![[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.