![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to Talloc.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 40BSD / cmd / lisp|
Return to Talloc.c CVS log | Up to [CSRG BSD Unix] / 40BSD / cmd / lisp |
1.1 root 1:
2: static char *sccsid = "@(#)Talloc.c 34.11 10/31/80";
3:
4: # include "global.h"
5: # include "structs.h"
6: # ifndef UNIXTS
7: # include <vadvise.h>
8: # endif
9:
10: # define NUMWORDS TTSIZE * 128 /* max number of words in P0 space */
11: # define BITQUADS TTSIZE * 2 /* length of bit map in quad words */
12:
13: # define ftstbit asm(" ashl $-2,r11,r3");\
14: asm(" bbcs r3,_bitmapq,$1");\
15: asm(" .byte 4");
16: /* define ftstbit if( readbit(p) ) return; oksetbit; */
17: # define readbit(p) ((int)bitmap[r=(int)p>>5] & (s=bitmsk[((int)p>>2)&7]))
18: # define lookbit(p) (bitmap[(int)p>>5] & bitmsk[((int)p>>2) & 7])
19: # define setbit(p) {bitmap[(int)p>>5] |= bitmsk[((int)p >> 2) & 7];}
20: # define oksetbit {bitmap[r] |= s;}
21:
22: # define readchk(p) ((int)bitfre[(int)p>>5] & bitmsk[((int)p>>2)&7])
23: # define setchk(p) {bitfre[(int)p>>5] |= bitmsk[((int)p >> 2) & 7];}
24: # define roundup(x,l) (((x - 1) | (l - 1)) + 1)
25:
26: /* METER denotes something added to help meter storage allocation. */
27:
28: extern struct heads header[];
29:
30: FILE * chkport; /* garbage collection dump file */
31: extern lispval datalim; /* end of data space */
32: double bitmapq[BITQUADS]; /* the bit map--one bit per long */
33: #ifdef METER
34: double Mbitmapq[BITQUADS];
35: #endif
36: double zeroq; /* a quad word of zeros */
37: char *bitmap = (char *) bitmapq; /* byte version of bit map array */
38: int *bitmapi = (int *) bitmapq; /* integer version of bit map array */
39: #ifdef METER
40: int *Mbitmapi = (int *) Mbitmapq; /* integer version of bit map array */
41: int freefree,usedfree,freeused,usedused;
42: #endif
43: #ifndef METER
44: int freefree,usedfree,freeused,usedused; /* need so external refs will be
45: satisfied, remove when get rid
46: of meter stuff
47: */
48: #endif
49: char bitmsk[8]={1,2,4,8,16,32,64,128}; /* used by bit-marking macros */
50: extern int *bind_lists ; /* lisp data for compiled code */
51:
52: char *xsbrk();
53: char *gethspace();
54:
55:
56: int atmlen;
57:
58: extern struct types atom_str, strng_str, int_str, dtpr_str, doub_str,
59: array_str, sdot_str, val_str, funct_str, hunk_str[];
60:
61: lispval hunk_items[7], hunk_pages[7], hunk_name[7];
62:
63: extern int initflag; /* starts off TRUE: initially gc not allowed */
64:
65: int gcflag = FALSE; /* TRUE during garbage collection */
66:
67: int current = 0; /* number of pages currently allocated */
68:
69: static struct types *(spaces[NUMSPACES]) =
70: {&atom_str, &strng_str, &int_str,
71: &dtpr_str, &doub_str, &array_str,
72: &sdot_str, &val_str, &funct_str,
73: &hunk_str[0], &hunk_str[1], &hunk_str[2],
74: &hunk_str[3], &hunk_str[4], &hunk_str[5],
75: &hunk_str[6]};
76:
77: /* this is a table of pointers to collectable struct types objects
78: * the index is the type number.
79: */
80: struct types *gcableptr[] =
81: { (struct types *) 0, /* strings not collectable */
82: (struct types *) 0, /* atoms not collectable */
83: &int_str, &dtpr_str, &doub_str,
84: (struct types *) 0, /* binary objects not collectable */
85: (struct types *) 0, /* port objects not collectable */
86: &array_str,
87: (struct types *) 0, /* gap in the type number sequence */
88: &sdot_str,&val_str,
89: &hunk_str[0], &hunk_str[1], &hunk_str[2],
90: &hunk_str[3], &hunk_str[4], &hunk_str[5],
91: &hunk_str[6]};
92:
93:
94: /** get_more_space(type_struct) *****************************************/
95: /* */
96: /* Allocates and structures a new page, returning 0. */
97: /* If no space is available, returns 1. */
98:
99: get_more_space(type_struct)
100: struct types *type_struct;
101: {
102: int cntr;
103: char *start;
104: int *loop, *temp;
105: lispval p, plim;
106: struct heads *next; extern char holend[];
107:
108: if(initflag == FALSE)
109: /* mustn't look at plist of plima too soon */
110: {
111: while( plim=copval(plima,(lispval)CNIL), TYPE(plim)!=INT )
112: copval(plima,error("BAD PAGE LIMIT",TRUE));
113: if( plim->i <= current ) return(1); /* Can't allocate */
114: }
115:
116: if( current >= TTSIZE ) return(2);
117:
118: #ifdef HOLE
119: if(type_struct==&strng_str || (type_struct==&funct_str))
120: start = gethspace(NBPG,type_struct->type);
121: else
122: #endif
123: start = xsbrk();
124:
125:
126: SETTYPE(start, type_struct->type); /* set type of page */
127:
128: /* bump the page counter for this space */
129:
130: ++((*(type_struct->pages))->i);
131:
132: type_struct->space_left = type_struct->space;
133: if(start >= holend) {
134: next = &header[ current++ ];
135: next->pntr = start;
136: next->link = type_struct->first;
137: type_struct->first = next;
138: }
139: if(type_struct==&strng_str) {
140: type_struct->next_free = start;
141: return(0); /* space was available */
142: }
143: type_struct->first = next;
144: temp = loop = (int *) start;
145: for(cntr=1; cntr < type_struct->space; cntr++)
146: loop = (int *) (*loop = (int) (loop + type_struct->type_len));
147: *loop = (int) (type_struct->next_free);
148: type_struct->next_free = (char *) temp;
149:
150: /* if type atom, set pnames to CNIL */
151:
152: if( type_struct == &atom_str )
153: for(cntr=0, p=(lispval) temp; cntr<atom_str.space; ++cntr)
154: {
155: p->a.pname = (char *) CNIL;
156: p = (lispval) ((int *)p + atom_str.type_len);
157: }
158: return(0); /* space was available */
159: }
160:
161:
162: /** next_one(type_struct) ************************************************/
163: /* */
164: /* Allocates one new item of each kind of space, except STRNG. */
165: /* If there is no space, calls gc, the garbage collector. */
166: /* If there is still no space, allocates a new page using */
167: /* get_more_space(type_struct) */
168:
169: lispval
170: next_one(type_struct)
171: struct types *type_struct;
172: {
173:
174: register char *temp;
175: snpand(1);
176:
177: while(type_struct->next_free == (char *) CNIL)
178: {
179: int g;
180:
181: if((type_struct->type != ATOM) && /* can't collect atoms */
182: (type_struct->type != STRNG) && /* can't collect strings */
183: (type_struct->type != BCD) && /* nor function headers */
184: (gcthresh->i <= current) && /* threshhold for gc */
185: gcdis->a.clb == nil && /* gc not disabled */
186: (NOTNIL(copval(gcload,CNIL)) || (loading->a.clb != tatom)) &&
187: /* not to collect during load */
188: (initflag == FALSE) && /* dont gc during init */
189: (gcflag == FALSE)) /* don't recurse gc */
190:
191: {
192: /* fputs("Collecting",poport);
193: dmpport(poport);*/
194: gc(type_struct); /* collect */
195: }
196:
197: if( type_struct->next_free != (char *) CNIL ) break;
198:
199: if(! (g=get_more_space(type_struct))) break;
200:
201: if( g==1 )
202: {
203: plimit->i = current+NUMSPACES;
204: /* allow a few more pages */
205: copval(plima,plimit); /* restore to reserved reg */
206:
207: error("PAGE LIMIT EXCEEDED--EMERGENCY PAGES ALLOCATED",
208: TRUE);
209: }
210: else error("SORRY, ABSOLUTE PAGE LIMIT HAS BEEN REACHED",
211: TRUE);
212: }
213:
214: temp = type_struct->next_free;
215: type_struct->next_free = * (char **)(type_struct->next_free);
216: return((lispval) temp);
217: }
218:
219: lispval
220: newint()
221: {
222: ++(int_items->i);
223: return(next_one(&int_str));
224: }
225:
226: lispval
227: newdot()
228: {
229: lispval temp;
230:
231: ++(dtpr_items->i);
232: temp = next_one(&dtpr_str);
233: temp->d.car = temp->d.cdr = nil;
234: return(temp);
235: }
236:
237: lispval
238: newdoub()
239: {
240: ++(doub_items->i);
241: return(next_one(&doub_str));
242: }
243:
244: lispval
245: newsdot()
246: {
247: register lispval temp;
248: ++(dtpr_items->i);
249: temp = next_one(&sdot_str);
250: temp->d.car = temp->d.cdr = 0;
251: return(temp);
252: }
253:
254: struct atom *
255: newatom() {
256: struct atom *save;
257:
258: ++(atom_items->i);
259: save = (struct atom *) next_one(&atom_str) ;
260: save->plist = save->fnbnd = nil;
261: save->hshlnk = (struct atom *)CNIL;
262: save->clb = CNIL;
263: save->pname = newstr();
264: return (save);
265: }
266:
267: char *newstr() {
268: char *save;
269: int atmlen2,atmlen;
270:
271: ++(str_items->i);
272: atmlen = strlen(strbuf)+1;
273: if(atmlen > strng_str.space_left)
274: while(get_more_space(&strng_str))
275: error("YOU HAVE RUN OUT OF SPACE",TRUE);
276: strcpy((save = strng_str.next_free), strbuf);
277: atmlen2 = atmlen;
278: while(atmlen2 & 3) ++atmlen2; /* even up length of string */
279: strng_str.next_free += atmlen2;
280: strng_str.space_left -= atmlen2;
281: return(save);
282: }
283:
284: char *inewstr(s) char *s;
285: {
286: strbuf[STRBLEN-1] = '\0';
287: strcpyn(strbuf,s,STRBLEN-1);
288: return(newstr());
289: }
290:
291: lispval
292: newarray()
293: {
294: register lispval temp;
295:
296: ++(array_items->i);
297: temp = next_one(&array_str);
298: temp->ar.data = (char *)nil;
299: temp->ar.accfun = nil;
300: temp->ar.aux = nil;
301: temp->ar.length = SMALL(0);
302: temp->ar.delta = SMALL(0);
303: return(temp);
304: }
305:
306: lispval
307: badcall()
308: { error("BAD FUNCTION DESCRIPTOR USED IN CALL",FALSE); }
309:
310: lispval
311: newfunct()
312: {
313: register lispval temp;
314: ++(funct_items->i);
315: temp = next_one(&funct_str);
316: temp->bcd.entry = badcall;
317: temp->bcd.discipline = nil;
318: return(temp);
319: }
320:
321: lispval
322: newval()
323: {
324: register lispval temp;
325: ++(val_items->i);
326: temp = next_one(&val_str);
327: temp->l = nil;
328: return(temp);
329: }
330:
331: lispval
332: newhunk(hunknum)
333: int hunknum;
334: {
335: register lispval temp;
336:
337: ++(hunk_items[hunknum]->i); /* Update used hunks count */
338: temp = next_one(&hunk_str[hunknum]); /* Get a hunk */
339: return(temp);
340: }
341:
342: lispval
343: inewval(arg) lispval arg;
344: {
345: lispval temp;
346: ++(val_items->i);
347: temp = next_one(&val_str);
348: temp->l = arg;
349: return(temp);
350: }
351:
352:
353: /** Ngc *****************************************************************/
354: /* */
355: /* LISP interface to gc. */
356:
357: lispval Ngc()
358: {
359: lispval temp;
360:
361: if( ISNIL(lbot->val) ) return(gc(CNIL));
362:
363: if( TYPE(lbot->val) != DTPR ) error("BAD CALL TO GC",FALSE);
364:
365: chkport = poport;
366:
367: if( NOTNIL(lbot->val->d.car) )
368: {
369: temp = eval(lbot->val->d.car);
370: if( TYPE(temp) == PORT ) chkport = temp->p;
371: }
372:
373: gc1(TRUE);
374:
375: return(nil);
376: }
377:
378: /** gc(type_struct) *****************************************************/
379: /* */
380: /* garbage collector: Collects garbage by mark and sweep algorithm. */
381: /* After this is done, calls the Nlambda, gcafter. */
382: /* gc may also be called from LISP, as a lambda of no arguments. */
383:
384: lispval
385: gc(type_struct)
386: struct types *type_struct;
387: {
388: lispval save;
389: struct {
390: long mytime;
391: long allelse[3];
392: } begin, finish;
393: extern int GCtime;
394:
395: save = copval(gcport,CNIL);
396: if(GCtime)
397: times(&begin);
398:
399: while( (TYPE(save) != PORT) && NOTNIL(save))
400: save = error("NEED PORT FOR GC",TRUE);
401:
402: chkport = (ISNIL(save) ? poport : save->p);
403:
404: gc1(NOTNIL(copval(gccheck,CNIL)) || (chkport!=poport)); /* mark&sweep */
405:
406: /* Now we call gcafter--special case if gc called from LISP */
407:
408: if( type_struct == (struct types *) CNIL )
409: gccall1->d.cdr = nil; /* make the call "(gcafter)" */
410: else
411: {
412: gccall1->d.cdr = gccall2;
413: gccall2->d.car = *(type_struct->type_name);
414: }
415: {lispval temp;temp = rdrsdot, rdrsdot = rdrsdot2, rdrsdot2 = temp; /*KLUDGE*/}
416: gcflag = TRUE; /* flag to indicate in garbage collector */
417: save = eval(gccall1); /* call gcafter */
418: gcflag = FALSE; /* turn off flag */
419: {lispval temp;temp = rdrsdot, rdrsdot = rdrsdot2, rdrsdot2 = temp; /*KLUDGE*/}
420:
421: if(GCtime) {
422: times(&finish);
423: GCtime += (finish.mytime - begin.mytime);
424: }
425: return(save); /* return result of gcafter */
426: }
427:
428:
429:
430: /* gc1() **************************************************************/
431: /* */
432: /* Mark-and-sweep phase */
433:
434: gc1(chkflag) int chkflag;
435: {
436: int j, typep,k;
437: register int *start,bvalue,type_len;
438: register struct types *s;
439: int *point,i,freecnt,itemstogo,bits,bindex,type,enddat;
440: struct heads *loop;
441: struct argent *loop2;
442: struct nament *loop3;
443: #ifdef METER
444: int Mbvalue;
445: #endif
446: int markdp();
447: int debugin = FALSE; /* temp debug flag */
448: extern int *beginsweep;
449: #define ERDB(s) { printf(s); fflush(stdout); }
450:
451: #ifndef UNIXTS
452: vadvise(VA_ANOM);
453: /* decide whether to check LISP structure or not */
454: #endif
455:
456:
457:
458: /* first set all bit maps to zero */
459:
460:
461: if(debugin) ERDB("Begin gc\n");
462: enddat = (int)datalim >> 8;
463: for(bvalue=0; bvalue < (int)enddat ; ++bvalue)
464: {
465: #ifdef METER
466: /* Mbitmapq[bvalue] = bitmapq[bvalue]; /* remember old vals */
467: /* the C compiler will use a movd if we let it,and this
468: will not work since the bit maps may be illegal
469: floating point values
470: */
471: asm(" movq _bitmapq[r10],_Mbitmapq[r10] ");
472: #endif
473: bitmapq[bvalue] = zeroq;
474: }
475:
476: /* try the movc5 to clear the bit maps */
477: /* blzero(bitmap,TTSIZE * 16); */
478:
479:
480: /* then mark all atoms' plists, clbs, and function bindings */
481:
482: for(loop=atom_str.first; loop!=(struct heads *)CNIL; loop=loop->link)
483: for(start=(int *)(loop->pntr), i=1;
484: i <= atom_str.space;
485: start = start + atom_str.type_len, ++i)
486: {
487:
488: /* unused atoms are marked with pname == CNIL */
489: /* this is done by get_more_space, as well as */
490: /* by gc (in the future) */
491:
492: if(((lispval)start)->a.pname == (char *)CNIL) continue;
493: #define MARKSUB(p) if(nil!=((lispval)start)->p)markdp(((lispval)start)->p);
494: MARKSUB(a.clb);
495: MARKSUB(a.fnbnd);
496: MARKSUB(a.plist);
497: }
498:
499: /* Mark all the atoms and ints associated with the hunk
500: data types */
501:
502: for(i=0; i<8; i++) {
503: markdp(hunk_items[i]);
504: markdp(hunk_name[i]);
505: markdp(hunk_pages[i]);
506: }
507: /* next run up the name stack */
508: if(debugin) ERDB("name stack\n");
509: for(loop2 = np - 1; loop2 >= orgnp; --loop2) markdp((loop2->val));
510:
511: /* now the bindstack (vals only, atoms are marked elsewhere ) */
512: for(loop3 = bnp - 1; loop3 >= orgbnp; --loop3)markdp(loop3->val);
513:
514: if(debugin) ERDB("compiler stuff\n");
515: /* from TBL 29july79 */
516: /* next mark all compiler linked data */
517: point = bind_lists;
518: while((start = point) != (int *)CNIL) {
519: if(debugin) ERDB("once ");
520: while( *start != -1 )
521: markdp(*start++);
522: point = (int *)*(point-1);
523: }
524: /* end from TBL */
525:
526: if(debugin) ERDB("signif stuff\n");
527: /* next mark all system-significant lisp data */
528:
529: for(i=0; i<SIGNIF; ++i) markdp((lispsys[i]));
530:
531: if(debugin) printf("time to sweep up\n");
532: /* all accessible data has now been marked. */
533: /* all collectable spaces must be swept, */
534: /* and freelists constructed. */
535:
536: /* first clear the structure elements for types
537: * we will sweep
538: */
539:
540: for(k=0 ; k <= HUNK128 ; k++)
541: {
542: if( s=gcableptr[k] )
543: {
544: (*(s->items))->i = 0;
545: s->space_left = 0;
546: s->next_free = (char *) CNIL;
547: }
548: }
549:
550:
551: /* sweep up in memory looking at gcable pages */
552:
553: for(start = beginsweep, bindex = (int)start >> 7;
554: start < (int *)datalim;
555: start += 128)
556: {
557: /* printf(" start %x, bindex %x\n",start,bindex); */
558: if(!(s=gcableptr[type = TYPE(start)]))
559: {
560: bindex += 4; /* and 4 words of 32 bit bitmap words */
561: continue;
562: }
563:
564: freecnt = 0; /* number of free items found */
565: itemstogo = s->space; /* number of items per page */
566: bits = 32; /* number of bits per word */
567: type_len = s->type_len;
568:
569: /* printf(" s %d, itemstogo %d, len %d\n",s,itemstogo,type_len);*/
570: bvalue = bitmapi[bindex++];
571: #ifdef METER
572: Mbvalue = Mbitmapi[bindex-1];
573: #endif
574:
575: point = start;
576: while(TRUE)
577: {
578: /*printf(" bv: %08x, ",bvalue);*/
579: if(!(bvalue & 1)) /* if data element is not marked */
580: {
581: freecnt++;
582: *point = (int) (s->next_free) ;
583: s->next_free = (char *) point;
584: #ifdef METER
585: if(type == DTPR)
586: {
587: if(Mbvalue & 1) usedfree++;
588: else freefree++;
589: }
590: #endif
591: }
592: #ifdef METER
593: else if(type == DTPR)
594: {
595: if (Mbvalue & 1) usedused++;
596: else freeused++;
597: }
598: #endif
599:
600: if( --itemstogo <= 0 )
601: { if(type_len >= 64)
602: {
603: bindex++;
604: if(type_len >=128) bindex += 2;
605: }
606: break;
607: }
608:
609: point += type_len;
610: /* shift over mask by number of words in data type */
611:
612: if( (bits -= type_len) > 0)
613: { bvalue = bvalue >> type_len;
614: #ifdef METER
615: Mbvalue = Mbvalue >> type_len;
616: #endif
617: }
618: else if( bits == 0 )
619: { bvalue = bitmapi[bindex++];
620: #ifdef METER
621: Mbvalue = Mbitmapi[bindex-1];
622: #endif
623: bits = 32;
624: }
625: else
626: { bits = -bits;
627: while( bits >= 32) { bindex++;
628: bits -= 32;
629: }
630: bvalue = bitmapi[bindex++];
631: bvalue = bvalue >> bits;
632: #ifdef METER
633: Mbvalue = Mbitmapi[bindex-1];
634: Mbvalue = Mbvalue >> bits;
635: #endif
636: bits = 32 - bits;;
637: }
638: }
639:
640: /* printf(" t %d,fr %d ",type,freecnt); */
641: s->space_left += freecnt;
642: (*(s->items))->i += s->space - freecnt;
643: }
644:
645: #ifndef UNIXTS
646: vadvise(VA_NORM);
647: #endif
648: }
649:
650: /** alloc() *************************************************************/
651: /* */
652: /* This routine tries to allocate one more page of the space named */
653: /* by the argument. If no more space is available returns 1, else 0. */
654:
655: lispval
656: alloc(tname,npages)
657: lispval tname; int npages;
658: {
659: int ii, jj;
660:
661: ii = typenum(tname);
662:
663: if(((int)datalim >> 9) + npages > TTSIZE)
664: error("Space request would exceed maximum memory allocation",FALSE);
665:
666: for( jj=0; jj<npages; ++jj)
667: if(get_more_space(spaces[ii])) break;
668: return(inewint(jj));
669: }
670:
671: lispval
672: csegment(tname,nitems,useholeflag)
673: lispval tname; int nitems;
674: {
675: int ii, jj;
676: char *charadd;
677:
678: ii = typenum(tname);
679:
680: nitems = nitems*4*spaces[ii]->type_len; /* find c-length of space */
681: nitems = roundup(nitems,512); /* round up to right length */
682: #ifdef HOLE
683: if((tname==str_name) && useholeflag)
684: charadd = gethspace(nitems,ii);
685: else
686: #endif
687: {
688: current += nitems/512;
689: charadd = sbrk(nitems);
690: datalim = (lispval)(charadd+nitems);
691: }
692: if( (int) charadd == 0 )
693: error("NOT ENOUGH SPACE FOR ARRAY",FALSE);
694: if((((int)datalim) >> 9) > TTSIZE) {
695: datalim = (lispval) (TTSIZE << 9);
696: badmem(53);
697: }
698: for(jj=0; jj<nitems; jj=jj+512) {
699: SETTYPE(charadd+jj, spaces[ii]->type);
700: }
701: blzero(charadd,nitems);
702: return((lispval)charadd);
703: }
704:
705: int csizeof(tname) lispval tname;
706: {
707: return( spaces[typenum(tname)]->type_len * 4 );
708: }
709:
710: int typenum(tname) lispval tname;
711: {
712: int ii;
713:
714: chek: for(ii=0; ii<NUMSPACES; ++ii)
715: if(tname == *(spaces[ii]->type_name)) break;
716: if(ii == NUMSPACES)
717: {
718: tname = error("BAD TYPE NAME",TRUE);
719: goto chek;
720: }
721:
722: return(ii);
723:
724: }
725: char *
726: gethspace(segsiz,type)
727: {
728: extern usehole; extern char holend[]; extern char *curhbeg;
729: register char *value;
730:
731: if(usehole) {
732: curhbeg = (char *) roundup(((int)curhbeg),NBPG);
733: if((holend - curhbeg) < segsiz)
734: { printf("[fasl hole filled up]\n");
735: usehole = FALSE;
736: } else {
737: value = curhbeg;
738: curhbeg = curhbeg + segsiz;
739: /*printf("start %d, finish %d, size %d\n",value, curhbeg,segsiz);*/
740: return(value);
741: }
742: }
743: value = (ysbrk(segsiz/NBPG,type));
744: datalim = (lispval)(value + segsiz);
745: return(value);
746: }
747: gcrebear()
748: {
749: #ifdef HOLE
750: /* this gets done upon rebirth */
751: strng_str.space_left = 0;
752: funct_str.space_left = 0;
753: funct_str.next_free = (char *) CNIL;
754: #endif
755: }
756:
757: /** markit(p) ***********************************************************/
758: /* just calls markdp */
759:
760: markit(p) lispval *p; { markdp(*p); }
761:
762: /** markdp(p) ***********************************************************/
763: /* */
764: /* markdp is the routine which marks each data item. If it is a */
765: /* dotted pair, the car and cdr are marked also. */
766: /* An iterative method is used to mark list structure, to avoid */
767: /* excessive recursion. */
768:
769:
770: markdp(p) register lispval p;
771: {
772: /* register int r, s; (goes with non-asm readbit, oksetbit) */
773: /* register hsize, hcntr; */
774: int hsize, hcntr;
775:
776: ptr_loop:
777: if((int)p <= 0) return; /* do not mark special data types or nil=0 */
778:
779: switch( TYPE(p) )
780: {
781: case INT:
782: case DOUB:
783: /* setbit(p);*/
784: ftstbit;
785: return;
786: case VALUE:
787: ftstbit;
788: p = p->l;
789: goto ptr_loop;
790: case DTPR:
791: ftstbit;
792: markdp(p->d.car);
793: p = p->d.cdr;
794: goto ptr_loop;
795:
796: case ARRAY:
797: ftstbit; /* mark array itself */
798:
799: markdp(p->ar.accfun); /* mark access function */
800: markdp(p->ar.aux); /* mark aux data */
801: markdp(p->ar.length); /* mark length */
802: markdp(p->ar.delta); /* mark delta */
803: if(TYPE(p->ar.aux)==DTPR && p->ar.aux->d.car==Vnogbar)
804: return;
805: {
806: /* register int i, l; int d; */
807: /* register char *dataptr = p->ar.data; */
808: int i,l,d;
809: char *dataptr = p->ar.data;
810:
811: for(i=0, l=p->ar.length->i, d=p->ar.delta->i; i<l; ++i)
812: {
813: markdp(dataptr);
814: dataptr += d;
815: }
816: return;
817: }
818: case SDOT:
819: do {
820: ftstbit;
821: p = p->s.CDR;
822: } while (p!=0);
823: return;
824:
825: case BCD:
826: ftstbit;
827: markdp(p->bcd.discipline);
828: return;
829:
830: case HUNK2:
831: case HUNK4:
832: case HUNK8:
833: case HUNK16:
834: case HUNK32:
835: case HUNK64:
836: case HUNK128:
837: {
838: hsize = 2 << HUNKSIZE(p);
839: ftstbit;
840: for (hcntr = 0; hcntr < hsize; hcntr++)
841: markdp(p->h.hunk[hcntr]);
842: return;
843: }
844: }
845: return;
846: }
847:
848:
849:
850: char *
851: xsbrk()
852: {
853: static char *xx; /* pointer to next available blank page */
854: extern int xcycle; /* number of blank pages available */
855: lispval u; /* used to compute limits of bit table */
856:
857: if( (xcycle--) <= 0 )
858: {
859: xcycle = 15;
860: xx = sbrk(16*NBPG); /* get pages 16 at a time */
861: if( (int)xx== -1 )
862: lispend("For sbrk from lisp: no space... Goodbye!");
863: goto done;
864: }
865: xx += NBPG;
866: done: if( (u = (lispval)(xx+NBPG)) > datalim ) datalim = u;
867: return(xx);
868: }
869:
870: char *ysbrk(pages,type) int pages, type;
871: {
872: char *xx; /* will point to block of storage */
873: int i;
874:
875: xx = sbrk(pages*NBPG);
876: if((int)xx == -1)
877: error("OUT OF SPACE FOR ARRAY REQUEST",FALSE);
878:
879: datalim = (lispval)(xx+pages*NBPG); /* compute bit table limit */
880:
881: /* set type for pages */
882:
883: for(i = 0; i < pages; ++i) {
884: SETTYPE((xx + i*NBPG),type);
885: }
886:
887: return(xx); /* return pointer to block of storage */
888: }
889:
890: #ifdef VMS
891: /* sbrk -
892: * this function is used by the VMS franz to allocate space.
893: * It allocates space in the zfreespace array.
894: * The single argument passed to sbrk is the number of bytes to allocate
895: *
896: */
897:
898: extern char zfreespace[];
899: extern char *lsbrkpnt;
900:
901: char *
902: sbrk(n)
903: {
904: char *result;
905: if(lsbrkpnt == (char *)0)
906: {
907: lsbrkpnt = (char *) roundup((int)zfreespace,NBPG);
908: }
909: result = lsbrkpnt;
910: /* printf("lispbrk: %x \n",lsbrkpnt);
911: fflush(stdout); */
912: lsbrkpnt += n;
913: if(lsbrkpnt > &zfreespace[FREESIZE])
914: error("sbrk: out of space ",FALSE);
915: return(result);
916: }
917: #endif
918: /* getatom **************************************************************/
919: /* returns either an existing atom with the name specified in strbuf, or*/
920: /* if the atom does not already exist, regurgitates a new one and */
921: /* returns it. */
922: lispval
923: getatom()
924: { register lispval aptr;
925: register char *name, *endname;
926: register int hash;
927: register struct argent *lbot, *np;
928: lispval b;
929: char c;
930:
931: name = strbuf;
932: if (*name == (char)0377) return (eofa);
933: hash = hashfcn(name);
934: atmlen = strlen(name) + 1;
935: aptr = (lispval) hasht[hash];
936: while (aptr != CNIL)
937: if (strcmp(name,aptr->a.pname)==0)
938: return (aptr);
939: else
940: aptr = (lispval) aptr->a.hshlnk;
941: aptr = (lispval) newatom();
942: aptr->a.hshlnk = hasht[hash];
943: hasht[hash] = (struct atom *) aptr;
944: endname = name + atmlen - 2;
945: if ((atmlen != 4) && (*name == 'c') && (*endname == 'r'))
946: {
947: b = newdot();
948: protect(b);
949: b->d.car = lambda;
950: b->d.cdr = newdot();
951: b = b->d.cdr;
952: b->d.car = newdot();
953: (b->d.car)->d.car = xatom;
954: while(TRUE)
955: {
956: b->d.cdr = newdot();
957: b= b->d.cdr;
958: if(++name == endname)
959: {
960: b->d.car= (lispval) xatom;
961: aptr->a.fnbnd = unprot();
962: break;
963: }
964: b->d.car= newdot();
965: b= b->d.car;
966: if((c = *name) == 'a') b->d.car = cara;
967: else if (c == 'd') b->d.car = cdra;
968: else{ unprot();
969: break;
970: }
971: }
972: }
973:
974: return(aptr);
975: }
976:
977: /* our hash function */
978:
979: hashfcn(symb)
980: char *symb;
981: {
982: register int i;
983: for (i=0 ; *symb ; i += i + *symb++);
984: return(i & (HASHTOP-1));
985: }
986:
987: extern struct atom *hasht[HASHTOP];
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.