![[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] / 3BSD / cmd / lisp|
Return to Talloc.c CVS log | Up to [CSRG BSD Unix] / 3BSD / cmd / lisp |
1.1 ! root 1: # include "global.h" ! 2: ! 3: # define NUMWORDS TTSIZE * 128 /* max number of words in P0 space */ ! 4: # define BITQUADS TTSIZE * 2 /* length of bit map in quad words */ ! 5: ! 6: # define ftstbit asm(" ashl $-2,r11,r3");\ ! 7: asm(" bbcs r3,_bitmapq,$1");\ ! 8: asm(" .byte 4"); ! 9: /* define ftstbit if( readbit(p) ) return; oksetbit; */ ! 10: # define readbit(p) ((int)bitmap[r=(int)p>>5] & (s=bitmsk[((int)p>>2)&7])) ! 11: # define lookbit(p) (bitmap[(int)p>>5] & bitmsk[((int)p>>2) & 7]) ! 12: # define setbit(p) {bitmap[(int)p>>5] |= bitmsk[((int)p >> 2) & 7];} ! 13: # define oksetbit {bitmap[r] |= s;} ! 14: ! 15: # define readchk(p) ((int)bitfre[(int)p>>5] & bitmsk[((int)p>>2)&7]) ! 16: # define setchk(p) {bitfre[(int)p>>5] |= bitmsk[((int)p >> 2) & 7];} ! 17: ! 18: struct heads { ! 19: struct heads *link; ! 20: char *pntr; ! 21: } header[TTSIZE]; ! 22: ! 23: FILE * chkport; /* garbage collection dump file */ ! 24: lispval datalim; /* end of data space */ ! 25: double bitmapq[BITQUADS]; /* the bit map--one bit per long */ ! 26: double zeroq; /* a quad word of zeros */ ! 27: char *bitmap = (char *) bitmapq; /* byte version of bit map array */ ! 28: char bitmsk[8]={1,2,4,8,16,32,64,128}; /* used by bit-marking macros */ ! 29: int *bind_lists = (int *) CNIL; /* lisp data for compiled code */ ! 30: ! 31: char *xsbrk(); ! 32: ! 33: ! 34: int atmlen; ! 35: ! 36: struct types { ! 37: char *next_free; ! 38: int space_left, ! 39: space, ! 40: type, ! 41: type_len; /* note type_len is in units of int */ ! 42: lispval *items, ! 43: *pages, ! 44: *type_name; ! 45: struct heads ! 46: *first; ! 47: } atom_str = {(char *)CNIL,0,ATOMSPP,ATOM,5,&atom_items,&atom_pages,&atom_name,(struct heads *)CNIL}, ! 48: strng_str = {(char *)CNIL,0,STRSPP,STRNG,1,&str_items,&str_pages,&str_name,(struct heads *)CNIL}, ! 49: int_str = {(char *)CNIL,0,INTSPP,INT,1,&int_items,&int_pages,&int_name,(struct heads *)CNIL}, ! 50: dtpr_str = {(char *)CNIL,0,DTPRSPP,DTPR,2,&dtpr_items,&dtpr_pages,&dtpr_name,(struct heads *)CNIL}, ! 51: doub_str = {(char *)CNIL,0,DOUBSPP,DOUB,2,&doub_items,&doub_pages,&doub_name,(struct heads *)CNIL}, ! 52: array_str = {(char *)CNIL,0,ARRAYSPP,ARRAY,5,&array_items,&array_pages,&array_name,(struct heads *)CNIL}, ! 53: sdot_str = {(char *)CNIL,0,SDOTSPP,SDOT,2,&sdot_items,&sdot_pages,&sdot_name,(struct heads *)CNIL}, ! 54: val_str = {(char *)CNIL,0,VALSPP,VALUE,1,&val_items,&val_pages,&val_name,(struct heads *)CNIL}, ! 55: funct_str = {(char *)CNIL,0,BCDSPP,BCD,2,&funct_items,&funct_pages,&funct_name,(struct heads *)CNIL}; ! 56: ! 57: extern int initflag; /* starts off TRUE: initially gc not allowed */ ! 58: ! 59: int gcflag = FALSE; /* TRUE during garbage collection */ ! 60: ! 61: int current = 0; /* number of pages currently allocated */ ! 62: ! 63: #define NUMSPACES 9 ! 64: ! 65: static struct types *(spaces[NUMSPACES]) = ! 66: {&atom_str, &strng_str, &int_str, ! 67: &dtpr_str, &doub_str, &array_str, ! 68: &sdot_str, &val_str, &funct_str}; ! 69: ! 70: ! 71: /** get_more_space(type_struct) *****************************************/ ! 72: /* */ ! 73: /* Allocates and structures a new page, returning 0. */ ! 74: /* If no space is available, returns 1. */ ! 75: ! 76: get_more_space(type_struct) ! 77: struct types *type_struct; ! 78: { ! 79: int cntr; ! 80: char *start; ! 81: int *loop, *temp; ! 82: lispval p, plim; ! 83: struct heads *next; ! 84: ! 85: if(initflag == FALSE) ! 86: /* mustn't look at plist of plima too soon */ ! 87: { ! 88: while( plim=copval(plima,(lispval)CNIL), TYPE(plim)!=INT ) ! 89: copval(plima,error("BAD PAGE LIMIT",TRUE)); ! 90: if( plim->i <= current ) return(1); /* Can't allocate */ ! 91: } ! 92: ! 93: if( current >= TTSIZE ) return(2); ! 94: ! 95: start = xsbrk( NBPG ); ! 96: ! 97: /* bump the page counter for this space */ ! 98: ! 99: ++((*(type_struct->pages))->i); ! 100: ! 101: SETTYPE(start, type_struct->type); /* set type of page */ ! 102: ! 103: type_struct->space_left = type_struct->space; ! 104: next = &header[ current++ ]; ! 105: if ((type_struct->type)==STRNG) ! 106: { ! 107: type_struct->next_free = start; ! 108: return(0); /* space was available */ ! 109: } ! 110: next->pntr = start; ! 111: next->link = type_struct->first; ! 112: type_struct->first = next; ! 113: temp = loop = (int *) start; ! 114: for(cntr=1; cntr < type_struct->space; cntr++) ! 115: loop = (int *) (*loop = (int) (loop + type_struct->type_len)); ! 116: *loop = (int) (type_struct->next_free); ! 117: type_struct->next_free = (char *) temp; ! 118: ! 119: /* if type atom, set pnames to CNIL */ ! 120: ! 121: if( type_struct == &atom_str ) ! 122: for(cntr=0, p=(lispval) temp; cntr<atom_str.space; ++cntr) ! 123: { ! 124: p->pname = (char *) CNIL; ! 125: p = (lispval) ((int *)p + atom_str.type_len); ! 126: } ! 127: return(0); /* space was available */ ! 128: } ! 129: ! 130: ! 131: /** next_one(type_struct) ************************************************/ ! 132: /* */ ! 133: /* Allocates one new item of each kind of space, except STRNG. */ ! 134: /* If there is no space, calls gc, the garbage collector. */ ! 135: /* If there is still no space, allocates a new page using */ ! 136: /* get_more_space(type_struct) */ ! 137: ! 138: lispval ! 139: next_one(type_struct) ! 140: struct types *type_struct; ! 141: { ! 142: ! 143: register char *temp; ! 144: snpand(1); ! 145: ! 146: while(type_struct->next_free == (char *) CNIL) ! 147: { ! 148: int g; ! 149: ! 150: if((type_struct->type != ATOM) && /* can't collect atoms */ ! 151: (type_struct->type != STRNG) && /* can't collect strings */ ! 152: (gcthresh->i <= current) && /* threshhold for gc */ ! 153: ISNIL(copval(gcdis,CNIL)) && /* gc not disabled */ ! 154: (NOTNIL(copval(gcload,CNIL)) || (loading->clb != tatom)) && ! 155: /* not to collect during load */ ! 156: (initflag == FALSE) && /* dont gc during init */ ! 157: (gcflag == FALSE)) /* don't recurse gc */ ! 158: ! 159: { ! 160: /* fputs("Collecting",poport); ! 161: dmpport(poport);*/ ! 162: gc(type_struct); /* collect */ ! 163: } ! 164: ! 165: if( type_struct->next_free != (char *) CNIL ) break; ! 166: ! 167: if(! (g=get_more_space(type_struct))) break; ! 168: ! 169: if( g==1 ) ! 170: { ! 171: plimit->i = current+NUMSPACES; ! 172: /* allow a few more pages */ ! 173: copval(plima,plimit); /* restore to reserved reg */ ! 174: ! 175: error("PAGE LIMIT EXCEEDED--EMERGENCY PAGES ALLOCATED", ! 176: TRUE); ! 177: } ! 178: else error("SORRY, ABSOLUTE PAGE LIMIT HAS BEEN REACHED", ! 179: TRUE); ! 180: } ! 181: ! 182: temp = type_struct->next_free; ! 183: type_struct->next_free = * (char **)(type_struct->next_free); ! 184: return((lispval) temp); ! 185: } ! 186: ! 187: lispval ! 188: newint() ! 189: { ! 190: ++(int_items->i); ! 191: return(next_one(&int_str)); ! 192: } ! 193: ! 194: lispval ! 195: newdot() ! 196: { ! 197: lispval temp; ! 198: ! 199: ++(dtpr_items->i); ! 200: temp = next_one(&dtpr_str); ! 201: temp->car = temp->cdr = nil; ! 202: return(temp); ! 203: } ! 204: ! 205: lispval ! 206: newdoub() ! 207: { ! 208: ++(doub_items->i); ! 209: return(next_one(&doub_str)); ! 210: } ! 211: ! 212: lispval ! 213: newsdot() ! 214: { ! 215: register lispval temp; ! 216: ++(dtpr_items->i); ! 217: temp = next_one(&sdot_str); ! 218: temp->car = temp->cdr = 0; ! 219: return(temp); ! 220: } ! 221: ! 222: struct atom *newatom() { ! 223: struct atom *save; ! 224: ! 225: ++(atom_items->i); ! 226: save = (struct atom *) next_one(&atom_str) ; ! 227: save->plist = save->fnbnd = nil; ! 228: save->hshlnk = (struct atom *)CNIL; ! 229: save->clb = CNIL; ! 230: save->pname = newstr(); ! 231: return (save); ! 232: } ! 233: ! 234: char *newstr() { ! 235: char *save; ! 236: int atmlen2; ! 237: ! 238: ++(str_items->i); ! 239: atmlen = strlen(strbuf)+1; ! 240: if(atmlen > strng_str.space_left) ! 241: while(get_more_space(&strng_str)) ! 242: error("YOU HAVE RUN OUT OF SPACE",TRUE); ! 243: strcpy((save = strng_str.next_free), strbuf); ! 244: atmlen2 = atmlen; ! 245: while(atmlen2 % 4) ++atmlen2; /* even up length of string */ ! 246: strng_str.next_free += atmlen2; ! 247: strng_str.space_left -= atmlen2; ! 248: return(save); ! 249: } ! 250: ! 251: char *inewstr(s) char *s; ! 252: { ! 253: strbuf[STRBLEN-1] = '\0'; ! 254: strcpyn(strbuf,s,STRBLEN-1); ! 255: return(newstr()); ! 256: } ! 257: ! 258: lispval ! 259: newarray() ! 260: { ! 261: register lispval temp; ! 262: ++(array_items->i); ! 263: temp = next_one(&array_str); ! 264: temp->data = (char *)nil; ! 265: temp->accfun = nil; ! 266: temp->aux = nil; ! 267: temp->length = SMALL(0); ! 268: temp->delta = SMALL(0); ! 269: return(temp); ! 270: } ! 271: ! 272: lispval ! 273: badcall() ! 274: { error("BAD FUNCTION DESCRIPTOR USED IN CALL",FALSE); } ! 275: ! 276: lispval ! 277: newfunct() ! 278: { ! 279: register lispval temp; ! 280: ++(funct_items->i); ! 281: temp = next_one(&funct_str); ! 282: temp->entry = badcall; ! 283: temp->discipline = nil; ! 284: return(temp); ! 285: } ! 286: ! 287: lispval ! 288: newval() ! 289: { ! 290: register lispval temp; ! 291: ++(val_items->i); ! 292: temp = next_one(&val_str); ! 293: temp->l = nil; ! 294: return(temp); ! 295: } ! 296: ! 297: lispval ! 298: inewval(arg) lispval arg; ! 299: { ! 300: lispval temp; ! 301: ++(val_items->i); ! 302: temp = next_one(&val_str); ! 303: temp->l = arg; ! 304: return(temp); ! 305: } ! 306: ! 307: /** Ngc *****************************************************************/ ! 308: /* */ ! 309: /* LISP interface to gc. */ ! 310: ! 311: lispval Ngc() ! 312: { ! 313: lispval temp; ! 314: ! 315: if( ISNIL(lbot->val) ) return(gc(CNIL)); ! 316: ! 317: if( TYPE(lbot->val) != DTPR ) error("BAD CALL TO GC",FALSE); ! 318: ! 319: chkport = poport; ! 320: ! 321: if( NOTNIL(lbot->val->car) ) ! 322: { ! 323: temp = eval(lbot->val->car); ! 324: if( TYPE(temp) == PORT ) chkport = (FILE *)*temp; ! 325: } ! 326: ! 327: gc1(TRUE); ! 328: ! 329: return(nil); ! 330: } ! 331: ! 332: /** gc(type_struct) *****************************************************/ ! 333: /* */ ! 334: /* garbage collector: Collects garbage by mark and sweep algorithm. */ ! 335: /* After this is done, calls the Nlambda, gcafter. */ ! 336: /* gc may also be called from LISP, as a lambda of no arguments. */ ! 337: ! 338: lispval ! 339: gc(type_struct) ! 340: struct types *type_struct; ! 341: { ! 342: lispval save; ! 343: struct { ! 344: long mytime; ! 345: long allelse[3]; ! 346: } begin, finish; ! 347: extern int GCtime; ! 348: ! 349: save = copval(gcport,CNIL); ! 350: if(GCtime) ! 351: times(&begin); ! 352: ! 353: while( (TYPE(save) != PORT) && NOTNIL(save)) ! 354: save = error("NEED PORT FOR GC",TRUE); ! 355: ! 356: chkport = ISNIL(save) ? poport : (FILE *)*save; ! 357: ! 358: gc1(NOTNIL(copval(gccheck,CNIL)) || (chkport!=poport)); /* mark&sweep */ ! 359: ! 360: /* Now we call gcafter--special case if gc called from LISP */ ! 361: ! 362: if( type_struct == (struct types *) CNIL ) ! 363: gccall1->cdr = nil; /* make the call "(gcafter)" */ ! 364: else ! 365: { ! 366: gccall1->cdr = gccall2; ! 367: gccall2->car = *(type_struct->type_name); ! 368: } ! 369: gcflag = TRUE; /* flag to indicate in garbage collector */ ! 370: save = eval(gccall1); /* call gcafter */ ! 371: gcflag = FALSE; /* turn off flag */ ! 372: ! 373: if(GCtime) { ! 374: times(&finish); ! 375: GCtime += (finish.mytime - begin.mytime); ! 376: } ! 377: return(save); /* return result of gcafter */ ! 378: } ! 379: ! 380: ! 381: ! 382: /* gc1() **************************************************************/ ! 383: /* */ ! 384: /* Mark-and-sweep phase */ ! 385: ! 386: gc1(chkflag) int chkflag; ! 387: { ! 388: int i, j, typep; ! 389: register int *start, *point; ! 390: struct types *s; ! 391: struct heads *loop; ! 392: struct argent *loop2; ! 393: int markdp(); ! 394: ! 395: ! 396: /* decide whether to check LISP structure or not */ ! 397: ! 398: ! 399: ! 400: ! 401: /* first set all bit maps to zero */ ! 402: ! 403: for(i=0; i<((int)datalim >> 8); ++i) bitmapq[i] = zeroq; ! 404: ! 405: ! 406: /* then mark all atoms' plists, clbs, and function bindings */ ! 407: ! 408: for(loop=atom_str.first; loop!=(struct heads *)CNIL; loop=loop->link) ! 409: for(start=(int *)(loop->pntr), i=1; ! 410: i <= atom_str.space; ! 411: start = start + atom_str.type_len, ++i) ! 412: { ! 413: ! 414: /* unused atoms are marked with pname == CNIL */ ! 415: /* this is done by get_more_space, as well as */ ! 416: /* by gc (in the future) */ ! 417: ! 418: if(((lispval)start)->pname == (char *)CNIL) continue; ! 419: #define MARKSUB(p) if(nil!=((lispval)start)->p)markdp(((lispval)start)->p); ! 420: MARKSUB(clb); ! 421: MARKSUB(fnbnd); ! 422: MARKSUB(plist); ! 423: } ! 424: ! 425: /* next run up the name stack */ ! 426: ! 427: for(loop2 = np - 1; loop2 >= orgnp; --loop2) markdp((loop2->val)); ! 428: /* from TBL 29july79 */ ! 429: /* next mark all compiler linked data */ ! 430: point = bind_lists; ! 431: while((start = point) != (int *)CNIL) { ! 432: while( *start != -1 ) ! 433: markdp(*start++); ! 434: point = (int *)*(point-1); ! 435: } ! 436: /* end from TBL */ ! 437: ! 438: /* next mark all system-significant lisp data */ ! 439: ! 440: for(i=0; i<SIGNIF; ++i) markdp((lispsys[i])); ! 441: ! 442: /* all accessible data has now been marked. */ ! 443: /* all collectable spaces must be swept, */ ! 444: /* and freelists constructed. */ ! 445: ! 446: for(i=0; i<NUMSPACES; ++i) ! 447: { ! 448: /* STRINGS do not participate. */ ! 449: /* ATOMS dont either (currently) */ ! 450: ! 451: s = spaces[i]; ! 452: typep = s->type; ! 453: if((typep==STRNG) || (typep==ATOM)) continue; ! 454: ! 455: s->space_left = 0; /* we will count free cells */ ! 456: (*(s->items))->i = 0; /* and compute cells used */ ! 457: ! 458: /* for each space, traverse list of pages. */ ! 459: ! 460: s->next_free = (char *) CNIL; /* reinitialize free list */ ! 461: ! 462: for(loop = s->first; loop != (struct heads *) CNIL; loop=loop->link) ! 463: { ! 464: /* add another page's worth to use count */ ! 465: ! 466: (*(s->items))->i += s->space; ! 467: ! 468: /* for each page, make a list of unmarked data */ ! 469: ! 470: for(j=0, point=(int *)(loop->pntr); ! 471: j<s->space; ++j, point += s->type_len) ! 472: if( ! lookbit(point) ) ! 473: { ! 474: /* add to free list */ ! 475: /* update pointer to free list*/ ! 476: /* update count of free list */ ! 477: ! 478: *point = (int)(s->next_free); ! 479: s->next_free = (char *) point; ! 480: ++(s->space_left); ! 481: } ! 482: } ! 483: (*(s->items))->i -= s->space_left; /* compute cells used */ ! 484: } ! 485: } ! 486: ! 487: /** alloc() *************************************************************/ ! 488: /* */ ! 489: /* This routine tries to allocate one more page of the space named */ ! 490: /* by the argument. If no more space is available returns 1, else 0. */ ! 491: ! 492: lispval ! 493: alloc(tname,npages) ! 494: lispval tname; int npages; ! 495: { ! 496: int ii, jj; ! 497: ! 498: ii = typenum(tname); ! 499: ! 500: for( jj=0; jj<npages; ++jj) ! 501: if(get_more_space(spaces[ii])) break; ! 502: return(inewint(jj)); ! 503: } ! 504: ! 505: lispval ! 506: csegment(tname,nitems) ! 507: lispval tname; int nitems; ! 508: { ! 509: int ii, jj; ! 510: char *charadd; ! 511: ! 512: ii = typenum(tname); ! 513: ! 514: nitems = nitems*4*spaces[ii]->type_len; /* find c-length of space */ ! 515: while( nitems%512 ) ++nitems; /* round up to right length */ ! 516: current += nitems/512; ! 517: charadd = sbrk(nitems); ! 518: if( (int) charadd == 0 ) ! 519: error("NOT ENOUGH SPACE FOR ARRAY",FALSE); ! 520: (datalim = (lispval)(charadd+nitems)); ! 521: if((((int)datalim) >> 9) > TTSIZE) { ! 522: datalim = (lispval) (TTSIZE << 9); ! 523: badmem(53); ! 524: } ! 525: for(jj=0; jj<nitems; jj=jj+512) { ! 526: SETTYPE(charadd+jj, spaces[ii]->type); ! 527: } ! 528: return((lispval)charadd); ! 529: } ! 530: ! 531: int csizeof(tname) lispval tname; ! 532: { ! 533: return( spaces[typenum(tname)]->type_len * 4 ); ! 534: } ! 535: ! 536: int typenum(tname) lispval tname; ! 537: { ! 538: int ii; ! 539: ! 540: chek: for(ii=0; ii<NUMSPACES; ++ii) ! 541: if(tname == *(spaces[ii]->type_name)) break; ! 542: if(ii == NUMSPACES) ! 543: { ! 544: tname = error("BAD TYPE NAME",TRUE); ! 545: goto chek; ! 546: } ! 547: ! 548: return(ii); ! 549: } ! 550: ! 551: /** markit(p) ***********************************************************/ ! 552: /* just calls markdp */ ! 553: ! 554: markit(p) lispval *p; { markdp(*p); } ! 555: ! 556: /** markdp(p) ***********************************************************/ ! 557: /* */ ! 558: /* markdp is the routine which marks each data item. If it is a */ ! 559: /* dotted pair, the car and cdr are marked also. */ ! 560: /* An iterative method is used to mark list structure, to avoid */ ! 561: /* excessive recursion. */ ! 562: ! 563: ! 564: markdp(p) register lispval p; ! 565: { ! 566: /* register int r, s; (goes with non-asm readbit, oksetbit) */ ! 567: ! 568: ptr_loop: ! 569: if((int)p <= 0) return; /* do not mark special data types or nil=0 */ ! 570: ! 571: switch( TYPE(p) ) ! 572: { ! 573: case INT: ! 574: case DOUB: ! 575: /* setbit(p);*/ ! 576: ftstbit; ! 577: return; ! 578: case VALUE: ! 579: ftstbit; ! 580: p = p->l; ! 581: goto ptr_loop; ! 582: case DTPR: ! 583: ftstbit; ! 584: markdp(p->car); ! 585: p = p->cdr; ! 586: goto ptr_loop; ! 587: ! 588: case ARRAY: ! 589: ftstbit; /* mark array itself */ ! 590: ! 591: markdp(p->accfun); /* mark access function */ ! 592: markdp(p->aux); /* mark aux data */ ! 593: markdp(p->length); /* mark length */ ! 594: markdp(p->delta); /* mark delta */ ! 595: ! 596: { ! 597: register int i, l; int d; ! 598: register char *dataptr = p->data; ! 599: ! 600: for(i=0, l=p->length->i, d=p->delta->i; i<l; ++i) ! 601: { ! 602: markdp(dataptr); ! 603: dataptr += d; ! 604: } ! 605: return; ! 606: } ! 607: case SDOT: ! 608: do { ! 609: ftstbit; ! 610: p = p->CDR; ! 611: } while (p!=0); ! 612: return; ! 613: ! 614: case BCD: ! 615: ftstbit; ! 616: markdp(p->discipline); ! 617: return; ! 618: } ! 619: return; ! 620: } ! 621: ! 622: ! 623: ! 624: char * ! 625: xsbrk() ! 626: { ! 627: static char *xx; /* pointer to next available blank page */ ! 628: static int cycle = 0; /* number of blank pages available */ ! 629: lispval u; /* used to compute limits of bit table */ ! 630: ! 631: if( (cycle--) <= 0 ) ! 632: { ! 633: cycle = 15; ! 634: xx = sbrk(16*NBPG); /* get pages 16 at a time */ ! 635: if( (int)xx== -1 ) ! 636: lispend("For sbrk from lisp: no space... Goodbye!"); ! 637: goto done; ! 638: } ! 639: xx += NBPG; ! 640: done: if( (u = (lispval)(xx+NBPG)) > datalim ) datalim = u; ! 641: return(xx); ! 642: } ! 643: ! 644: char *ysbrk(pages,type) int pages, type; ! 645: { ! 646: char *xx; /* will point to block of storage */ ! 647: int i; ! 648: ! 649: xx = sbrk(pages*NBPG); ! 650: if((int)xx == -1) ! 651: error("OUT OF SPACE FOR ARRAY REQUEST",FALSE); ! 652: ! 653: datalim = (lispval)(xx+pages*NBPG); /* compute bit table limit */ ! 654: ! 655: /* set type for pages */ ! 656: ! 657: for(i = 0; i < pages; ++i) { ! 658: SETTYPE((xx + i*NBPG),type); ! 659: } ! 660: ! 661: return(xx); /* return pointer to block of storage */ ! 662: } ! 663: ! 664: /* getatom **************************************************************/ ! 665: /* returns either an existing atom with the name specified in strbuf, or*/ ! 666: /* if the atom does not already exist, regurgitates a new one and */ ! 667: /* returns it. */ ! 668: lispval ! 669: getatom() ! 670: { register lispval aptr; ! 671: register char *name, *endname; ! 672: lispval b; ! 673: char c; ! 674: register int hash; ! 675: snpand(4); ! 676: ! 677: name = strbuf; ! 678: if (*name == (char)0377) return (eofa); ! 679: hash = 0; ! 680: for(name=strbuf; *name;) { ! 681: hash ^= *name++; ! 682: } ! 683: hash &= 0177; /* make sure no high-order bits have crept in */ ! 684: atmlen = name - strbuf + 1; ! 685: aptr = (lispval) hasht[hash]; ! 686: while (aptr != CNIL) ! 687: if (strcmp(strbuf,aptr->pname)==0) ! 688: return (aptr); ! 689: else ! 690: aptr = (lispval) aptr->hshlnk; ! 691: aptr = (lispval) newatom(); ! 692: aptr->hshlnk = hasht[hash]; ! 693: hasht[hash] = (struct atom *) aptr; ! 694: endname = name - 1; ! 695: name = strbuf; ! 696: if ((atmlen != 4) && (*name == 'c') && (*endname == 'r')) ! 697: { ! 698: b = newdot(); ! 699: protect(b); ! 700: b->car = lambda; ! 701: b->cdr = newdot(); ! 702: b = b->cdr; ! 703: b->car = newdot(); ! 704: (b->car)->car = xatom; ! 705: while(TRUE) ! 706: { ! 707: b->cdr = newdot(); ! 708: b= b->cdr; ! 709: if(++name == endname) ! 710: { ! 711: b->car= (lispval) xatom; ! 712: aptr->fnbnd = unprot(); ! 713: break; ! 714: } ! 715: b->car= newdot(); ! 716: b= b->car; ! 717: if((c = *name) == 'a') b->car = cara; ! 718: else if (c == 'd') b->car = cdra; ! 719: else{ unprot(); ! 720: break; ! 721: } ! 722: } ! 723: } ! 724: ! 725: return(aptr); ! 726: } ! 727:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.