![[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] / 43BSD / ucb / lisp / franz|
Return to fasl.c CVS log | Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / franz |
1.1 ! root 1: #ifndef lint ! 2: static char *rcsid = ! 3: "$Header: fasl.c,v 1.10 85/03/24 11:03:34 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 mcnts[],mcntp,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: "mcnts", (int) mcnts, -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, *fstopen(); /* 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: strncat(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) mcnts) { ! 473: *(int *)(code_core_org+reloc.r_address) ! 474: += mcntp - offset(reloc); ! 475: if(doprof){ ! 476: if (mcntp == (int) &mcnts[NMCOUNT-2]) ! 477: printf("Ran out of counters; increas NMCOUNT in fasl.c\n"); ! 478: if (mcntp < (int) &mcnts[NMCOUNT-1]) ! 479: mcntp += 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 = fstopen((char *) literal_core_org, lit_end - lit_org, "r"); ! 504: ! 505: if(debug)printf("lit_org %d, charstrt %d\n",lit_org, p->_base); ! 506: /* the first forms we wish to read are those literals in the ! 507: * literal table, that is those forms referenced by an offset ! 508: * from r8 in compiled code ! 509: */ ! 510: ! 511: /* to read in the forms correctly, we must set up the read table ! 512: */ ! 513: currtab = Vreadtable->a.clb; ! 514: Vreadtable->a.clb = strtab; /* standard read table */ ! 515: curibase = ibase->a.clb; ! 516: ibase->a.clb = inewint(10); /* read in decimal */ ! 517: ouctolc = uctolc; /* remember value of uctolc flag */ ! 518: ! 519: PUSHDOWN(gcdis,tatom); /* turn off gc */ ! 520: ! 521: i = 1; ! 522: linktab = (lispval *)(lc_org +4); ! 523: while (linktab < (lispval *)lc_end) ! 524: { ! 525: np = svnp; ! 526: protect(P(p)); ! 527: uctolc = FALSE; ! 528: handy = (lispval)Lread(); ! 529: if (Vpurcopylits->a.clb != nil) { ! 530: handy = Ipurcopy(handy); ! 531: } ! 532: uctolc = ouctolc; ! 533: getc(p); /* eat trailing blank */ ! 534: if(debugmode != nil) ! 535: { printf("form %d read: ",i++); ! 536: printr(handy,stdout); ! 537: putchar('\n'); ! 538: fflush(stdout); ! 539: } ! 540: *linktab++ = handy; ! 541: } ! 542: ! 543: /* process the transfer table if one is used */ ! 544: trsize = trans_size; ! 545: while(trsize--) ! 546: { ! 547: np = svnp; ! 548: protect(P(p)); ! 549: uctolc = FALSE; ! 550: handy = Lread(); /* get function name */ ! 551: uctolc = ouctolc; ! 552: getc(p); ! 553: tranloc->name = handy; ! 554: tranloc->fcn = qlinker; /* initially go to qlinker */ ! 555: tranloc++; ! 556: } ! 557: ! 558: ! 559: ! 560: /* now process the binder table, which contains pointers to ! 561: functions to link in and forms to evaluate. ! 562: */ ! 563: funcnt = 0; ! 564: ! 565: curbind = (struct bindage *) binder_core_org; ! 566: for( ; curbind->b_type != -1 ; curbind++) ! 567: { ! 568: np = svnp; ! 569: protect(P(p)); ! 570: uctolc = FALSE; /* inhibit uctolc conversion */ ! 571: rdform = Lread(); ! 572: /* debugging */ ! 573: if(debugmode != nil) { printf("link form read: "); ! 574: printr(rdform,stdout); ! 575: printf(" ,type: %d\n", ! 576: curbind->b_type); ! 577: fflush(stdout); ! 578: } ! 579: /* end debugging */ ! 580: uctolc = ouctolc; /* restore previous state */ ! 581: getc(p); /* eat trailing null */ ! 582: protect(rdform); ! 583: if(curbind->b_type <= 2) /* if function type */ ! 584: { ! 585: handy = newfunct(); ! 586: if (note_redef && (rdform->a.fnbnd != nil)) ! 587: { ! 588: printr(rdform,stdout); ! 589: printf(" redefined\n"); ! 590: } ! 591: rdform->a.fnbnd = handy; ! 592: handy->bcd.start = (lispval (*)())(code_core_org + funloc[funcnt++]); ! 593: handy->bcd.discipline = ! 594: (curbind->b_type == 0 ? lambda : ! 595: curbind->b_type == 1 ? nlambda : ! 596: macro); ! 597: if(domap) { ! 598: fprintf(map,"%s\n%x\n",rdform->a.pname,handy->bcd.start); ! 599: } ! 600: } ! 601: else { ! 602: Vreadtable->a.clb = currtab; ! 603: ibase->a.clb = curibase; ! 604: ! 605: /* debugging */ ! 606: if(debugmode != nil) { ! 607: printf("Eval: "); ! 608: printr(rdform,stdout); ! 609: printf("\n"); ! 610: fflush(stdout); ! 611: }; ! 612: /* end debugging */ ! 613: ! 614: eval(rdform); /* otherwise eval it */ ! 615: ! 616: if(uctolc) ouctolc = TRUE; /* if changed by eval, remember */ ! 617: curibase = ibase->a.clb; ! 618: ibase->a.clb = inewint(10); ! 619: Vreadtable->a.clb = strtab; ! 620: } ! 621: }; ! 622: ! 623: fclose(p); /* give up file descriptor */ ! 624: ! 625: POP; /* restore state of gcdisable variable */ ! 626: ! 627: Vreadtable->a.clb = currtab; ! 628: chkrtab(currtab); ! 629: ibase->a.clb = curibase; ! 630: ! 631: fclose(filp); ! 632: if(domap) fclose(map); ! 633: Freexs(); ! 634: return(tatom); ! 635: } ! 636: ! 637: #if m_68k ! 638: /* function used in qsort for 68k version only */ ! 639: compar(arg1,arg2) ! 640: int *arg1,*arg2; ! 641: { ! 642: if(*arg1 < *arg2) return (-1); ! 643: else if (*arg1 == *arg2) return (0); ! 644: else return(1); ! 645: } ! 646: #endif ! 647: ! 648: /* gettran :: allocate a segment of transfer table of the given size */ ! 649: ! 650: struct trent * ! 651: gettran(size) ! 652: { ! 653: struct trtab *trp; ! 654: struct trent *retv; ! 655: int ousehole; ! 656: extern int usehole; ! 657: ! 658: if(size > TRENTS) ! 659: error("transfer table too large",FALSE); ! 660: ! 661: if(size > trleft) ! 662: { ! 663: /* allocate a new transfer table */ ! 664: /* must not allocate in the hole or we cant modify it */ ! 665: ousehole = usehole; /* remember old value */ ! 666: usehole = FALSE; ! 667: trp = (struct trtab *)csegment(OTHER,sizeof(struct trtab),FALSE); ! 668: usehole = ousehole; ! 669: ! 670: trp->sentinal = 0; /* make sure the sentinal is 0 */ ! 671: trp->nxtt = trhead; /* link at beginning of table */ ! 672: trhead = trp; ! 673: trcur = &(trp->trentrs[0]); /* begin allocating here */ ! 674: trleft = TRENTS; ! 675: } ! 676: ! 677: trleft = trleft - size; ! 678: retv = trcur; ! 679: trcur = trcur + size; ! 680: return(retv); ! 681: } ! 682: ! 683: /* clrtt :: clear transfer tables, or link them all up; ! 684: * this has two totally opposite functions: ! 685: * 1) all transfer tables are reset so that all function calls will go ! 686: * through qlinker ! 687: * 2) as many transfer tables are set up to point to bcd functions ! 688: * as possible ! 689: */ ! 690: clrtt(flag) ! 691: { ! 692: /* flag = 0 :: set to qlinker ! 693: * flag = 1 :: set to function bcd binding if possible ! 694: */ ! 695: register struct trtab *temptt; ! 696: register struct trent *tement; ! 697: register lispval fnb; ! 698: ! 699: for (temptt = trhead; temptt != 0 ; temptt = temptt->nxtt) ! 700: { ! 701: for(tement = &temptt->trentrs[0] ; tement->fcn != 0 ; tement++) ! 702: { if(flag == 0 || TYPE(fnb=tement->name->a.fnbnd) != BCD ! 703: || TYPE(fnb->bcd.discipline) == STRNG) ! 704: tement->fcn = qlinker; ! 705: else tement->fcn = fnb->bcd.start; ! 706: } ! 707: } ! 708: } ! 709: ! 710: /* chktt - builds a list of transfer table entries which don't yet have ! 711: a function associated with them, i.e if this transfer table entry ! 712: were used, an undefined function error would result ! 713: */ ! 714: lispval ! 715: chktt() ! 716: { ! 717: register struct trtab *temptt; ! 718: register struct trent *tement; ! 719: register lispval retlst,curv; ! 720: Savestack(4); ! 721: ! 722: retlst = newdot(); /* build list of undef functions */ ! 723: protect(retlst); ! 724: for (temptt = trhead; temptt != 0 ; temptt = temptt->nxtt) ! 725: { ! 726: for(tement = &temptt->trentrs[0] ; tement->fcn != 0 ; tement++) ! 727: { ! 728: if(tement->name->a.fnbnd == nil) ! 729: { ! 730: curv= newdot(); ! 731: curv->d.car = tement->name; ! 732: curv->d.cdr = retlst->d.cdr; ! 733: retlst->d.cdr = curv; ! 734: } ! 735: } ! 736: } ! 737: Restorestack(); ! 738: return(retlst->d.cdr); ! 739: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.