![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to alloc.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSDReno / pgrm / lisp / franz|
Return to alloc.c CVS log | Up to [CSRG BSD Unix] / 43BSDReno / pgrm / lisp / franz |
1.1 root 1: #ifndef lint
2: static char *rcsid =
3: "$Header: alloc.c,v 1.13 87/12/11 17:27:45 sklower Exp $";
4: #endif
5:
6: /*
7: * alloc.c $Locker: $
8: * storage allocator and garbage collector
9: *
10: * (c) copyright 1982, Regents of the University of California
11: */
12:
13: # include "global.h"
14: # include "structs.h"
15:
16: #include <sys/types.h>
17: #include <sys/times.h>
18: #ifdef METER
19: #include <sys/vtimes.h>
20: #endif
21:
22: # define NUMWORDS TTSIZE * 128 /* max number of words in P0 space */
23: # define BITQUADS TTSIZE * 2 /* length of bit map in quad words */
24: # define BITLONGS TTSIZE * 4 /* length of bit map in long words */
25:
26: # ifdef vax
27: # define ftstbit asm(" ashl $-2,r11,r3");\
28: asm(" bbcs r3,_bitmapi,1f");\
29: asm(" ret"); \
30: asm("1:");
31:
32: /* setbit is a fast way of setting a bit, it is like ftstbit except it
33: * always continues on to the next instruction
34: */
35: # define setbit asm(" ashl $-2,r11,r0"); \
36: asm(" bbcs r0,_bitmapi,$0");
37: # endif
38:
39: # if m_68k
40: # define ftstbit {if(Itstbt()) return;}
41: # define setbit Itstbt()
42: # endif
43:
44: # ifdef tahoe
45: # define ftstbit if( readbit(p) ) return; oksetbit;
46: # define setbit {bitmapi[(int)p>>7] |= bitmsk[((int)p >> 2)&31];}
47: # define readbit(p) ((int)bitmapi[r=(int)p>>7] & (s=bitmsk[((int)p>>2)&31]))
48: # define oksetbit {bitmapi[r] |= s;}
49: # endif
50:
51: /* Unused bit macros
52: # define lookbit(p) (bbitmap[(int)p>>5] & bitmsk[((int)p>>2) & 7])
53: # define readchk(p) ((int)bitfre[(int)p>>5] & bitmsk[((int)p>>2)&7])
54: # define setchk(p) {bitfre[(int)p>>5] |= bitmsk[((int)p >> 2) & 7];}
55: */
56:
57: # define roundup(x,l) (((x - 1) | (l - 1)) + 1)
58:
59: # define MARKVAL(v) if(((int)v) >= (int)beginsweep) markdp(v);
60: # define ATOLX(p) ((((int)p)-OFFSET)>>7)
61:
62: /* the Vax hardware only allows 2^16-1 bytes to be accessed with one
63: * movc5 instruction. We use the movc5 instruction to clear the
64: * bitmaps.
65: */
66: # define MAXCLEAR ((1<<16)-1)
67:
68: /* METER denotes something added to help meter storage allocation. */
69:
70: extern int *beginsweep; /* first sweepable data */
71: extern char purepage[];
72: extern int fakettsize;
73: extern int gcstrings;
74: int debugin = FALSE; /* temp debug flag */
75:
76: extern lispval datalim; /* end of data space */
77: int bitmapi[BITLONGS]; /* the bit map--one bit per long */
78: double zeroq; /* a quad word of zeros */
79: char *bbitmap = (char *) bitmapi; /* byte version of bit map array */
80: double *qbitmap = (double *) bitmapi; /* integer version of bit map array */
81: #ifdef METER
82: extern int gcstat;
83: extern struct vtimes
84: premark,presweep,alldone; /* actually struct tbuffer's */
85:
86: extern int mrkdpcnt;
87: extern int conssame, consdiff,consnil; /* count of cells whose cdr point
88: * to the same page and different
89: * pages respectively
90: */
91: #endif
92: int bitmsk[32]={1,2,4,8,16,32,64,128, /* used by bit-marking macros */
93: 0x100, 0x200, 0x400, 0x800,
94: 0x1000, 0x2000, 0x4000, 0x8000,
95: 0x10000, 0x20000, 0x40000, 0x80000,
96: 0x100000, 0x200000, 0x400000, 0x800000,
97: 0x1000000, 0x2000000, 0x4000000, 0x8000000,
98: 0x10000000, 0x20000000, 0x40000000, 0x80000000};
99: extern int *bind_lists; /* lisp data for compiled code */
100:
101: char *xsbrk();
102: char *gethspace();
103:
104:
105: extern struct types atom_str, strng_str, int_str, dtpr_str, doub_str,
106: array_str, sdot_str, val_str, funct_str, hunk_str[], vect_str,
107: vecti_str, other_str;
108:
109: extern struct str_x str_current[];
110:
111: lispval hunk_items[7], hunk_pages[7], hunk_name[7];
112:
113: extern int initflag; /* starts off TRUE: initially gc not allowed */
114:
115:
116: /* this is a table of pointers to all struct types objects
117: * the index is the type number.
118: */
119: static struct types *spaces[NUMSPACES] =
120: {&strng_str, &atom_str, &int_str,
121: &dtpr_str, &doub_str, &funct_str,
122: (struct types *) 0, /* port objects not allocated in this way */
123: &array_str,
124: &other_str, /* other objects not allocated in this way */
125: &sdot_str,&val_str,
126: &hunk_str[0], &hunk_str[1], &hunk_str[2],
127: &hunk_str[3], &hunk_str[4], &hunk_str[5],
128: &hunk_str[6],
129: &vect_str, &vecti_str};
130:
131:
132: /* this is a table of pointers to collectable struct types objects
133: * the index is the type number.
134: */
135: struct types *gcableptr[] = {
136: #ifndef GCSTRINGS
137: (struct types *) 0, /* strings not collectable */
138: #else
139: &strng_str,
140: #endif
141: &atom_str,
142: &int_str, &dtpr_str, &doub_str,
143: (struct types *) 0, /* binary objects not collectable */
144: (struct types *) 0, /* port objects not collectable */
145: &array_str,
146: (struct types *) 0, /* gap in the type number sequence */
147: &sdot_str,&val_str,
148: &hunk_str[0], &hunk_str[1], &hunk_str[2],
149: &hunk_str[3], &hunk_str[4], &hunk_str[5],
150: &hunk_str[6],
151: &vect_str, &vecti_str};
152:
153:
154: /*
155: * get_more_space(type_struct,purep)
156: *
157: * Allocates and structures a new page, returning 0.
158: * If no space is available, returns positive number.
159: * If purep is TRUE, then pure space is allocated.
160: */
161: get_more_space(type_struct,purep)
162: struct types *type_struct;
163: {
164: int cntr;
165: char *start;
166: int *loop, *temp;
167: lispval p;
168: extern char holend[];
169:
170: if( (int) datalim >= TTSIZE*LBPG+OFFSET ) return(2);
171:
172: /*
173: * If the hole is defined, then we allocate binary objects
174: * and strings in the hole. However we don't put strings in
175: * the hole if strings are gc'ed.
176: */
177: #ifdef HOLE
178: if( purep
179: #ifndef GCSTRINGS
180: || type_struct==&strng_str
181: #endif
182: || type_struct==&funct_str)
183: start = gethspace(LBPG,type_struct->type);
184: else
185: #endif
186: start = xsbrk(1); /* get new page */
187:
188:
189: SETTYPE(start, type_struct->type,20); /* set type of page */
190:
191: purepage[ATOX(start)] = (char)purep; /* remember if page was pure*/
192:
193: /* bump the page counter for this space if not pure */
194:
195: if(!purep) ++((*(type_struct->pages))->i);
196:
197: type_struct->space_left = type_struct->space;
198: temp = loop = (int *) start;
199: for(cntr=1; cntr < type_struct->space; cntr++)
200: loop = (int *) (*loop = (int) (loop + type_struct->type_len));
201:
202: /* attach new cells to either the pure space free list or the
203: * standard free list
204: */
205: if(purep) {
206: *loop = (int) (type_struct->next_pure_free);
207: type_struct->next_pure_free = (char *) temp;
208: }
209: else {
210: *loop = (int) (type_struct->next_free);
211: type_struct->next_free = (char *) temp;
212: }
213:
214: /* if type atom, set pnames to CNIL */
215:
216: if( type_struct == &atom_str )
217: for(cntr=0, p=(lispval) temp; cntr<atom_str.space; ++cntr)
218: {
219: p->a.pname = (char *) CNIL;
220: p = (lispval) ((int *)p + atom_str.type_len);
221: }
222: return(0); /* space was available */
223: }
224:
225:
226: /*
227: * next_one(type_struct)
228: *
229: * Allocates one new item of each kind of space, except STRNG.
230: * If there is no space, calls gc, the garbage collector.
231: * If there is still no space, allocates a new page using
232: * get_more_space
233: */
234:
235: lispval
236: next_one(type_struct)
237: struct types *type_struct;
238: {
239:
240: register char *temp;
241:
242: while(type_struct->next_free == (char *) CNIL)
243: {
244: int g;
245:
246: if(
247: (initflag == FALSE) && /* dont gc during init */
248: #ifndef GCSTRINGS
249: (type_struct->type != STRNG) && /* can't collect strings */
250: #else
251: gcstrings && /* user (sstatus gcstrings) */
252: #endif
253: (type_struct->type != BCD) && /* nor function headers */
254: gcdis->a.clb == nil ) /* gc not disabled */
255: /* not to collect during load */
256:
257: {
258: gc(type_struct); /* collect */
259: }
260:
261: if( type_struct->next_free != (char *) CNIL ) break;
262:
263: if(! (g=get_more_space(type_struct,FALSE))) break;
264:
265: space_warn(g);
266: }
267: temp = type_struct->next_free;
268: type_struct->next_free = * (char **)(type_struct->next_free);
269: (*(type_struct->items))->i ++;
270: return((lispval) temp);
271: }
272: /*
273: * Warn about exhaustion of space,
274: * shared with next_pure_free().
275: */
276: space_warn(g)
277: {
278: if( g==1 ) {
279: plimit->i += NUMSPACES; /* allow a few more pages */
280: copval(plima,plimit); /* restore to reserved reg */
281:
282: error("PAGE LIMIT EXCEEDED--EMERGENCY PAGES ALLOCATED", TRUE);
283: } else error("SORRY, ABSOLUTE PAGE LIMIT HAS BEEN REACHED", TRUE);
284: }
285:
286:
287: /* allocate an element of a pure structure. Pure structures will
288: * be ignored by the garbage collector.
289: */
290: lispval
291: next_pure_one(type_struct)
292: struct types *type_struct;
293: {
294:
295: register char *temp;
296:
297: while(type_struct->next_pure_free == (char *) CNIL)
298: {
299: int g;
300: if(! (g=get_more_space(type_struct,TRUE))) break;
301: space_warn(g);
302: }
303:
304: temp = type_struct->next_pure_free;
305: type_struct->next_pure_free = * (char **)(type_struct->next_pure_free);
306: return((lispval) temp);
307: }
308:
309: lispval
310: newint()
311: {
312: return(next_one(&int_str));
313: }
314:
315: lispval
316: pnewint()
317: {
318: return(next_pure_one(&int_str));
319: }
320:
321: lispval
322: newdot()
323: {
324: lispval temp;
325:
326: temp = next_one(&dtpr_str);
327: temp->d.car = temp->d.cdr = nil;
328: return(temp);
329: }
330:
331: lispval
332: pnewdot()
333: {
334: lispval temp;
335:
336: temp = next_pure_one(&dtpr_str);
337: temp->d.car = temp->d.cdr = nil;
338: return(temp);
339: }
340:
341: lispval
342: newdoub()
343: {
344: return(next_one(&doub_str));
345: }
346:
347: lispval
348: pnewdb()
349: {
350: return(next_pure_one(&doub_str));
351: }
352:
353: lispval
354: newsdot()
355: {
356: register lispval temp;
357: temp = next_one(&sdot_str);
358: temp->d.car = temp->d.cdr = 0;
359: return(temp);
360: }
361:
362: lispval
363: pnewsdot()
364: {
365: register lispval temp;
366: temp = next_pure_one(&sdot_str);
367: temp->d.car = temp->d.cdr = 0;
368: return(temp);
369: }
370:
371: struct atom *
372: newatom(pure) {
373: struct atom *save; char *mypname;
374:
375: mypname = newstr(pure);
376: pnameprot = ((lispval) mypname);
377: save = (struct atom *) next_one(&atom_str) ;
378: save->plist = save->fnbnd = nil;
379: save->hshlnk = (struct atom *)CNIL;
380: save->clb = CNIL;
381: save->pname = mypname;
382: return (save);
383: }
384:
385: char *
386: newstr(purep) {
387: char *save, *strcpy();
388: int atmlen;
389: register struct str_x *p = str_current + purep;
390:
391: atmlen = strlen(strbuf)+1;
392: if(atmlen > p->space_left) {
393: if(atmlen >= STRBLEN) {
394: save = (char *)csegment(OTHER, atmlen, purep);
395: SETTYPE(save,STRNG,40);
396: purepage[ATOX(save)] = (char)purep;
397: strcpy(save,strbuf);
398: return(save);
399: }
400: p->next_free = (char *) (purep ?
401: next_pure_one(&strng_str) : next_one(&strng_str)) ;
402: p->space_left = LBPG;
403: }
404: strcpy((save = p->next_free), strbuf);
405: /*while(atmlen & 3) ++atmlen; /* even up length of string */
406: p->next_free += atmlen;
407: p->space_left -= atmlen;
408: return(save);
409: }
410:
411: static char * Iinewstr(s,purep) char *s;
412: {
413: int len = strlen(s);
414: while(len > (endstrb - strbuf - 1)) atomtoolong(strbuf);
415: strcpy(strbuf,s);
416: return(newstr(purep));
417: }
418:
419:
420: char *inewstr(s) char *s;
421: {
422: Iinewstr(s,0);
423: }
424:
425: char *pinewstr(s) char *s;
426: {
427: Iinewstr(s,1);
428: }
429:
430: lispval
431: newarray()
432: {
433: register lispval temp;
434:
435: temp = next_one(&array_str);
436: temp->ar.data = (char *)nil;
437: temp->ar.accfun = nil;
438: temp->ar.aux = nil;
439: temp->ar.length = SMALL(0);
440: temp->ar.delta = SMALL(0);
441: return(temp);
442: }
443:
444: lispval
445: newfunct()
446: {
447: register lispval temp;
448: lispval Badcall();
449: temp = next_one(&funct_str);
450: temp->bcd.start = Badcall;
451: temp->bcd.discipline = nil;
452: return(temp);
453: }
454:
455: lispval
456: newval()
457: {
458: register lispval temp;
459: temp = next_one(&val_str);
460: temp->l = nil;
461: return(temp);
462: }
463:
464: lispval
465: pnewval()
466: {
467: register lispval temp;
468: temp = next_pure_one(&val_str);
469: temp->l = nil;
470: return(temp);
471: }
472:
473: lispval
474: newhunk(hunknum)
475: int hunknum;
476: {
477: register lispval temp;
478:
479: temp = next_one(&hunk_str[hunknum]); /* Get a hunk */
480: return(temp);
481: }
482:
483: lispval
484: pnewhunk(hunknum)
485: int hunknum;
486: {
487: register lispval temp;
488:
489: temp = next_pure_one(&hunk_str[hunknum]); /* Get a hunk */
490: return(temp);
491: }
492:
493: lispval
494: inewval(arg) lispval arg;
495: {
496: lispval temp;
497: temp = next_one(&val_str);
498: temp->l = arg;
499: return(temp);
500: }
501:
502: /*
503: * Vector allocators.
504: * a vector looks like:
505: * longword: N = size in bytes
506: * longword: pointer to lisp object, this is the vector property field
507: * N consecutive bytes
508: *
509: */
510: lispval getvec();
511:
512: lispval
513: newvec(size)
514: {
515: return(getvec(size,&vect_str,FALSE));
516: }
517:
518: lispval
519: pnewvec(size)
520: {
521: return(getvec(size,&vect_str,TRUE));
522: }
523:
524: lispval
525: nveci(size)
526: {
527: return(getvec(size,&vecti_str,FALSE));
528: }
529:
530: lispval
531: pnveci(size)
532: {
533: return(getvec(size,&vecti_str,TRUE));
534: }
535:
536: /*
537: * getvec
538: * get a vector of size byte, from type structure typestr and
539: * get it from pure space if purep is TRUE.
540: * vectors are stored linked through their property field. Thus
541: * when the code here refers to v.vector[0], it is the prop field
542: * and vl.vectorl[-1] is the size field. In other code,
543: * v.vector[-1] is the prop field, and vl.vectorl[-2] is the size.
544: */
545: lispval
546: getvec(size,typestr,purep)
547: register struct types *typestr;
548: {
549: register lispval back, current;
550: int sizewant, bytes, thissize, pages, pindex, triedgc = FALSE;
551:
552: /* we have to round up to a multiple of 4 bytes to determine the
553: * size of vector we want. The rounding up assures that the
554: * property pointers are longword aligned
555: */
556: sizewant = VecTotSize(size);
557: if(debugin) fprintf(stderr,"want vect %db\n",size);
558: again:
559: if(purep)
560: back = (lispval) &(typestr->next_pure_free);
561: else
562: back = (lispval) &(typestr->next_free);
563: current = back->v.vector[0];
564: while(current != CNIL)
565: {
566: if(debugin)
567: fprintf(stderr,"next free size %db; ", current->vl.vectorl[-1]);
568: if ((thissize = VecTotSize(current->vl.vectorl[-1])) == sizewant)
569: {
570: if(debugin) fprintf(stderr,"exact match of size %d at 0x%x\n",
571: 4*thissize, ¤t->v.vector[1]);
572: back->v.vector[0]
573: = current->v.vector[0];/* change free pointer*/
574: current->v.vector[0] = nil; /* put nil in property */
575: /* to the user, vector begins one after property*/
576: return((lispval)¤t->v.vector[1]);
577: }
578: else if (thissize >= sizewant + 3)
579: {
580: /* the reason that there is a `+ 3' instead of `+ 2'
581: * is that we don't want to leave a zero sized vector which
582: * isn't guaranteed to be followed by another vector
583: */
584: if(debugin)
585: fprintf(stderr,"breaking a %d vector into a ",
586: current->vl.vectorl[-1]);
587:
588: current->v.vector[1+sizewant+1]
589: = current->v.vector[0]; /* free list pointer */
590: current->vl.vectorl[1+sizewant]
591: = VecTotToByte(thissize - sizewant - 2);/*size info */
592: back->v.vector[0] = (lispval) &(current->v.vector[1+sizewant+1]);
593: current->vl.vectorl[-1] = size;
594:
595: if(debugin)fprintf(stderr," %d one and a %d one\n",
596: current->vl.vectorl[-1],current->vl.vectorl[1+sizewant]);
597: current->v.vector[0] = nil; /* put nil in property */
598: /* vector begins one after the property */
599: if(debugin) fprintf(stderr," and returning vector at 0x%x\n",
600: ¤t->v.vector[1]);
601: return((lispval)(¤t->v.vector[1]));
602: }
603: back = current;
604: current = current->v.vector[0];
605: }
606: if(!triedgc
607: && !purep
608: && (gcdis->a.clb == nil)
609: && (initflag == FALSE))
610: {
611: gc(typestr);
612: triedgc = TRUE;
613: goto again;
614: }
615:
616: /* set bytes to size needed for this vector */
617: bytes = size + 2*sizeof(long);
618:
619: /* must make sure that if the vector we are allocating doesnt
620: completely fill a page, there is room for another vector to record
621: the size left over */
622: if((bytes & (LBPG - 1)) > (LBPG - 2*sizeof(long))) bytes += LBPG;
623: bytes = roundup(bytes,LBPG);
624:
625: current = csegment(typestr->type,bytes/sizeof(long),purep);
626: current->vl.vectorl[0] = bytes - 2*sizeof(long);
627:
628: if(purep) {
629: current->v.vector[1] = (lispval)(typestr->next_pure_free);
630: typestr->next_pure_free = (char *) &(current->v.vector[1]);
631: /* make them pure */
632: pages = bytes/LBPG;
633: for(pindex = ATOX(current); pages ; pages--)
634: {
635: purepage[pindex++] = TRUE;
636: }
637: } else {
638: current->v.vector[1] = (lispval)(typestr->next_free);
639: typestr->next_free = (char *) &(current->v.vector[1]);
640: if(debugin) fprintf(stderr,"grabbed %d vec pages\n",bytes/LBPG);
641: }
642: if(debugin)
643: fprintf(stderr,"creating a new vec, size %d\n",current->v.vector[0]);
644: goto again;
645: }
646:
647: /*
648: * Ipurep :: routine to check for pureness of a data item
649: *
650: */
651: lispval
652: Ipurep(element)
653: lispval element;
654: {
655: if(purepage[ATOX(element)]) return(tatom) ; else return(nil);
656: }
657:
658: /* routines to return space to the free list. These are used by the
659: * arithmetic routines which tend to create large intermediate results
660: * which are know to be garbage after the calculation is over.
661: *
662: * There are jsb callable versions of these routines in qfuncl.s
663: */
664:
665: /* pruneb - prune bignum. A bignum is an sdot followed by a list of
666: * dtprs. The dtpr list is linked by car instead of cdr so when we
667: * put it in the free list, we have to change the links.
668: */
669: pruneb(bignum)
670: lispval bignum;
671: {
672: register lispval temp = bignum;
673:
674: if(TYPE(temp) != SDOT)
675: errorh(Vermisc,"value to pruneb not a sdot",nil,FALSE,0);
676:
677: --(sdot_items->i);
678: temp->s.I = (int) sdot_str.next_free;
679: sdot_str.next_free = (char *) temp;
680:
681: /* bignums are not terminated by nil on the dual,
682: they are terminated by (lispval) 0 */
683:
684: while(temp = temp->s.CDR)
685: {
686: if(TYPE(temp) != DTPR)
687: errorh(Vermisc,"value to pruneb not a list",
688: nil,FALSE,0);
689: --(dtpr_items->i);
690: temp->s.I = (int) dtpr_str.next_free;
691: dtpr_str.next_free = (char *) temp;
692: }
693: }
694: lispval
695: Badcall()
696: { error("BAD FUNCTION DESCRIPTOR USED IN CALL",FALSE); }
697:
698:
699:
700: /*
701: * Ngc
702: * this is the lisp function gc
703: *
704: */
705:
706: lispval
707: Ngc()
708: {
709: return(gc((struct types *)CNIL));
710: }
711:
712: /*
713: * gc(type_struct)
714: *
715: * garbage collector: Collects garbage by mark and sweep algorithm.
716: * After this is done, calls the Nlambda, gcafter.
717: * gc may also be called from LISP, as an nlambda of no arguments.
718: * type_struct is the type of lisp data that ran out causing this
719: * garbage collection
720: */
721: int printall = 0;
722: lispval
723: gc(type_struct)
724: struct types *type_struct;
725: {
726: lispval save;
727: struct tms begin, finish;
728: extern int gctime;
729:
730: /* if this was called automatically when space ran out
731: * print out a message
732: */
733: if((Vgcprint->a.clb != nil)
734: && (type_struct != (struct types *) CNIL ))
735: {
736: FILE *port = okport(Vpoport->a.clb,poport);
737: fprintf(port,"gc:");
738: fflush(port);
739: }
740:
741: if(gctime) times(&begin);
742:
743: gc1(); /* mark&sweep */
744:
745: /* Now we call gcafter--special c ase if gc called from LISP */
746:
747: if( type_struct == (struct types *) CNIL )
748: gccall1->d.cdr = nil; /* make the call "(gcafter)" */
749: else
750: {
751: gccall1->d.cdr = gccall2;
752: gccall2->d.car = *(type_struct->type_name);
753: }
754: PUSHDOWN(gcdis,gcdis); /* flag to indicate in garbage collector */
755: save = eval(gccall1); /* call gcafter */
756: POP; /* turn off flag */
757:
758: if(gctime) {
759: times(&finish);
760: gctime += (finish.tms_utime - begin.tms_utime);
761: }
762: return(save); /* return result of gcafter */
763: }
764:
765:
766:
767: /* gc1() **************************************************************/
768: /* */
769: /* Mark-and-sweep phase */
770:
771: gc1()
772: {
773: int j, k;
774: register int *start,bvalue,type_len;
775: register struct types *s;
776: int *point,i,freecnt,itemstogo,bits,bindex,type,bytestoclear;
777: int usedcnt;
778: char *pindex;
779: struct argent *loop2;
780: struct nament *loop3;
781: struct atom *symb;
782: int markdp();
783: extern int hashtop;
784:
785: pagerand();
786: /* decide whether to check LISP structure or not */
787:
788:
789: #ifdef METER
790: vtimes(&premark,0);
791: mrkdpcnt = 0;
792: conssame = consdiff = consnil = 0;
793: #endif
794:
795: /* first set all bit maps to zero */
796:
797:
798: #ifdef SLOCLEAR
799: {
800: int enddat;
801: enddat = (int)(datalim-OFFSET) >> 8;
802: for(bvalue=0; bvalue < (int)enddat ; ++bvalue)
803: {
804: qbitmap[bvalue] = zeroq;
805: }
806: }
807: #endif
808:
809: /* try the movc5 to clear the bit maps */
810: /* the maximum number of bytes we can clear in one sweep is
811: * 2^16 (or 1<<16 in the C lingo)
812: */
813: bytestoclear = ((((int)datalim)-((int)beginsweep)) >> 9) * 16;
814: for(start = bitmapi + ATOLX(beginsweep);
815: bytestoclear > 0;)
816: {
817: if(bytestoclear > MAXCLEAR)
818: blzero((int)start,MAXCLEAR);
819: else
820: blzero((int)start,bytestoclear);
821: start = (int *) (MAXCLEAR + (int) start);
822: bytestoclear -= MAXCLEAR;
823: }
824:
825: /* mark all atoms in the oblist */
826: for( bvalue=0 ; bvalue <= hashtop-1 ; bvalue++ ) /* though oblist */
827: {
828: for( symb = hasht[bvalue] ; symb != (struct atom *) CNIL ;
829: symb = symb-> hshlnk) {
830: markdp((lispval)symb);
831: }
832: }
833:
834:
835: /* Mark all the atoms and ints associated with the hunk
836: data types */
837:
838: for(i=0; i<7; i++) {
839: markdp(hunk_items[i]);
840: markdp(hunk_name[i]);
841: markdp(hunk_pages[i]);
842: }
843: /* next run up the name stack */
844: for(loop2 = np - 1; loop2 >= orgnp; --loop2) MARKVAL(loop2->val);
845:
846: /* now the bindstack (vals only, atoms are marked elsewhere ) */
847: for(loop3 = bnp - 1; loop3 >= orgbnp; --loop3)MARKVAL(loop3->val);
848:
849:
850: /* next mark all compiler linked data */
851: /* if the Vpurcopylits switch is non nil (lisp variable $purcopylits)
852: * then when compiled code is read in, it tables will not be linked
853: * into this table and thus will not be marked here. That is ok
854: * though, since that data is assumed to be pure.
855: */
856: point = bind_lists;
857: while((start = point) != (int *)CNIL) {
858: while( *start != -1 )
859: {
860: markdp((lispval)*start);
861: start++;
862: }
863: point = (int *)*(point-1);
864: }
865:
866: /* next mark all system-significant lisp data */
867:
868:
869: for(i=0; i<SIGNIF; ++i) markdp((lispsys[i]));
870:
871: #ifdef METER
872: vtimes(&presweep,0);
873: #endif
874: /* all accessible data has now been marked. */
875: /* all collectable spaces must be swept, */
876: /* and freelists constructed. */
877:
878: /* first clear the structure elements for types
879: * we will sweep
880: */
881:
882: for(k=0 ; k <= VECTORI ; k++)
883: {
884: if( s=gcableptr[k]) {
885: if(k==STRNG && !gcstrings) { /* don't do anything*/ }
886: else
887: {
888: (*(s->items))->i = 0;
889: s->space_left = 0;
890: s->next_free = (char *) CNIL;
891: }
892: }
893: }
894: #if m_68k
895: fixbits(bitmapi+ATOLX(beginsweep),bitmapi+ATOLX(datalim));
896: #endif
897:
898:
899: /* sweep up in memory looking at gcable pages */
900:
901: for(start = beginsweep, bindex = ATOLX(start),
902: pindex = &purepage[ATOX(start)];
903: start < (int *)datalim;
904: start += 128, pindex++)
905: {
906: if(!(s=gcableptr[type = TYPE(start)]) || *pindex
907: #ifdef GCSTRINGS
908: || (type==STRNG && !gcstrings)
909: #endif
910: )
911: {
912: /* ignore this page but advance pointer */
913: bindex += 4; /* and 4 words of 32 bit bitmap words */
914: continue;
915: }
916:
917: freecnt = 0; /* number of free items found */
918: usedcnt = 0; /* number of used items found */
919:
920: point = start;
921: /* sweep dtprs as a special case, since
922: * 1) there will (usually) be more dtpr pages than any other type
923: * 2) most dtpr pages will be empty so we can really win by special
924: * caseing the sweeping of massive numbers of free cells
925: */
926: /* since sdot's have the same structure as dtprs, this code will
927: work for them too
928: */
929: if((type == DTPR) || (type == SDOT))
930: {
931: int *head,*lim;
932: head = (int *) s->next_free; /* first value on free list*/
933:
934: for(i=0; i < 4; i++) /* 4 bit map words per page */
935: {
936: bvalue = bitmapi[bindex++]; /* 32 bits = 16 dtprs */
937: if(bvalue == 0) /* if all are free */
938: {
939: *point = (int)head;
940: lim = point + 32; /* 16 dtprs = 32 ints */
941: for(point += 2; point < lim ; point += 2)
942: {
943: *point = (int)(point - 2);
944: }
945: head = point - 2;
946: freecnt += 16;
947: }
948: else for(j = 0; j < 16 ; j++)
949: {
950: if(!(bvalue & 1))
951: {
952: freecnt++;
953: *point = (int)head;
954: head = point;
955: }
956: #ifdef METER
957: /* check if the page address of this cell is the
958: * same as the address of its cdr
959: */
960: else if(FALSE && gcstat && (type == DTPR))
961: {
962: if(((int)point & ~511)
963: == ((int)(*point) & ~511)) conssame++;
964: else consdiff++;
965: usedcnt++;
966: }
967: #endif
968: else usedcnt++; /* keep track of used */
969:
970: point += 2;
971: bvalue = bvalue >> 2;
972: }
973: }
974: s->next_free = (char *) head;
975: }
976: else if((type == VECTOR) || (type == VECTORI))
977: {
978: int canjoin = FALSE;
979: int *tempp;
980:
981: /* check if first item on freelist ends exactly at
982: this page
983: */
984: if(((tempp = (int *)s->next_free) != (int *)CNIL)
985: && ((VecTotSize(((lispval)tempp)->vl.vectorl[-1])
986: + 1 + tempp)
987: == point))
988: canjoin = TRUE;
989:
990: /* arbitrary sized vector sweeper */
991: /*
992: * jump past first word since that is a size fixnum
993: * and second word since that is property word
994: */
995: if(debugin)
996: fprintf(stderr,"vector sweeping, start at 0x%x\n",
997: point);
998: bits = 30;
999: bvalue = bitmapi[bindex++] >> 2;
1000: point += 2;
1001: while (TRUE) {
1002: type_len = point[VSizeOff];
1003: if(debugin) {
1004: fprintf(stderr,"point: 0x%x, type_len %d\n",
1005: point, type_len);
1006: fprintf(stderr,"bvalue: 0x%x, bits: %d, bindex: 0x%x\n",
1007: bvalue, bits, bindex);
1008: }
1009: /* get size of vector */
1010: if(!(bvalue & 1)) /* if free */
1011: {
1012: if(debugin) fprintf(stderr,"free\n");
1013: freecnt += type_len + 2*sizeof(long);
1014: if(canjoin)
1015: {
1016: /* join by adjusting size of first vector */
1017: ((lispval)(s->next_free))->vl.vectorl[-1]
1018: += type_len + 2*sizeof(long);
1019: if(debugin)
1020: fprintf(stderr,"joined size: %d\n",
1021: ((lispval)(s->next_free))->vl.vectorl[-1]);
1022: }
1023: else {
1024: /* vectors are linked at the property word */
1025: *(point - 1) = (int)(s->next_free);
1026: s->next_free = (char *) (point - 1);
1027: }
1028: canjoin = TRUE;
1029: }
1030: else {
1031: canjoin = FALSE;
1032: usedcnt += type_len + 2*sizeof(long);
1033: }
1034:
1035: point += VecTotSize(type_len);
1036: /* we stop sweeping only when we reach a page
1037: boundary since vectors can span pages
1038: */
1039: if(((int)point & 511) == 0)
1040: {
1041: /* reset the counters, we cannot predict how
1042: * many pages we have crossed over
1043: */
1044: bindex = ATOLX(point);
1045: /* these will be inced, so we must dec */
1046: pindex = &purepage[ATOX(point)] - 1;
1047: start = point - 128;
1048: if(debugin)
1049: fprintf(stderr,
1050: "out of vector sweep when point = 0x%x\n",
1051: point);
1052: break;
1053: }
1054: /* must advance to next point and next value in bitmap.
1055: * we add VecTotSize(type_len) + 2 to get us to the 0th
1056: * entry in the next vector (beyond the size fixnum)
1057: */
1058: point += 2; /* point to next 0th entry */
1059: if ( (bits -= (VecTotSize(type_len) + 2)) > 0)
1060: bvalue = bvalue >> (VecTotSize(type_len) + 2);
1061: else {
1062: bits = -bits; /* must advance to next word in map */
1063: bindex += bits / 32; /* this is tricky stuff... */
1064: bits = bits % 32;
1065: bvalue = bitmapi[bindex++] >> bits;
1066: bits = 32 - bits;
1067: }
1068: }
1069: }
1070: else {
1071: /* general sweeper, will work for all types */
1072: itemstogo = s->space; /* number of items per page */
1073: bits = 32; /* number of bits per word */
1074: type_len = s->type_len;
1075:
1076: /* printf(" s %d, itemstogo %d, len %d\n",s,itemstogo,type_len);*/
1077: bvalue = bitmapi[bindex++];
1078:
1079: while(TRUE)
1080: {
1081: if(!(bvalue & 1)) /* if data element is not marked */
1082: {
1083: freecnt++;
1084: *point = (int) (s->next_free) ;
1085: s->next_free = (char *) point;
1086: }
1087: else usedcnt++;
1088:
1089: if( --itemstogo <= 0 )
1090: { if(type_len >= 64)
1091: {
1092: bindex++;
1093: if(type_len >=128) bindex += 2;
1094: }
1095: break;
1096: }
1097:
1098: point += type_len;
1099: /* shift over mask by number of words in data type */
1100:
1101: if( (bits -= type_len) > 0)
1102: { bvalue = bvalue >> type_len;
1103: }
1104: else if( bits == 0 )
1105: { bvalue = bitmapi[bindex++];
1106: bits = 32;
1107: }
1108: else
1109: { bits = -bits;
1110: while( bits >= 32) { bindex++;
1111: bits -= 32;
1112: }
1113: bvalue = bitmapi[bindex++];
1114: bvalue = bvalue >> bits;
1115: bits = 32 - bits;;
1116: }
1117: }
1118: }
1119:
1120: s->space_left += freecnt;
1121: (*(s->items))->i += usedcnt;
1122: }
1123:
1124: #ifdef METER
1125: vtimes(&alldone,0);
1126: if(gcstat) gcdump();
1127: #endif
1128: pagenorm();
1129: }
1130:
1131: /*
1132: * alloc
1133: *
1134: * This routine tries to allocate one or more pages of the space named
1135: * by the first argument. Returns the number of pages actually allocated.
1136: *
1137: */
1138:
1139: lispval
1140: alloc(tname,npages)
1141: lispval tname; long npages;
1142: {
1143: long ii, jj;
1144: struct types *typeptr;
1145:
1146: ii = typenum(tname);
1147: typeptr = spaces[ii];
1148: if(npages <= 0) return(inewint(npages));
1149:
1150: if((ATOX(datalim)) + npages > TTSIZE)
1151: error("Space request would exceed maximum memory allocation",FALSE);
1152: if((ii == VECTOR) || (ii == VECTORI))
1153: {
1154: /* allocate in one big chunk */
1155: tname = csegment((int) ii,(int) npages*128,0);
1156: tname->vl.vectorl[0] = (npages*512 - 2*sizeof(long));
1157: tname->v.vector[1] = (lispval) typeptr->next_free;
1158: typeptr->next_free = (char *) &(tname->v.vector[1]);
1159: if(debugin) fprintf(stderr,"alloced %d vec pages\n",npages);
1160: return(inewint(npages));
1161: }
1162:
1163: for( jj=0; jj<npages; ++jj)
1164: if(get_more_space(spaces[ii],FALSE)) break;
1165: return(inewint(jj));
1166: }
1167:
1168: /*
1169: * csegment(typecode,nitems,useholeflag)
1170: * allocate nitems of type typecode. If useholeflag is true, then
1171: * allocate in the hole if there is room. This routine doesn't look
1172: * in the free lists, it always allocates space.
1173: */
1174: lispval
1175: csegment(typecode,nitems,useholeflag)
1176: {
1177: register int ii, jj;
1178: register char *charadd;
1179:
1180: ii = typecode;
1181:
1182: if(ii!=OTHER) nitems *= 4*spaces[ii]->type_len;
1183: nitems = roundup(nitems,512); /* round up to right length */
1184: #ifdef HOLE
1185: if(useholeflag)
1186: charadd = gethspace(nitems,ii);
1187: else
1188: #endif
1189: {
1190: charadd = sbrk(nitems);
1191: datalim = (lispval)(charadd+nitems);
1192: }
1193: if( (int) charadd <= 0 )
1194: error("NOT ENOUGH SPACE FOR ARRAY",FALSE);
1195: /*if(ii!=OTHER)*/ (*spaces[ii]->pages)->i += nitems/512;
1196: if(ATOX(datalim) > fakettsize) {
1197: datalim = (lispval) (OFFSET + (fakettsize << 9));
1198: if(fakettsize >= TTSIZE)
1199: {
1200: printf("There isn't room enough to continue, goodbye\n");
1201: franzexit(1);
1202: }
1203: fakettsize++;
1204: badmem(53);
1205: }
1206: for(jj=0; jj<nitems; jj=jj+512) {
1207: SETTYPE(charadd+jj, ii,30);
1208: }
1209: ii = (int) charadd;
1210: while(nitems > MAXCLEAR)
1211: {
1212: blzero(ii,MAXCLEAR);
1213: nitems -= MAXCLEAR;
1214: ii += MAXCLEAR;
1215: }
1216: blzero(ii,nitems);
1217: return((lispval)charadd);
1218: }
1219:
1220: int csizeof(tname) lispval tname;
1221: {
1222: return( spaces[typenum(tname)]->type_len * 4 );
1223: }
1224:
1225: int typenum(tname) lispval tname;
1226: {
1227: int ii;
1228:
1229: chek: for(ii=0; ii<NUMSPACES; ++ii)
1230: if(spaces[ii] && tname == *(spaces[ii]->type_name)) break;
1231: if(ii == NUMSPACES)
1232: {
1233: tname = error("BAD TYPE NAME",TRUE);
1234: goto chek;
1235: }
1236:
1237: return(ii);
1238:
1239: }
1240: char *
1241: gethspace(segsiz,type)
1242: {
1243: extern usehole; extern char holend[]; extern char *curhbeg;
1244: register char *value;
1245:
1246: if(usehole) {
1247: curhbeg = (char *) roundup(((int)curhbeg),LBPG);
1248: if((holend - curhbeg) < segsiz)
1249: {
1250: usehole = FALSE;
1251: curhbeg = holend;
1252: } else {
1253: value = curhbeg;
1254: curhbeg = curhbeg + segsiz;
1255: /*printf("start %d, finish %d, size %d\n",value, curhbeg,segsiz);*/
1256: return(value);
1257: }
1258: }
1259: value = (ysbrk(segsiz/LBPG,type));
1260: datalim = (lispval)(value + segsiz);
1261: return(value);
1262: }
1263: gcrebear()
1264: {
1265: #ifdef HOLE
1266: register int i; register struct types *p;
1267:
1268: /* this gets done upon rebirth */
1269: str_current[1].space_left = 0;
1270: #ifndef GCSTRINGS
1271: str_current[0].space_left = 0; /* both kinds of strings go in hole*/
1272: #endif
1273: funct_str.space_left = 0;
1274: funct_str.next_free = (char *) CNIL;
1275: /* clear pure space pointers */
1276: for(i = 0; i < NUMSPACES; i++)
1277: {
1278: if(p=spaces[i])
1279: p->next_pure_free = (char *) CNIL;
1280: }
1281: #endif
1282: }
1283:
1284: /** markit(p) ***********************************************************/
1285: /* just calls markdp */
1286:
1287: markit(p) lispval *p; { markdp(*p); }
1288:
1289: /*
1290: * markdp(p)
1291: *
1292: * markdp is the routine which marks each data item. If it is a
1293: * dotted pair, the car and cdr are marked also.
1294: * An iterative method is used to mark list structure, to avoid
1295: * excessive recursion.
1296: */
1297: markdp(p) register lispval p;
1298: {
1299: #ifdef tahoe
1300: register int r, s; /* (goes with non-asm readbit, oksetbit) */
1301: #endif
1302: /* register hsize, hcntr; */
1303: int hsize, hcntr;
1304:
1305: #ifdef METER
1306: mrkdpcnt++;
1307: #endif
1308: ptr_loop:
1309: if(((int)p) <= ((int)nil)) return; /* do not mark special data types or nil=0 */
1310:
1311:
1312: switch( TYPE(p) )
1313: {
1314: case ATOM:
1315: ftstbit;
1316: MARKVAL(p->a.clb);
1317: MARKVAL(p->a.plist);
1318: MARKVAL(p->a.fnbnd);
1319: #ifdef GCSTRINGS
1320: if(gcstrings) MARKVAL(((lispval)p->a.pname));
1321: return;
1322:
1323: case STRNG:
1324: p = (lispval) (((int) p) & ~ (LBPG-1));
1325: ftstbit;
1326: #endif
1327: return;
1328:
1329: case INT:
1330: case DOUB:
1331: ftstbit;
1332: return;
1333: case VALUE:
1334: ftstbit;
1335: p = p->l;
1336: goto ptr_loop;
1337: case DTPR:
1338: ftstbit;
1339: MARKVAL(p->d.car);
1340: #ifdef METER
1341: /* if we are metering , then check if the cdr is
1342: * nil, or if the cdr is on the same page, and if
1343: * it isn't one of those, then it is on a different
1344: * page
1345: */
1346: if(gcstat)
1347: {
1348: if(p->d.cdr == nil) consnil++;
1349: else if(((int)p & ~511)
1350: == (((int)(p->d.cdr)) & ~511))
1351: conssame++;
1352: else consdiff++;
1353: }
1354: #endif
1355: p = p->d.cdr;
1356: goto ptr_loop;
1357:
1358: case ARRAY:
1359: ftstbit; /* mark array itself */
1360:
1361: MARKVAL(p->ar.accfun); /* mark access function */
1362: MARKVAL(p->ar.aux); /* mark aux data */
1363: MARKVAL(p->ar.length); /* mark length */
1364: MARKVAL(p->ar.delta); /* mark delta */
1365: if(TYPE(p->ar.aux)==DTPR && p->ar.aux->d.car==Vnogbar)
1366: {
1367: /* a non garbage collected array must have its
1368: * array space marked but the value of the array
1369: * space is not marked
1370: */
1371: int l;
1372: int cnt,d;
1373: if(debugin) {
1374: printf("mark array holders len %d, del %d, start 0x%x\n",
1375: p->ar.length->i,p->ar.delta->i,p->ar.data);
1376: fflush(stdout);
1377: }
1378: l = p->ar.length->i; /* number of elements */
1379: d = p->ar.delta->i; /* bytes per element */
1380: p = (lispval) p->ar.data;/* address of first one*/
1381: if(purepage[ATOX(p)]) return;
1382:
1383: for((cnt = 0); cnt<l ;
1384: p = (lispval)(((char *) p) + d), cnt++)
1385: {
1386: setbit;
1387: }
1388: } else {
1389: /* register int i, l; int d; */
1390: /* register char *dataptr = p->ar.data; */
1391: int i,l,d;
1392: char *dataptr = p->ar.data;
1393:
1394: for(i=0, l=p->ar.length->i, d=p->ar.delta->i; i<l; ++i)
1395: {
1396: markdp((lispval)dataptr);
1397: dataptr += d;
1398: }
1399: }
1400: return;
1401: case SDOT:
1402: do {
1403: ftstbit;
1404: p = p->s.CDR;
1405: } while (p!=0);
1406: return;
1407:
1408: case BCD:
1409: ftstbit;
1410: markdp(p->bcd.discipline);
1411: return;
1412:
1413: case HUNK2:
1414: case HUNK4:
1415: case HUNK8:
1416: case HUNK16:
1417: case HUNK32:
1418: case HUNK64:
1419: case HUNK128:
1420: {
1421: hsize = 2 << HUNKSIZE(p);
1422: ftstbit;
1423: for (hcntr = 0; hcntr < hsize; hcntr++)
1424: MARKVAL(p->h.hunk[hcntr]);
1425: return;
1426: }
1427:
1428: case VECTORI:
1429: ftstbit;
1430: MARKVAL(p->v.vector[-1]); /* mark property */
1431: return;
1432:
1433: case VECTOR:
1434: {
1435: register int vsize;
1436: ftstbit;
1437: vsize = VecSize(p->vl.vectorl[VSizeOff]);
1438: if(debugin)
1439: fprintf(stderr,"mark vect at %x size %d\n",
1440: p,vsize);
1441: while(--vsize >= -1)
1442: {
1443: MARKVAL(p->v.vector[vsize]);
1444: };
1445: return;
1446: }
1447: }
1448: return;
1449: }
1450:
1451:
1452: /* xsbrk allocates space in large chunks (currently 16 pages)
1453: * xsbrk(1) returns a pointer to a page
1454: * xsbrk(0) returns a pointer to the next page we will allocate (like sbrk(0))
1455: */
1456:
1457: char *
1458: xsbrk(n)
1459: {
1460: static char *xx; /* pointer to next available blank page */
1461: extern int xcycle; /* number of blank pages available */
1462: lispval u; /* used to compute limits of bit table */
1463:
1464: if( (xcycle--) <= 0 )
1465: {
1466: xcycle = 15;
1467: xx = sbrk(16*LBPG); /* get pages 16 at a time */
1468: if( (int)xx== -1 )
1469: lispend("For sbrk from lisp: no space... Goodbye!");
1470: }
1471: else xx += LBPG;
1472:
1473: if(n == 0)
1474: {
1475: xcycle++; /* don't allocate the page */
1476: xx -= LBPG;
1477: return(xx); /* just return its address */
1478: }
1479:
1480: if( (u = (lispval)(xx+LBPG)) > datalim ) datalim = u;
1481: return(xx);
1482: }
1483:
1484: char *ysbrk(pages,type) int pages, type;
1485: {
1486: char *xx; /* will point to block of storage */
1487: int i;
1488:
1489: xx = sbrk(pages*LBPG);
1490: if((int)xx == -1)
1491: error("OUT OF SPACE FOR ARRAY REQUEST",FALSE);
1492:
1493: datalim = (lispval)(xx+pages*LBPG); /* compute bit table limit */
1494:
1495: /* set type for pages */
1496:
1497: for(i = 0; i < pages; ++i) {
1498: SETTYPE((xx + i*LBPG),type,10);
1499: }
1500:
1501: return(xx); /* return pointer to block of storage */
1502: }
1503:
1504: /*
1505: * getatom
1506: * returns either an existing atom with the name specified in strbuf, or
1507: * if the atom does not already exist, regurgitates a new one and
1508: * returns it.
1509: */
1510: lispval
1511: getatom(purep)
1512: { register lispval aptr;
1513: register char *name, *endname;
1514: register int hash;
1515: lispval b;
1516: char c;
1517:
1518: name = strbuf;
1519: if (*name == (char)0377) return (eofa);
1520: hash = hashfcn(name);
1521: atmlen = strlen(name) + 1;
1522: aptr = (lispval) hasht[hash];
1523: while (aptr != CNIL)
1524: /* if (strcmp(name,aptr->a.pname)==0) */
1525: if (*name==*aptr->a.pname && strcmp(name,aptr->a.pname)==0)
1526: return (aptr);
1527: else
1528: aptr = (lispval) aptr->a.hshlnk;
1529: aptr = (lispval) newatom(purep); /*share pname of atoms on oblist*/
1530: aptr->a.hshlnk = hasht[hash];
1531: hasht[hash] = (struct atom *) aptr;
1532: endname = name + atmlen - 2;
1533: if ((atmlen != 4) && (*name == 'c') && (*endname == 'r'))
1534: {
1535: b = newdot();
1536: protect(b);
1537: b->d.car = lambda;
1538: b->d.cdr = newdot();
1539: b = b->d.cdr;
1540: b->d.car = newdot();
1541: (b->d.car)->d.car = xatom;
1542: while(TRUE)
1543: {
1544: b->d.cdr = newdot();
1545: b= b->d.cdr;
1546: if(++name == endname)
1547: {
1548: b->d.car= (lispval) xatom;
1549: aptr->a.fnbnd = (--np)->val;
1550: break;
1551: }
1552: b->d.car= newdot();
1553: b= b->d.car;
1554: if((c = *name) == 'a') b->d.car = cara;
1555: else if (c == 'd') b->d.car = cdra;
1556: else{ --np;
1557: break;
1558: }
1559: }
1560: }
1561:
1562: return(aptr);
1563: }
1564:
1565: /*
1566: * inewatom is like getatom, except that you provide it a string
1567: * to be used as the print name. It doesn't do the automagic
1568: * creation of things of the form c[ad]*r.
1569: */
1570: lispval
1571: inewatom(name)
1572: register char *name;
1573: { register struct atom *aptr;
1574: register int hash;
1575: extern struct types atom_str;
1576: char c;
1577:
1578: if (*name == (char)0377) return (eofa);
1579: hash = hashfcn(name);
1580: aptr = hasht[hash];
1581: while (aptr != (struct atom *)CNIL)
1582: if (strcmp(name,aptr->pname)==0)
1583: return ((lispval) aptr);
1584: else
1585: aptr = aptr->hshlnk;
1586: aptr = (struct atom *) next_one(&atom_str) ;
1587: aptr->plist = aptr->fnbnd = nil;
1588: aptr->clb = CNIL;
1589: aptr->pname = name;
1590: aptr->hshlnk = hasht[hash];
1591: hasht[hash] = aptr;
1592: return((lispval)aptr);
1593: }
1594:
1595:
1596: /* our hash function */
1597:
1598: hashfcn(symb)
1599: register char *symb;
1600: {
1601: register int i;
1602: /* for (i=0 ; *symb ; i += i + *symb++); return(i & (HASHTOP-1)); */
1603: for (i=0 ; *symb ; i += i*2 + *symb++);
1604: return(i&077777 % HASHTOP);
1605: }
1606:
1607: lispval
1608: LImemory()
1609: {
1610: int nextadr, pagesinuse;
1611:
1612: printf("Memory report. max pages = %d (0x%x) = %d Bytes\n",
1613: TTSIZE,TTSIZE,TTSIZE*LBPG);
1614: #ifdef HOLE
1615: printf("This lisp has a hole:\n");
1616: printf(" current hole start: %d (0x%x), end %d (0x%x)\n",
1617: curhbeg, curhbeg, holend, holend);
1618: printf(" hole free: %d bytes = %d pages\n\n",
1619: holend-curhbeg, (holend-curhbeg)/LBPG);
1620: #endif
1621: nextadr = (int) xsbrk(0); /* next space to be allocated */
1622: pagesinuse = nextadr/LBPG;
1623: printf("Next allocation at addr %d (0x%x) = page %d\n",
1624: nextadr, nextadr, pagesinuse);
1625: printf("Free data pages: %d\n", TTSIZE-pagesinuse);
1626: return(nil);
1627: }
1628:
1629: extern struct atom *hasht[HASHTOP];
1630: myhook(){}
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.