Return to fasl.c CVS log

Up to [CSRG BSD Unix] / 43BSDReno / pgrm / lisp / franz

Annotation of 43BSDReno/pgrm/lisp/franz/fasl.c, revision 1.1

1.1     ! root        1: #ifndef lint
        !             2: static char *rcsid =
        !             3:    "$Header: fasl.c,v 1.11 87/12/14 16:49:06 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: #define roundup(x) (char *)(((int)x + 3) & ~3) /* round to longword boundary */
        !           145: 
        !           146: struct nlist syml;             /* to read a.out symb tab */
        !           147: extern int *bind_lists;                /* gc binding lists       */
        !           148: 
        !           149: /* bindage structure:
        !           150:  *  the bindage structure describes the linkages of functions and name,
        !           151:  *  and tells which functions should be evaluated.  It is mainly used 
        !           152:  *  for the non-fasl'ing of files, we only use one of the fields in fasl
        !           153:  */
        !           154: struct bindage
        !           155: {
        !           156:      int     b_type;                   /* type code, as described below */
        !           157: };
        !           158: 
        !           159: /* the possible values of b_type
        !           160:  * -1 - this is the end of the bindage entries
        !           161:  * 0  - this is a lambda function
        !           162:  * 1  - this is a nlambda function
        !           163:  * 2  - this is a macro function
        !           164:  * 99 - evaluate the string
        !           165:  *
        !           166:  */
        !           167: 
        !           168: 
        !           169: extern struct trtab *trhead;   /* head of list of transfer tables          */
        !           170: extern struct trent *trcur;    /* next entry to allocate                   */
        !           171: extern int trleft;             /* # of entries left in this transfer table */
        !           172: 
        !           173: struct trent *gettran();       /* function to allocate entries */
        !           174: 
        !           175: /* maximum number of functions */
        !           176: #define MAXFNS 2000
        !           177: 
        !           178: lispval Lfasl()
        !           179: {
        !           180:        extern int holend,usehole;
        !           181:        extern int uctolc;
        !           182:        extern char *curhbeg;
        !           183:        struct argent *svnp;
        !           184:        struct exec exblk;      /* stores a.out header */
        !           185:        FILE *filp, *p, *map, *fstopen();       /* file pointer */
        !           186:        int domap,note_redef;
        !           187:        lispval handy,debugmode;
        !           188:        struct relocation_info reloc;
        !           189:        struct trent *tranloc;
        !           190:        int trsize;
        !           191:        int i,j,times, *iptr;
        !           192:        int  funloc[MAXFNS];    /* addresses of functions rel to txt org */
        !           193:        int funcnt = 0;
        !           194: 
        !           195:        /* symbols whose values are taken from symbol table of .o file */
        !           196:        int bind_org = 0;               /* beginning of bind table */
        !           197:        int lit_org = 0;        /* beginning of literal table */
        !           198:        int lit_end;            /* end of literal table  */
        !           199:        int trans_size = 0;     /* size in entries of transfer table */
        !           200:        int linker_size;        /* size in bytes   of linker table 
        !           201:                                        (not counting gc ptr) */
        !           202: 
        !           203:        /* symbols which hold the locations of the segments in core and 
        !           204:        * in the file
        !           205:        */
        !           206:        char *code_core_org,    /* beginning of code segment */
        !           207:             *lc_org,  /* beginning of linker segment */
        !           208:             *lc_end,  /* last word in linker segment */
        !           209:             *literal_core_org, /* beginning of literal table   */
        !           210:             *binder_core_org,  /* beginning of binder table   */
        !           211:             *string_core_org;
        !           212: 
        !           213:        int /*string_file_org,  /* location of string table in file */
        !           214:            string_size,        /* number of chars in string table */
        !           215:            segsiz;             /* size of permanent incore segment */
        !           216: 
        !           217:        char *symbol_name;
        !           218:        struct bindage *curbind;
        !           219:        lispval rdform, *linktab;
        !           220:        int ouctolc;
        !           221:        int debug = 0;
        !           222:        lispval currtab,curibase;
        !           223:        char ch,*filnm,*nfilnm;
        !           224:        char tempfilbf[100];
        !           225:        char *strcat();
        !           226:        long lseek();
        !           227:        Keepxs();
        !           228:        
        !           229: 
        !           230:        switch(np-lbot) {
        !           231:        case 0:
        !           232:                protect(nil);
        !           233:        case 1:
        !           234:                protect(nil);
        !           235:        case 2:
        !           236:                protect(nil);
        !           237:        case 3:
        !           238:                break;
        !           239:        default:
        !           240:                argerr("fasl");
        !           241:        }
        !           242:        filnm = (char *) verify(lbot->val,"fasl: non atom arg");
        !           243: 
        !           244: 
        !           245:        domap = FALSE;
        !           246:        /* debugging */
        !           247:        debugmode = Istsrch(matom("debugging"))->d.cdr->d.cdr->d.cdr;
        !           248:        if (debugmode != nil) debug = 1;
        !           249:         /* end debugging */
        !           250: 
        !           251: 
        !           252:        /* insure that the given file name ends in .o
        !           253:           if it doesnt, copy to a new buffer and add a .o
        !           254:           but Allow non .o file names (5mar80 jkf)
        !           255:        */
        !           256:        tempfilbf[0] = '\0';
        !           257:        nfilnm = filnm;         /* same file name for now */
        !           258:        if( (i = strlen(filnm)) < 2 ||
        !           259:             strcmp(filnm+i-2,".o") != 0)
        !           260:        {
        !           261:                strncat(tempfilbf,filnm,96);
        !           262:                strcat(tempfilbf,".o");
        !           263:                nfilnm = tempfilbf;
        !           264:        }
        !           265: 
        !           266:        if ( (filp = fopen(nfilnm,"r")) == NULL)
        !           267:           if ((filnm == nfilnm) || ((filp = fopen(filnm,"r")) == NULL))
        !           268:               errorh1(Vermisc,"Can't open file",nil,FALSE,9797,lbot->val);
        !           269: 
        !           270:        if ((handy = (lbot+1)->val) != nil )
        !           271:        {
        !           272:            if((TYPE(handy) != ATOM )   ||
        !           273:               (map = fopen(handy->a.pname,
        !           274:                            (Istsrch(matom("appendmap"))->d.cdr->d.cdr->d.cdr == nil 
        !           275:                                    ? "w" : "a")))  == NULL)
        !           276:                error("fasl: can't open map file",FALSE);
        !           277:            else 
        !           278:            {   domap = TRUE;
        !           279:                /* fprintf(map,"Map of file %s\n",lbot->val->a.pname); */
        !           280:            }
        !           281:        }
        !           282: 
        !           283:        /* set the note redefinition flag */
        !           284:        if((lbot+2)->val != nil) note_redef = TRUE;
        !           285:        else    note_redef = FALSE;
        !           286: 
        !           287:        /* if nil don't print fasl message */
        !           288:        if ( Vldprt->a.clb != nil ) {
        !           289:                printf("[fasl %s]",filnm);
        !           290:                fflush(stdout);
        !           291:        }
        !           292:        svnp = np;
        !           293: 
        !           294: 
        !           295: 
        !           296:        /* clear the ords in the symbol table */
        !           297:        for(i=0 ; i < SYMMAX ; i++) Symbtb[i].ord = -1;
        !           298: 
        !           299:        if( read(fileno(filp),(char *)&exblk,sizeof(struct exec)) 
        !           300:                != sizeof(struct exec))
        !           301:          error("fasl: header read failed",FALSE);
        !           302:          
        !           303:        /* check that the magic number is valid */
        !           304: 
        !           305:        if(exblk.a_magic != 0407)
        !           306:           errorh1(Vermisc,"fasl: file is not a lisp object file (bad magic number): ",
        !           307:                nil,FALSE,0,lbot->val);
        !           308: 
        !           309:        /* read in string table */
        !           310:        lseek(fileno(filp),(long)(/*string_file_org =*/N_STROFF(exblk)),0);
        !           311:        if( read(fileno(filp), (char *)&string_size , 4) != 4)
        !           312:          error("fasl: string table read error, probably old fasl format", FALSE);
        !           313:        
        !           314:        lbot = np;              /* set up base for later calls */
        !           315:         /* allocate space for string table on the stack */
        !           316:        string_core_org = alloca(string_size - 4);
        !           317: 
        !           318:        if( read(fileno(filp), string_core_org , string_size - 4)
        !           319:                != string_size -4) error("fasl: string table read error ",FALSE);
        !           320:        /* read in symbol table and set the ordinal values */
        !           321: 
        !           322:        fseek(filp,(long) (N_SYMOFF(exblk)),0);
        !           323: 
        !           324:        times = exblk.a_syms/sizeof(struct nlist);
        !           325:        if(debug) printf(" %d symbols in symbol table\n",times);
        !           326: 
        !           327:        for(i=0; i < times ; i++)
        !           328:        {
        !           329:           if( fread((char *)&syml,sizeof(struct nlist),1,filp) != 1)
        !           330:               error("fasl: Symb tab read error",FALSE);
        !           331:        
        !           332:           symbol_name = syml.n_un.n_strx - 4 + string_core_org;
        !           333:           if(debug) printf("symbol %s\n read\n",symbol_name);
        !           334:           if (syml.n_type == N_EXT) 
        !           335:           { 
        !           336:              for(j=0; j< SYMMAX; j++)
        !           337:              {
        !           338:                 if((Symbtb[j].ord < 0) 
        !           339:                          && strcmp(Symbtb[j].fnam,symbol_name)==0)
        !           340:                 {    Symbtb[j].ord = i;
        !           341:                      if(debug)printf("symbol %s ord is %d\n",symbol_name,i);
        !           342:                      break;
        !           343:                 };
        !           344: 
        !           345:              };
        !           346: 
        !           347:              if( j>=SYMMAX )  printf("Unknown symbol %s\n",symbol_name);
        !           348:           }
        !           349:           else if (((ch = symbol_name[0]) == 's')
        !           350:                     || (ch == 'L')
        !           351:                     || (ch == '.') )  ;                /* skip this */
        !           352:           else if (symbol_name[0] == 'F')
        !           353:           {
        !           354:               if(funcnt >= MAXFNS)
        !           355:                        error("fasl: too many function in file",FALSE);
        !           356:               funloc[funcnt++] = syml.n_value;         /* seeing function */
        !           357:           }
        !           358:           else if (!bind_org && (strcmp(symbol_name, "bind_org") == 0))
        !           359:             bind_org = syml.n_value;
        !           360:           else if (strcmp(symbol_name, "lit_org") == 0)
        !           361:             lit_org = syml.n_value;
        !           362:           else if (strcmp(symbol_name, "lit_end") == 0)
        !           363:             lit_end = syml.n_value;
        !           364:           else if (strcmp(symbol_name, "trans_size") == 0)
        !           365:             trans_size = syml.n_value;
        !           366:           else if (strcmp(symbol_name, "linker_size") == 0)
        !           367:             linker_size = syml.n_value;
        !           368:        }
        !           369: 
        !           370: #if m_68k
        !           371:        /* 68k only, on the vax the symbols appear in the correct order */
        !           372:        { int compar();
        !           373:          qsort(funloc,funcnt,sizeof(int),compar);
        !           374:        }
        !           375: #endif
        !           376: 
        !           377:        if (debug)
        !           378:          printf("lit_org %x,  lit_end %x, bind_org %x, linker_size %x\n",
        !           379:                lit_org, lit_end, bind_org, linker_size);
        !           380:        /* check to make sure we are working with the right format */
        !           381:        if((lit_org == 0) || (lit_end == 0))
        !           382:           errorh1(Vermisc,"File not in new fasl format",nil,FALSE,0,lbot->val);
        !           383: 
        !           384:         /*----------------*/
        !           385: 
        !           386:        /* read in text segment  up to beginning of binder table */
        !           387: 
        !           388:        segsiz = bind_org + 4*linker_size + 8 + 3; /* size is core segment size
        !           389:                                                 * plus linker table size
        !           390:                                                 * plus 2 for gc list
        !           391:                                                 * plus 3 to round up to word
        !           392:                                                 */
        !           393: 
        !           394:        lseek(fileno(filp),(long)sizeof(struct exec),0);
        !           395:        code_core_org = (char *) csegment(OTHER,segsiz,TRUE);
        !           396:        if(read(fileno(filp),code_core_org,bind_org) != bind_org)
        !           397:            error("Read error in text ",FALSE);
        !           398: 
        !           399:   if(debug) {
        !           400:        printf("Read %d bytes of text into 0x%x\n",bind_org,code_core_org);
        !           401:         printf(" incore segment size: %d (0x%x)\n",segsiz,segsiz);
        !           402:         }
        !           403:         
        !           404:        /* linker table is 2 entries (8 bytes) larger than the number of
        !           405:         * entries given by linker_size .  There must be a gc word at
        !           406:         * the beginning and a -1 at the end
        !           407:         */
        !           408:        lc_org = roundup(code_core_org + bind_org);
        !           409:        lc_end = lc_org + 4*linker_size + 4; 
        !           410:                                        /* address of gc sentinal last */
        !           411: 
        !           412:        if(debug)printf("lin_cor_org: %x, link_cor_end %x\n",
        !           413:                                      lc_org,
        !           414:                                      lc_end);
        !           415:        Symbtb[1].floc = (int) (lc_org + 4);
        !           416: 
        !           417:        /* set the linker table to all -1's so we can put in the gc table */
        !           418:        for( iptr = (int *)(lc_org + 4 ); 
        !           419:             iptr <= (int *)(lc_end); 
        !           420:             iptr++)
        !           421:          *iptr = -1;
        !           422: 
        !           423: 
        !           424:        /* link our table into the gc tables */
        !           425:        /* only do so if we will not purcopy these tables */
        !           426:        if(Vpurcopylits->a.clb == nil)
        !           427:        {
        !           428:            *(int *)lc_org = (int)bind_lists;   /* point to current */
        !           429:            bind_lists = (int *) (lc_org + 4); /* point to first
        !           430:                                                                item */
        !           431:        }
        !           432: 
        !           433:        /* read the binder table and literals onto the stack */
        !           434: 
        !           435:        binder_core_org =  alloca(lit_end - bind_org);
        !           436:        read(fileno(filp),binder_core_org,lit_end-bind_org);
        !           437: 
        !           438:        literal_core_org = binder_core_org + lit_org - bind_org;
        !           439: 
        !           440:        /* check if there is a transfer table required for this
        !           441:         * file, and if so allocate one of the necessary size
        !           442:         */
        !           443: 
        !           444:        if(trans_size > 0)
        !           445:        {
        !           446:            tranloc = gettran(trans_size);
        !           447:            Symbtb[0].floc = (int) tranloc;
        !           448:        }
        !           449: 
        !           450:        /* now relocate the necessary symbols in the text segment */
        !           451: 
        !           452:        fseek(filp,(long)(sizeof(struct exec) + exblk.a_text + exblk.a_data),0);
        !           453:        times = (exblk.a_trsize)/sizeof(struct relocation_info);
        !           454:                
        !           455:        /* the only symbols we will relocate are references to  
        !           456:                external symbols.  They are recognized by 
        !           457:                extern and pcrel set.
        !           458:         */
        !           459: 
        !           460:         for( i=1; i<=times ; i++)
        !           461:            {
        !           462:                if( fread((char *)&reloc,sizeof(struct relocation_info),1,filp) != 1)
        !           463:                   error("Bad text reloc read",FALSE);
        !           464:             if(reloc.r_extern)
        !           465:             {
        !           466:                for(j=0; j < SYMMAX; j++)
        !           467:                {
        !           468: 
        !           469:                   if(Symbtb[j].ord == reloc.r_symbolnum)  /* look for this sym */
        !           470:                    {
        !           471: #define offset(p) (((p).r_pcrel) ? ((int) code_core_org): 0)
        !           472:                      if(debug) printf("Relocating %d (ord %d) at %x\n",
        !           473:                                         j, Symbtb[j].ord, reloc.r_address);
        !           474:                        if (Symbtb[j].floc == (int)  mcnts) {
        !           475:                            add_offset((int *)(code_core_org + reloc.r_address),
        !           476:                                        mcntp - offset(reloc)); 
        !           477:                            if(doprof){
        !           478:                             if (mcntp == (int) &mcnts[NMCOUNT-2])
        !           479:                                printf("Ran out of counters; increas NMCOUNT in fasl.c\n");
        !           480:                             if (mcntp < (int) &mcnts[NMCOUNT-1])
        !           481:                                mcntp += 4;
        !           482:                            }
        !           483:                        } else
        !           484:                            add_offset((int *)(code_core_org + reloc.r_address),
        !           485:                                        Symbtb[j].floc - offset(reloc)); 
        !           486:                          
        !           487:                        break;
        !           488:                      
        !           489:                      }
        !           490:                 };
        !           491:                 if( j >= SYMMAX) if(debug) printf("Couldnt find ord # %d\n",
        !           492:                                                   reloc.r_symbolnum);
        !           493:             }
        !           494: 
        !           495:            }
        !           496:        
        !           497:        if ( Vldprt->a.clb != nil ) {
        !           498:                putchar('\n');
        !           499:                fflush(stdout);
        !           500:        }
        !           501: 
        !           502:        /* set up a fake port so we can read from core */
        !           503:        /* first find a free port                      */
        !           504: 
        !           505:        p = fstopen((char *) literal_core_org, lit_end - lit_org, "r");
        !           506: 
        !           507:        if(debug)printf("lit_org %d, charstrt  %d\n",lit_org, p->_base);
        !           508:        /* the first forms we wish to read are those literals in the 
        !           509:         * literal table, that is those forms referenced by an offset
        !           510:         * from r8 in  compiled code
        !           511:         */
        !           512: 
        !           513:        /* to read in the forms correctly, we must set up the read table
        !           514:         */
        !           515:        currtab = Vreadtable->a.clb;
        !           516:        Vreadtable->a.clb = strtab;             /* standard read table */
        !           517:        curibase = ibase->a.clb;
        !           518:        ibase->a.clb = inewint(10);             /* read in decimal */
        !           519:        ouctolc = uctolc;       /* remember value of uctolc flag */
        !           520: 
        !           521:        PUSHDOWN(gcdis,tatom);                  /* turn off gc */
        !           522: 
        !           523:        i = 1;  
        !           524:        linktab = (lispval *)(lc_org +4);
        !           525:        while (linktab < (lispval *)lc_end)
        !           526:        {
        !           527:           np = svnp;
        !           528:           protect(P(p));
        !           529:           uctolc = FALSE;
        !           530:           handy = (lispval)Lread();
        !           531:           if (Vpurcopylits->a.clb != nil) {
        !           532:                handy = Ipurcopy(handy);
        !           533:           }
        !           534:           uctolc = ouctolc;
        !           535:           getc(p);                     /* eat trailing blank */
        !           536:           if(debugmode != nil)
        !           537:           {   printf("form %d read: ",i++);
        !           538:               printr(handy,stdout); 
        !           539:               putchar('\n');
        !           540:               fflush(stdout);
        !           541:           }
        !           542:           *linktab++ = handy;
        !           543:        }
        !           544: 
        !           545:        /* process the transfer table if one is used            */
        !           546:        trsize = trans_size;
        !           547:        while(trsize--)
        !           548:        {
        !           549:            np = svnp;
        !           550:            protect(P(p));
        !           551:            uctolc = FALSE;
        !           552:            handy = Lread();        /* get function name */
        !           553:            uctolc = ouctolc;
        !           554:            getc(p);
        !           555:            tranloc->name = handy;
        !           556:            tranloc->fcn = qlinker;     /* initially go to qlinker */
        !           557:            tranloc++;
        !           558:        }
        !           559: 
        !           560: 
        !           561: 
        !           562:        /* now process the binder table, which contains pointers to 
        !           563:           functions to link in and forms to evaluate.
        !           564:        */
        !           565:        funcnt = 0;
        !           566: 
        !           567:        curbind = (struct bindage *) binder_core_org;
        !           568:        for( ; curbind->b_type != -1 ; curbind++) 
        !           569:        {
        !           570:            np = svnp;
        !           571:            protect(P(p));
        !           572:            uctolc = FALSE;             /* inhibit uctolc conversion */
        !           573:            rdform = Lread();
        !           574:            /* debugging */
        !           575:            if(debugmode != nil) { printf("link form read: ");
        !           576:                        printr(rdform,stdout);
        !           577:                        printf("  ,type: %d\n",
        !           578:                                 curbind->b_type);
        !           579:                        fflush(stdout);
        !           580:                      }
        !           581:            /* end debugging */
        !           582:            uctolc = ouctolc;           /* restore previous state */
        !           583:            getc(p);                    /* eat trailing null */
        !           584:            protect(rdform);
        !           585:            if(curbind->b_type <= 2)    /* if function type */
        !           586:            { 
        !           587:               handy = newfunct();
        !           588:               if (note_redef && (rdform->a.fnbnd != nil))
        !           589:               {
        !           590:                   printr(rdform,stdout);
        !           591:                   printf(" redefined\n");
        !           592:               }
        !           593:               rdform->a.fnbnd = handy;
        !           594:               handy->bcd.start = (lispval (*)())(code_core_org + funloc[funcnt++]);
        !           595:               handy->bcd.discipline =
        !           596:                  (curbind->b_type == 0 ? lambda :
        !           597:                       curbind->b_type == 1 ? nlambda :
        !           598:                          macro);
        !           599:               if(domap) {
        !           600:                   fprintf(map,"%s\n%x\n",rdform->a.pname,handy->bcd.start);
        !           601:               }
        !           602:            }
        !           603:            else {
        !           604:                Vreadtable->a.clb = currtab;
        !           605:                ibase->a.clb = curibase;
        !           606: 
        !           607:                /* debugging */
        !           608:                if(debugmode != nil) {
        !           609:                        printf("Eval: ");
        !           610:                        printr(rdform,stdout);
        !           611:                        printf("\n");
        !           612:                        fflush(stdout);
        !           613:                };
        !           614:                /* end debugging */
        !           615: 
        !           616:                eval(rdform);           /* otherwise eval it */
        !           617: 
        !           618:                if(uctolc) ouctolc = TRUE; /* if changed by eval, remember */
        !           619:                curibase = ibase->a.clb;
        !           620:                ibase->a.clb = inewint(10);
        !           621:                Vreadtable->a.clb = strtab;
        !           622:           }
        !           623:        };
        !           624:              
        !           625:        fclose(p);      /* give up file descriptor */
        !           626: 
        !           627:        POP;                    /* restore state of gcdisable variable */
        !           628: 
        !           629:        Vreadtable->a.clb = currtab;
        !           630:        chkrtab(currtab);
        !           631:        ibase->a.clb = curibase;
        !           632: 
        !           633:        fclose(filp);
        !           634:        if(domap) fclose(map);
        !           635:        Freexs();
        !           636:        return(tatom);
        !           637: }
        !           638: 
        !           639: #if m_68k
        !           640: /* function used in qsort for 68k version only */
        !           641: compar(arg1,arg2)
        !           642: int *arg1,*arg2;
        !           643: {
        !           644:        if(*arg1 < *arg2) return (-1);
        !           645:         else if (*arg1 == *arg2) return (0);
        !           646:        else return(1);
        !           647: }
        !           648: #endif
        !           649: 
        !           650: /* gettran :: allocate a segment of transfer table of the given size   */
        !           651: 
        !           652: struct trent *
        !           653: gettran(size)
        !           654: {
        !           655:        struct trtab *trp;
        !           656:        struct trent *retv;
        !           657:        int ousehole;
        !           658:        extern int usehole;
        !           659: 
        !           660:        if(size > TRENTS)
        !           661:          error("transfer table too large",FALSE);
        !           662:        
        !           663:        if(size > trleft)
        !           664:        {
        !           665:            /* allocate a new transfer table */
        !           666:            /* must not allocate in the hole or we cant modify it */
        !           667:            ousehole = usehole; /* remember old value */
        !           668:            usehole = FALSE;
        !           669:            trp = (struct trtab *)csegment(OTHER,sizeof(struct trtab),FALSE);
        !           670:            usehole = ousehole;
        !           671: 
        !           672:            trp->sentinal = 0;          /* make sure the sentinal is 0 */
        !           673:            trp->nxtt = trhead; /* link at beginning of table  */
        !           674:            trhead = trp;
        !           675:            trcur = &(trp->trentrs[0]); /* begin allocating here        */
        !           676:            trleft = TRENTS;
        !           677:        }
        !           678: 
        !           679:        trleft = trleft - size;
        !           680:        retv = trcur;
        !           681:        trcur = trcur + size;
        !           682:        return(retv);
        !           683: }
        !           684: 
        !           685: /* clrtt :: clear transfer tables, or link them all up;
        !           686:  * this has two totally opposite functions:
        !           687:  * 1) all transfer tables are reset so that all function calls will go
        !           688:  * through qlinker
        !           689:  * 2) as many transfer tables are set up to point to bcd functions
        !           690:  *    as possible
        !           691:  */
        !           692: clrtt(flag)
        !           693: {
        !           694:        /*  flag = 0 :: set to qlinker
        !           695:         *  flag = 1 :: set to function bcd binding if possible
        !           696:         */
        !           697:        register struct trtab *temptt;
        !           698:        register struct trent *tement;
        !           699:        register lispval fnb;
        !           700: 
        !           701:        for (temptt = trhead; temptt != 0 ; temptt = temptt->nxtt)
        !           702:        { 
        !           703:            for(tement = &temptt->trentrs[0] ; tement->fcn != 0 ; tement++)
        !           704:            {   if(flag == 0 || TYPE(fnb=tement->name->a.fnbnd) != BCD
        !           705:                             || TYPE(fnb->bcd.discipline) == STRNG)
        !           706:                tement->fcn =  qlinker;
        !           707:                else tement->fcn = fnb->bcd.start;
        !           708:            }
        !           709:        }
        !           710: }
        !           711: 
        !           712: /* chktt - builds a list of transfer table entries which don't yet have
        !           713:   a function associated with them, i.e if this transfer table entry
        !           714:   were used, an undefined function error would result
        !           715:  */
        !           716: lispval 
        !           717: chktt()
        !           718: {
        !           719:        register struct trtab *temptt;
        !           720:        register struct trent *tement;
        !           721:        register lispval retlst,curv;
        !           722:        Savestack(4);
        !           723: 
        !           724:        retlst = newdot();              /* build list of undef functions */
        !           725:        protect(retlst);
        !           726:        for (temptt = trhead; temptt != 0 ; temptt = temptt->nxtt)
        !           727:        { 
        !           728:             for(tement = &temptt->trentrs[0] ; tement->fcn != 0 ; tement++)
        !           729:            {
        !           730:               if(tement->name->a.fnbnd == nil)
        !           731:               {
        !           732:                  curv= newdot();
        !           733:                  curv->d.car = tement->name;
        !           734:                  curv->d.cdr = retlst->d.cdr;
        !           735:                  retlst->d.cdr = curv;
        !           736:                }
        !           737:             }
        !           738:         }
        !           739:         Restorestack();
        !           740:         return(retlst->d.cdr);
        !           741: }
        !           742: 
        !           743: /* since the tahoe machine is picky about word/longword alignment
        !           744: ** when it is doing data access but not when doing instruction fetches,
        !           745: ** we have to add the relocation offset in a slightly different manner.
        !           746: */
        !           747: #ifdef tahoe
        !           748: add_offset(addr, relocoffset)
        !           749: register int *addr;
        !           750: {register int r11, r10, r9, r8;
        !           751:  asm(" cvtbl   (r12), r0");
        !           752:  asm(" cvtbl   8(fp), r1");
        !           753:  asm(" cvtbl   1(r12), r8");
        !           754:  asm(" cvtbl   9(fp), r9");
        !           755:  asm(" cvtbl   2(r12), r10");
        !           756:  asm(" cvtbl   10(fp), r11");
        !           757:  asm(" addb2   11(fp), 3(r12)");       /* add least sig. bytes */
        !           758:  asm(" adwc    r11, r10");
        !           759:  asm(" adwc    r9, r8");
        !           760:  asm(" adwc    r1, r0");
        !           761:  asm(" cvtlb   r10, 2(r12)");
        !           762:  asm(" cvtlb   r8, 1(r12)");
        !           763:  asm(" cvtlb   r0,(r12)");
        !           764: }
        !           765: #else
        !           766: add_offset(addr, relocoffset)
        !           767: register int *addr;
        !           768: {
        !           769:  *addr += relocoffset;
        !           770: }
        !           771: #endif

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.