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