4.3BSD - /usr/src/ucb/lisp/franz/fasl.c

   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: }

Defined functions

Defined variables

Defined struct's

Defined macros