![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to nfasl.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 41BSD / cmd / lisp|
Return to nfasl.c CVS log | Up to [CSRG BSD Unix] / 41BSD / cmd / lisp |
1.1 ! root 1: static char *sccsid = "@(#)nfasl.c 34.5 10/13/80"; ! 2: ! 3: #include "global.h" ! 4: #include <sys/types.h> ! 5: #include <pagsiz.h> ! 6: #include "naout.h" ! 7: #include "chkrtab.h" ! 8: #include "structs.h" ! 9: ! 10: /* fasl - fast loader j.k.foderaro ! 11: * this loader is tuned for the lisp fast loading application ! 12: * any changes in the system loading procedure will require changes ! 13: * to this file ! 14: * ! 15: * The format of the object file we read as input: ! 16: * text segment: ! 17: * 1) program text - this comes first. ! 18: * 2) binder table - one word entries, see struct bindage ! 19: * begins with symbol: bind_org ! 20: * 3) litterals - exploded lisp objects. ! 21: * begins with symbol: lit_org ! 22: * ends with symbol: lit_end ! 23: * data segment: ! 24: * not used ! 25: * ! 26: * ! 27: * these segments are created permanently in memory: ! 28: * code segment - contains machine codes to evaluate lisp functions. ! 29: * linker segment - a list of pointers to lispvals. This allows the ! 30: * compiled code to reference constant lisp objects. ! 31: * The first word of the linker segment is a gc link ! 32: * pointer and does not point to a literal. The ! 33: * symbol binder is assumed to point to the second ! 34: * longword in this segment. The last word in the ! 35: * table is -1 as a sentinal to the gc marker. ! 36: * The number of real entries in the linker segment ! 37: * is given as the value of the linker_size symbol. ! 38: * Taking into account the 2 words required for the ! 39: * gc, there are 4*linker_size + 8 bytes in this segment. ! 40: * transfer segment - this is a transfer table block. It is used to ! 41: * allow compiled code to call other functions ! 42: * quickly. The number of entries in the transfer table is ! 43: * given as the value of the trans_size symbol. ! 44: * ! 45: * the following segments are set up in memory temporarily then flushed ! 46: * binder segment - a list of struct bindage entries. They describe ! 47: * what to do with the literals read from the literal ! 48: * table. The binder segment begins in the file ! 49: * following the bindorg symbol. ! 50: * literal segment - a list of characters which _Lread will read to ! 51: * create the lisp objects. The order of the literals ! 52: * is: ! 53: * linker literals - used to fill the linker segment. ! 54: * transfer table literals - used to fill the ! 55: * transfer segment ! 56: * binder literals - these include names of functions ! 57: * to bind interspersed with forms to evaluate. ! 58: * The meanings of the binder literals is given by ! 59: * the values in the binder segment. ! 60: * string segment - this is the string table from the file. We have ! 61: * to allocate space for it in core to speed up ! 62: * symbol referencing. ! 63: * ! 64: */ ! 65: ! 66: ! 67: /* external functions called or referenced */ ! 68: ! 69: lispval qcons(),qlinker(),qget(); ! 70: int _qf0(), _qf1(), _qf2(), _qf3(), _qf4(), _qfuncl(), svkludg(),qnewint(); ! 71: lispval Lread(), Lcons(), Lminus(), Ladd1(), Lsub1(), Lplist(), Lputprop(); ! 72: lispval Lprint(), Lpatom(), Lconcat(), Lget(), Lmapc(), Lmapcan(); ! 73: lispval Llist(), Ladd(), Lgreaterp(), Lequal(), Ltimes(), Lsub(); ! 74: lispval Lncons(); ! 75: lispval Idothrow(),error(); ! 76: lispval Istsrch(); ! 77: int mcount(); ! 78: extern int mcounts[],mcountp,doprof; ! 79: ! 80: extern lispval *tynames[]; ! 81: extern long errp; ! 82: extern char _erthrow[]; ! 83: extern char setsav[]; ! 84: ! 85: extern int initflag; /* when TRUE, inhibits gc */ ! 86: ! 87: char *alloca(); /* stack space allocator */ ! 88: ! 89: /* mini symbol table, contains the only external symbols compiled code ! 90: is allowed to reference ! 91: */ ! 92: ! 93: #define SYMMAX 16 ! 94: struct ssym { char *fnam; /* pointer to string containing name */ ! 95: int floc; /* address of symbol */ ! 96: int ord; /* ordinal number within cur sym tab */ ! 97: ! 98: } Symbtb[SYMMAX] ! 99: = { ! 100: "trantb", 0, -1, /* must be first */ ! 101: "linker", 0, -1, /* must be second */ ! 102: "mcount", (int) mcount, -1, ! 103: "mcounts", (int) mcounts, -1, ! 104: "_qnewint", (int) qnewint, -1, ! 105: "_qcons", (int) qcons, -1, ! 106: "_typetable", (int) typetable, -1, ! 107: "_tynames", (int) tynames, -1, ! 108: "_qget", (int) qget, -1, ! 109: "_errp", (int) &errp, -1, ! 110: "_Idothrow", (int) Idothrow, -1, ! 111: "__erthrow", (int) _erthrow, -1, ! 112: "_error", (int) error, -1, ! 113: "_setsav", (int) setsav, -1, ! 114: "_svkludg", (int) svkludg, -1, ! 115: "_bnp", (int) &bnp, -1, ! 116: }; ! 117: ! 118: struct nlist syml; /* to read a.out symb tab */ ! 119: extern lispval *bind_lists; /* gc binding lists */ ! 120: ! 121: /* bindage structure: ! 122: * the bindage structure describes the linkages of functions and name, ! 123: * and tells which functions should be evaluated. It is mainly used ! 124: * for the non-fasl'ing of files, we only use one of the fields in fasl ! 125: */ ! 126: struct bindage ! 127: { ! 128: int b_type; /* type code, as described below */ ! 129: }; ! 130: ! 131: /* the possible values of b_type ! 132: * -1 - this is the end of the bindage entries ! 133: * 0 - this is a lambda function ! 134: * 1 - this is a nlambda function ! 135: * 2 - this is a macro function ! 136: * 99 - evaluate the string ! 137: * ! 138: */ ! 139: ! 140: ! 141: extern struct trtab *trhead; /* head of list of transfer tables */ ! 142: extern struct trent *trcur; /* next entry to allocate */ ! 143: extern int trleft; /* # of entries left in this transfer table */ ! 144: ! 145: struct trent *gettran(); /* function to allocate entries */ ! 146: ! 147: /* maximum number of functions */ ! 148: #define MAXFNS 500 ! 149: ! 150: lispval Lnfasl() ! 151: { ! 152: extern int holend,usehole; ! 153: extern int uctolc; ! 154: extern char *curhbeg; ! 155: struct argent *svnp; ! 156: struct exec exblk; /* stores a.out header */ ! 157: FILE *filp, *p, *map; /* file pointer */ ! 158: int domap,note_redef; ! 159: lispval handy,debugmode; ! 160: struct relocation_info reloc; ! 161: struct trent *tranloc; ! 162: int trsize; ! 163: lispval disp; ! 164: int i,j,times, *iptr, oldinitflag; ! 165: int funloc[MAXFNS]; /* addresses of functions rel to txt org */ ! 166: int funcnt = 0; ! 167: ! 168: /* symbols whose values are taken from symbol table of .o file */ ! 169: int bind_org = 0; /* beginning of bind table */ ! 170: int lit_org = 0; /* beginning of literal table */ ! 171: int lit_end; /* end of literal table */ ! 172: int trans_size = 0; /* size in entries of transfer table */ ! 173: int linker_size; /* size in bytes of linker table ! 174: (not counting gc ptr) */ ! 175: ! 176: /* symbols which hold the locations of the segments in core and ! 177: * in the file ! 178: */ ! 179: char *code_core_org, /* beginning of code segment */ ! 180: *linker_core_org, /* beginning of linker segment */ ! 181: *linker_core_end, /* last word in linker segment */ ! 182: *literal_core_org, /* beginning of literal table */ ! 183: *binder_core_org, /* beginning of binder table */ ! 184: *string_core_org; ! 185: ! 186: int string_file_org, /* location of string table in file */ ! 187: string_size, /* number of chars in string table */ ! 188: segsiz; /* size of permanent incore segment */ ! 189: ! 190: char *symbol_name; ! 191: struct bindage *bindorg, *curbind; ! 192: int linkerloc, typer; ! 193: lispval rdform, *linktab; ! 194: int ouctolc; ! 195: int debug = 0; ! 196: lispval currtab,curibase; ! 197: char ch,*filnm; ! 198: char tempfilbf[100]; ! 199: ! 200: ! 201: switch(np-lbot) { ! 202: case 0: ! 203: protect(nil); ! 204: case 1: ! 205: protect(nil); ! 206: case 2: ! 207: protect(nil); ! 208: case 3: ! 209: break; ! 210: default: ! 211: argerr("fasl"); ! 212: } ! 213: filnm = (char *) verify(lbot->val,"fasl: non atom arg"); ! 214: ! 215: ! 216: domap = FALSE; ! 217: /* debugging */ ! 218: debugmode = Istsrch(matom("debugging"))->d.cdr->d.cdr->d.cdr; ! 219: /* end debugging */ ! 220: ! 221: ! 222: /* insure that the given file name ends in .o ! 223: if it doesnt, copy to a new buffer and add a .o ! 224: */ ! 225: tempfilbf[0] = '\0'; ! 226: if( (i = strlen(filnm)) < 2 || ! 227: strcmp(filnm+i-2,".o") != 0) ! 228: { ! 229: strcatn(tempfilbf,filnm,96); ! 230: strcat(tempfilbf,".o"); ! 231: filnm = tempfilbf; ! 232: } ! 233: ! 234: if ( (filp = fopen(filnm,"r")) == NULL) ! 235: errorh(Vermisc,"Can't open file",nil,FALSE,9797,lbot->val); ! 236: ! 237: if ((handy = (lbot+1)->val) != nil ) ! 238: { ! 239: if((TYPE(handy) != ATOM ) || ! 240: (map = fopen(handy->a.pname, ! 241: (Istsrch(matom("appendmap"))->d.cdr->d.cdr->d.cdr == nil ! 242: ? "w" : "a"))) == NULL) ! 243: error("fasl: can't open map file",FALSE); ! 244: else ! 245: { domap = TRUE; ! 246: /* fprintf(map,"Map of file %s\n",lbot->val->a.pname); */ ! 247: } ! 248: } ! 249: ! 250: /* set the note redefinition flag */ ! 251: if((lbot+2)->val != nil) note_redef = TRUE; ! 252: else note_redef = FALSE; ! 253: ! 254: printf("[fasl %s]",filnm); ! 255: fflush(stdout); ! 256: svnp = np; ! 257: ! 258: lbot = np; /* set up base for later calls */ ! 259: ! 260: ! 261: /* clear the ords in the symbol table */ ! 262: for(i=0 ; i < SYMMAX ; i++) Symbtb[i].ord = -1; ! 263: ! 264: if( read(fileno(filp),&exblk,sizeof(struct exec)) ! 265: != sizeof(struct exec)) ! 266: error("fasl: header read failed",FALSE); ! 267: ! 268: /* check that the magic number is valid */ ! 269: ! 270: if(exblk.a_magic != 0407) error("fasl: bad magic number in fasl file",FALSE); ! 271: ! 272: /* read in string table */ ! 273: lseek(fileno(filp),(string_file_org = N_STROFF(exblk)),0); ! 274: if( read(fileno(filp), &string_size , 4) != 4) ! 275: error("fasl: string table read error, probably old fasl format", FALSE); ! 276: ! 277: /* allocate space for string table on the stack */ ! 278: string_core_org = alloca(string_size - 4); ! 279: ! 280: if( read(fileno(filp), string_core_org , string_size - 4) ! 281: != string_size -4) error("fasl: string table read error ",FALSE); ! 282: /* read in symbol table and set the ordinal values */ ! 283: ! 284: fseek(filp,N_SYMOFF(exblk),0); ! 285: ! 286: times = exblk.a_syms/sizeof(struct nlist); ! 287: if(debug) printf(" %d symbols in symbol table\n",times); ! 288: ! 289: for(i=0; i < times ; i++) ! 290: { ! 291: if( fread(&syml,sizeof(struct nlist),1,filp) != 1) ! 292: error("fasl: Symb tab read error",FALSE); ! 293: ! 294: symbol_name = syml.n_un.n_strx - 4 + string_core_org; ! 295: if (syml.n_type == N_EXT) ! 296: { ! 297: for(j=0; j< SYMMAX; j++) ! 298: { ! 299: if((Symbtb[j].ord < 0) ! 300: && strcmp(Symbtb[j].fnam,symbol_name)==0) ! 301: { Symbtb[j].ord = i; ! 302: if(debug)printf("symbol %s ord is %d\n",symbol_name,i); ! 303: break; ! 304: }; ! 305: ! 306: }; ! 307: ! 308: if( j>=SYMMAX ) printf("Unknown symbol %s\n",symbol_name); ! 309: } ! 310: else if (((ch = symbol_name[0]) == 's') ! 311: || (ch == 'L') ! 312: || (ch == '.') ) ; /* skip this */ ! 313: else if (symbol_name[0] == 'F') ! 314: funloc[funcnt++] = syml.n_value; /* seeing function */ ! 315: else if (!bind_org && (strcmp(symbol_name, "bind_org") == 0)) ! 316: bind_org = syml.n_value; ! 317: else if (strcmp(symbol_name, "lit_org") == 0) ! 318: lit_org = syml.n_value; ! 319: else if (strcmp(symbol_name, "lit_end") == 0) ! 320: lit_end = syml.n_value; ! 321: else if (strcmp(symbol_name, "trans_size") == 0) ! 322: trans_size = syml.n_value; ! 323: else if (strcmp(symbol_name, "linker_size") == 0) ! 324: linker_size = syml.n_value; ! 325: } ! 326: ! 327: /* check to make sure we are working with the right format */ ! 328: if((lit_org == 0) || (lit_end == 0)) ! 329: errorh(Vermisc,"File not in new fasl format",nil,FALSE,0,lbot->val); ! 330: ! 331: /*----------------*/ ! 332: ! 333: /* read in text segment up to beginning of binder table */ ! 334: ! 335: segsiz = bind_org + 4*linker_size + 8 + 3; /* size is core segment size ! 336: * plus linker table size ! 337: * plus 2 for gc list ! 338: * plus 3 to round up to word ! 339: */ ! 340: ! 341: lseek(fileno(filp),(long)sizeof(struct exec),0); ! 342: code_core_org = (char *) csegment(str_name,segsiz/4,TRUE); ! 343: if(read(fileno(filp),code_core_org,bind_org) != bind_org) ! 344: error("Read error in text ",FALSE); ! 345: ! 346: if(debug) { ! 347: printf("Read %d bytes of text into 0x%x\n",bind_org,code_core_org); ! 348: printf(" incore segment size: %d (0x%x)\n",segsiz,segsiz); ! 349: } ! 350: ! 351: /* linker table is 2 entries (8 bytes) larger than the number of ! 352: * entries given by linker_size . There must be a gc word at ! 353: * the beginning and a -1 at the end ! 354: */ ! 355: linker_core_org = code_core_org + bind_org; ! 356: linker_core_end = linker_core_org + 4*linker_size + 4; ! 357: /* address of gc sentinal last */ ! 358: ! 359: if(debug)printf("lin_cor_org: %x, link_cor_end %x\n", ! 360: linker_core_org, ! 361: linker_core_end); ! 362: Symbtb[1].floc = (int) (linker_core_org + 4); ! 363: ! 364: /* set the linker table to all -1's so we can put in the gc table */ ! 365: for( iptr = (int *)(linker_core_org + 4 ); ! 366: iptr <= (int *)(linker_core_end); ! 367: iptr++) ! 368: *iptr = -1; ! 369: ! 370: ! 371: /* link our table into the gc tables */ ! 372: *(int *)linker_core_org = (int)bind_lists; /* point to current */ ! 373: bind_lists = (lispval *) (linker_core_org + 4); /* point to first item */ ! 374: ! 375: /* read the binder table and literals onto the stack */ ! 376: ! 377: binder_core_org = alloca(lit_end - bind_org); ! 378: read(fileno(filp),binder_core_org,lit_end-bind_org); ! 379: ! 380: literal_core_org = binder_core_org + lit_org - bind_org; ! 381: ! 382: /* check if there is a transfer table required for this ! 383: * file, and if so allocate one of the necessary size ! 384: */ ! 385: ! 386: if(trans_size > 0) ! 387: { ! 388: tranloc = gettran(trans_size); ! 389: Symbtb[0].floc = (int) tranloc; ! 390: } ! 391: ! 392: /* now relocate the necessary symbols in the text segment */ ! 393: ! 394: fseek(filp,(long)(sizeof(struct exec) + exblk.a_text + exblk.a_data),0); ! 395: times = (exblk.a_trsize)/sizeof(struct relocation_info); ! 396: ! 397: /* the only symbols we will relocate are references to ! 398: external symbols. They are recognized by ! 399: extern and pcrel set. ! 400: */ ! 401: ! 402: for( i=1; i<=times ; i++) ! 403: { ! 404: if( fread(&reloc,sizeof(struct relocation_info),1,filp) != 1) ! 405: error("Bad text reloc read",FALSE); ! 406: if(reloc.r_extern && reloc.r_pcrel) ! 407: { ! 408: for(j=0; j < SYMMAX; j++) ! 409: { ! 410: ! 411: if(Symbtb[j].ord == reloc.r_symbolnum) /* look for this sym */ ! 412: { ! 413: if(debug && FALSE) printf("Relocating %d (ord %d) at %x\n", ! 414: j, Symbtb[j].ord, reloc.r_address); ! 415: if (Symbtb[j].floc == (int) mcounts) { ! 416: *(int *)(code_core_org+reloc.r_address) ! 417: += mcountp - (int)code_core_org; ! 418: if(doprof){ ! 419: if (mcountp == (int) &mcounts[NMCOUNT-2]) ! 420: printf("Ran out of counters; increas NMCOUNT in fasl.c\n"); ! 421: if (mcountp < (int) &mcounts[NMCOUNT-1]) ! 422: mcountp += 4; ! 423: } ! 424: } else ! 425: *(int *)(code_core_org+reloc.r_address) ! 426: += Symbtb[j].floc - (int)code_core_org; ! 427: ! 428: break; ! 429: ! 430: } ! 431: }; ! 432: if( j >= SYMMAX) if(debug) printf("Couldnt find ord # %d\n", ! 433: reloc.r_symbolnum); ! 434: } ! 435: ! 436: } ! 437: ! 438: putchar('\n'); ! 439: fflush(stdout); ! 440: ! 441: /* set up a fake port so we can read from core */ ! 442: /* first find a free port */ ! 443: ! 444: p = stdin; ! 445: for( ; p->_flag & (_IOREAD|_IOWRT) ; p++) ! 446: if( p >= _iob + _NFILE) ! 447: error(" No free file descriptor for fasl ",FALSE); ! 448: ! 449: p->_flag = _IOREAD | _IOSTRG; ! 450: p->_base = p->_ptr = (char *) literal_core_org; /* start at beginning of lit */ ! 451: p->_cnt = lit_end - lit_org; ! 452: ! 453: if(debug)printf("lit_org %d, charstrt %d\n",lit_org, p->_base); ! 454: /* the first forms we wish to read are those literals in the ! 455: * literal table, that is those forms referenced by an offset ! 456: * from r8 in compiled code ! 457: */ ! 458: ! 459: /* to read in the forms correctly, we must set up the read table ! 460: */ ! 461: currtab = Vreadtable->a.clb; ! 462: Vreadtable->a.clb = strtab; /* standard read table */ ! 463: curibase = ibase->a.clb; ! 464: ibase->a.clb = inewint(10); /* read in decimal */ ! 465: ouctolc = uctolc; /* remember value of uctolc flag */ ! 466: ! 467: oldinitflag = initflag; /* remember current val */ ! 468: initflag = TRUE; /* turn OFF gc */ ! 469: i = 1; ! 470: linktab = (lispval *)(linker_core_org +4); ! 471: while (linktab < (lispval *)linker_core_end) ! 472: { ! 473: np = svnp; ! 474: protect(P(p)); ! 475: uctolc = FALSE; ! 476: handy = Lread(); ! 477: uctolc = ouctolc; ! 478: getc(p); /* eat trailing blank */ ! 479: if(debugmode) ! 480: { printf("form %d read: ",i++); ! 481: printr(handy,stdout); ! 482: putchar('\n'); ! 483: fflush(stdout); ! 484: } ! 485: *linktab++ = handy; ! 486: } ! 487: ! 488: /* process the transfer table if one is used */ ! 489: trsize = trans_size; ! 490: while(trsize--) ! 491: { ! 492: np = svnp; ! 493: protect(P(p)); ! 494: uctolc = FALSE; ! 495: handy = Lread(); /* get function name */ ! 496: uctolc = ouctolc; ! 497: getc(p); ! 498: tranloc->name = handy; ! 499: tranloc->fcn = qlinker; /* initially go to qlinker */ ! 500: tranloc++; ! 501: } ! 502: ! 503: ! 504: ! 505: /* now process the binder table, which contains pointers to ! 506: functions to link in and forms to evaluate. ! 507: */ ! 508: funcnt = 0; ! 509: ! 510: curbind = (struct bindage *) binder_core_org; ! 511: for( ; curbind->b_type != -1 ; curbind++) ! 512: { ! 513: np = svnp; ! 514: protect(P(p)); ! 515: uctolc = FALSE; /* inhibit uctolc conversion */ ! 516: rdform = Lread(); ! 517: /* debugging */ ! 518: if(debugmode) { printf("link form read: "); ! 519: printr(rdform,stdout); ! 520: printf(" ,type: %d\n", ! 521: curbind->b_type); ! 522: fflush(stdout); ! 523: } ! 524: /* end debugging */ ! 525: uctolc = ouctolc; /* restore previous state */ ! 526: getc(p); /* eat trailing null */ ! 527: protect(rdform); ! 528: if(curbind->b_type <= 2) /* if function type */ ! 529: { ! 530: handy = newfunct(); ! 531: if (note_redef && (rdform->a.fnbnd != nil)) ! 532: { ! 533: printr(rdform,stdout); ! 534: printf(" redefined\n"); ! 535: } ! 536: rdform->a.fnbnd = handy; ! 537: handy->bcd.entry = (lispval (*)())(code_core_org + funloc[funcnt++]); ! 538: handy->bcd.discipline = ! 539: (curbind->b_type == 0 ? lambda : ! 540: curbind->b_type == 1 ? nlambda : ! 541: macro); ! 542: if(domap) fprintf(map,"%s\n%x\n",rdform->a.pname,handy->bcd.entry); ! 543: } ! 544: else { ! 545: Vreadtable->a.clb = currtab; ! 546: ibase->a.clb = curibase; ! 547: ! 548: /* debugging */ ! 549: if(debugmode) { ! 550: printf("Eval: "); ! 551: printr(rdform,stdout); ! 552: printf("\n"); ! 553: fflush(stdout); ! 554: }; ! 555: /* end debugging */ ! 556: ! 557: eval(rdform); /* otherwise eval it */ ! 558: ! 559: if(uctolc) ouctolc = TRUE; /* if changed by eval, remember */ ! 560: curibase = ibase->a.clb; ! 561: ibase->a.clb = inewint(10); ! 562: Vreadtable->a.clb = strtab; ! 563: } ! 564: }; ! 565: ! 566: p->_cnt = p->_file = p->_flag = 0; /* give up file descriptor */ ! 567: p->_ptr = p-> _base = (char *) 0; ! 568: initflag = oldinitflag; /* restore state of gc */ ! 569: Vreadtable->a.clb = currtab; ! 570: chkrtab(currtab); ! 571: ibase->a.clb = curibase; ! 572: ! 573: fclose(filp); ! 574: if(domap) fclose(map); ! 575: return(tatom); ! 576: } ! 577: ! 578: ! 579: /* gettran :: allocate a segment of transfer table of the given size */ ! 580: ! 581: struct trent * ! 582: gettran(size) ! 583: { ! 584: struct trtab *trp; ! 585: struct trent *retv; ! 586: int ousehole; ! 587: extern int usehole; ! 588: ! 589: if(size > TRENTS) ! 590: error("transfer table too large",FALSE); ! 591: ! 592: if(size > trleft) ! 593: { ! 594: /* allocate a new transfer table */ ! 595: /* must not allocate in the hole or we cant modify it */ ! 596: ousehole = usehole; /* remember old value */ ! 597: usehole = FALSE; ! 598: trp = (struct trtab *)csegment(str_name,sizeof(struct trtab),FALSE); ! 599: usehole = ousehole; ! 600: ! 601: trp->sentinal = 0; /* make sure the sentinal is 0 */ ! 602: trp->nxtt = trhead; /* link at beginning of table */ ! 603: trhead = trp; ! 604: trcur = &(trp->trentrs[0]); /* begin allocating here */ ! 605: trleft = TRENTS; ! 606: } ! 607: ! 608: trleft = trleft - size; ! 609: retv = trcur; ! 610: trcur = trcur + size; ! 611: return(retv); ! 612: } ! 613: ! 614: /* clrtt :: clear transfer tables, or link them all up; ! 615: * this has two totally opposite functions: ! 616: * 1) all transfer tables are reset so that all function calls will go ! 617: * through qlinker ! 618: * 2) as many transfer tables are set up to point to bcd functions ! 619: * as possible ! 620: */ ! 621: clrtt(flag) ! 622: { ! 623: /* flag = 0 :: set to qlinker ! 624: * flag = 1 :: set to function bcd binding if possible ! 625: */ ! 626: register struct trtab *temptt; ! 627: register struct trent *tement; ! 628: register lispval fnb; ! 629: ! 630: for (temptt = trhead; temptt != 0 ; temptt = temptt->nxtt) ! 631: { ! 632: for(tement = &temptt->trentrs[0] ; tement->fcn != 0 ; tement++) ! 633: { if(flag == 0 || TYPE(fnb=tement->name->a.fnbnd) != BCD ! 634: || TYPE(fnb->bcd.discipline) == STRNG) ! 635: tement->fcn = qlinker; ! 636: else tement->fcn = fnb->bcd.entry; ! 637: } ! 638: } ! 639: } ! 640: ! 641: /* chktt - builds a list of transfer table entries which don't yet have ! 642: a function associated with them, i.e if this transfer table entry ! 643: were used, an undefined function error would result ! 644: */ ! 645: lispval ! 646: chktt() ! 647: { ! 648: register struct trtab *temptt; ! 649: register struct trent *tement; ! 650: register lispval retlst,curv; ! 651: ! 652: snpand(4); ! 653: ! 654: retlst = newdot(); /* build list of undef functions */ ! 655: protect(retlst); ! 656: for (temptt = trhead; temptt != 0 ; temptt = temptt->nxtt) ! 657: { ! 658: for(tement = &temptt->trentrs[0] ; tement->fcn != 0 ; tement++) ! 659: { ! 660: if(tement->name->a.fnbnd == nil) ! 661: { ! 662: curv= newdot(); ! 663: curv->d.car = tement->name; ! 664: curv->d.cdr = retlst->d.cdr; ! 665: retlst->d.cdr = curv; ! 666: } ! 667: } ! 668: } ! 669: return(retlst->d.cdr); ! 670: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.