![[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] / 43BSDReno / pgrm / lisp / franz|
Return to fasl.c CVS log | Up to [CSRG BSD Unix] / 43BSDReno / pgrm / lisp / franz |
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.