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