![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to ffasl.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 ffasl.c CVS log | Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / franz |
1.1 root 1: #ifndef lint
2: static char *rcsid =
3: "$Header: ffasl.c,v 1.9 83/09/12 14:17:21 sklower Exp $";
4: #endif
5:
6: /* -[Mon Mar 21 19:37:21 1983 by jkf]-
7: * ffasl.c $Locker: $
8: * dynamically load C code
9: *
10: * (c) copyright 1982, Regents of the University of California
11: */
12:
13:
14: #include "global.h"
15: #include <sys/types.h>
16: #include <sys/stat.h>
17: #include <aout.h>
18: #define round(x,s) ((((x)-1) & ~((s)-1)) + (s))
19:
20: char *stabf = 0, *strcpy(), *sprintf(), *Ilibdir();
21: extern int fvirgin;
22: static seed=0, mypid = 0;
23: static char myname[100];
24: lispval verify();
25:
26: /* dispget - get discipline of function
27: * this is used to handle the tricky defaulting of the discipline
28: * field of such functions as cfasl and getaddress.
29: * dispget is given the value supplied by the caller,
30: * the error message to print if something goes wrong,
31: * the default to use if nil was supplied.
32: * the discipline can be an atom or string. If an atom it is supplied
33: * it must be lambda, nlambda or macro. Otherwise the atoms pname
34: * is used.
35: */
36:
37: lispval
38: dispget(given,messg,defult)
39: lispval given,defult;
40: char *messg;
41: {
42: int typ;
43:
44: while(TRUE)
45: {
46: if(given == nil)
47: return(defult);
48: if((typ=TYPE(given)) == ATOM)
49: { if(given == lambda ||
50: given == nlambda ||
51: given == macro) return(given);
52: else return((lispval) given->a.pname);
53: } else if(typ == STRNG) return(given);
54:
55: given = errorh1(Vermisc,messg,nil,TRUE,0,given);
56: }
57: }
58:
59: lispval
60: Lcfasl(){
61: register struct argent *mlbot = lbot;
62: register lispval work;
63: register int fildes, totsize;
64: int readsize;
65: lispval csegment();
66: char *sbrk(), *currend, *tfile, cbuf[6000], *mytemp(), *gstab();
67: char ostabf[128];
68: struct exec header;
69: char *largs;
70: Savestack(4);
71:
72: switch(np-lbot) {
73: case 3: protect(nil); /* no discipline given */
74: case 4: protect(nil); /* no library given */
75: }
76: chkarg(5,"cfasl");
77: mlbot[0].val = verify(mlbot[0].val,"Incorrect .o file specification");
78: mlbot[1].val = verify(mlbot[1].val,"Incorrect entry specification for cfasl");
79: mlbot[3].val = dispget(mlbot[3].val,"Incorrect discipline specification for cfasl",(lispval)Vsubrou->a.pname);
80: while(TYPE(mlbot[2].val)!= ATOM)
81: mlbot[2].val = errorh1(Vermisc,"Bad associated atom name for fasl",
82: nil,TRUE,0,mlbot[2].val);
83: work = mlbot[4].val;
84: if(work==nil)
85: largs = 0;
86: else
87: largs = (char *) verify(work,"Bad loader flags");
88:
89: /*
90: * Invoke loader.
91: */
92: strcpy(ostabf,gstab());
93: currend = sbrk(0);
94: #if (!os_vms) | EUNICE_UNIX_OBJECT_FILE_CFASL
95: /*** UNIX cfasl code ***/
96: tfile = mytemp();
97: sprintf(cbuf,
98: "%s/nld -N -x -A %s -T %x %s -e %s -o %s %s -lc",
99: Ilibdir(),
100: ostabf,
101: currend,
102: mlbot[0].val,
103: mlbot[1].val,
104: tfile,
105: largs);
106: /* if nil don't print cfasl/nld message */
107: if ( Vldprt->a.clb != nil ) {
108: printf(cbuf);
109: putchar('\n'); fflush(stdout);
110: }
111: if(system(cbuf)!=0) {
112: unlink(tfile);
113: ungstab();
114: fprintf(stderr,"Ld returns error status\n");
115: Restorestack();
116: return(nil);
117: }
118: if(fvirgin)
119: fvirgin = 0;
120: else
121: unlink(ostabf);
122: stabf = tfile;
123: if((fildes = open(tfile,0))<0) {
124: fprintf(stderr,"Couldn't open temporary file: %s\n",tfile);
125: Restorestack();
126: return(nil);
127: }
128: /*
129: * Read a.out header to find out how much room to
130: * allocate and attempt to do so.
131: */
132: if(read(fildes,(char *)&header,sizeof(header)) <= 0) {
133: close(fildes);
134: Restorestack();
135: return(nil);
136: }
137: readsize = round(header.a_text,4) + round(header.a_data,4);
138: totsize = readsize + header.a_bss;
139: totsize = round(totsize,512);
140: /*
141: * Fix up system indicators, typing info, etc.
142: */
143: currend = (char *)csegment(OTHER,totsize,FALSE);
144:
145: if(readsize!=read(fildes,currend,readsize))
146: {close(fildes);Restorestack(); return(nil);}
147: work = newfunct();
148: work->bcd.start = (lispval (*)())header.a_entry;
149: work->bcd.discipline = mlbot[3].val;
150: close(fildes);
151: Restorestack();
152: return(mlbot[2].val->a.fnbnd = work);
153: #else
154: /*** VMS cfasl code ***/
155: {
156: int pid = getpid() & 0xffff; /* Our process ID number */
157: char objfil[100]; /* Absolute object file name */
158: char symfil[100]; /* Old symbol table file */
159: char filename[100]; /* Random filename buffer */
160: int strlen(); /* String length function */
161: int cvt_unix_to_vms(); /* Convert UNIX to VMS filename */
162: lispval Lgetaddress(),matom();
163: struct stat stbuf;
164:
165: if (largs == 0) largs = " ";
166: sprintf(objfil,"tmp:cfasl%d.tmp",pid);
167: symfil[cvt_unix_to_vms(ostabf,symfil)] = 0;
168: sprintf(cbuf, /* Create link cmd. */
169: "$ link/exe=%s/nom/syst=%%X%x/sym=tmp:sym%d.new %s,%s%s",
170: objfil,
171: currend,
172: pid,
173: mlbot[0].val,
174: symfil,
175: largs);
176: printf( /* Echo link cmd. */
177: "$ link/exe=%s/nomap/system=%%X%x/symbol_table=tmp:sym%d.new %s,%s%s\n",
178: objfil,
179: currend,
180: pid,
181: mlbot[0].val,
182: symfil,
183: largs);
184: fflush(stdout);
185: vms_system(cbuf,0);
186:
187: if ((fildes = open(objfil,0)) < 0) /* Open abs file */
188: {Restorestack(); return(nil);}
189: fstat(fildes,&stbuf); /* Get its size */
190: readsize=stbuf.st_size;
191: currend = (char *)csegment(OTHER,readsize,FALSE);
192: readsize = read(fildes,currend,10000000);
193: close(fildes);
194: /*
195: * Delete the absolute object file
196: */
197: unlink(objfil);
198: /*
199: * Delete the old symbol table (if temporary)
200: */
201: unlink(sprintf(filename,"tmp:sym%d.stb",pid));
202: /*
203: * Rename the new symbol table so it is now the old symbol table
204: */
205: link(sprintf(symfil,"tmp:sym%d.new",pid),filename);
206: unlink(symfil);
207: sprintf(myname,"tmp:sym%d.stb",pid);
208: stabf = myname;
209: /*
210: * Return Lgetaddress(entry,function_name,discipline)
211: */
212: {
213: struct argent *oldlbot, *oldnp;
214: lispval result;
215:
216: oldlbot = lbot;
217: oldnp = np;
218: lbot = np;
219: np++->val = matom(mlbot[1].val);
220: np++->val = mlbot[2].val;
221: np++->val = matom(mlbot[3].val);
222: result = Lgetaddress();
223: lbot = oldlbot;
224: np = oldnp;
225: return(result);
226: }
227: }
228: #endif
229: }
230: #ifdef os_vms
231: #define M 4
232: #else
233: #define M 1
234: #endif
235: #define oktox(n) \
236: (0==stat(n,&stbuf)&&(stbuf.st_mode&S_IFMT)==S_IFREG&&0==access(n,M))
237: char *
238: gstab()
239: {
240: register char *cp, *cp2; char *getenv();
241: struct stat stbuf;
242: extern char **Xargv;
243:
244: if(stabf==0) {
245: cp = getenv("PATH");
246: if(cp==0)
247: cp=":/usr/ucb:/bin:/usr/bin";
248: if(*cp==':'||*Xargv[0]=='/') {
249: cp++;
250: if(oktox(Xargv[0])) {
251: strcpy(myname,Xargv[0]);
252: return(stabf = myname);
253: }
254: #ifdef os_vms
255: /*
256: * Try Xargv[0] with ".stb" concatenated
257: */
258: strcpy(myname,Xargv[0]);
259: strcat(myname,".stb");
260: if (oktox(myname)) return(stabf = myname);
261: /*
262: * Try Xargv[0] with ".exe" concatenated
263: */
264: strcpy(myname,Xargv[0]);
265: strcat(myname,".exe");
266: if (oktox(myname)) return(stabf = myname);
267: #endif
268: }
269: for(;*cp;) {
270:
271: /* copy over current directory
272: and then append argv[0] */
273:
274: for(cp2=myname;(*cp)!=0 && (*cp)!=':';)
275: *cp2++ = *cp++;
276: *cp2++ = '/';
277: strcpy(cp2,Xargv[0]);
278: if(*cp) cp++;
279: #ifndef os_vms
280: if(!oktox(myname)) continue;
281: #else
282: /*
283: * Also try ".stb" and ".exe" in VMS
284: */
285: if(!oktox(myname)) {
286: char *end_of_name;
287: end_of_name = cp2 + strlen(cp2);
288: strcat(cp2,".stb");
289: if(!oktox(myname)) {
290: /*
291: * Try ".exe"
292: */
293: *end_of_name = 0; /* Kill ".stb" */
294: strcat(cp2,".exe");
295: if (!oktox(myname)) continue;
296: }
297: }
298: #endif
299: return(stabf = myname);
300: }
301: /* one last try for dual systems */
302: strcpy(myname,Xargv[0]);
303: if(oktox(myname)) return(stabf = myname);
304: error("Could not find which file is being executed.",FALSE);
305: /* NOTREACHED */
306: } else return (stabf);
307: }
308: static char mybuff[40];
309: char *
310: mytemp()
311: {
312: /*if(mypid==0) mypid = (getpid() & 0xffff);
313: fails if you do a dumplisp after doing a
314: cfasl */
315: sprintf(mybuff,"/tmp/Li%d.%d",(getpid() & 0xffff),seed++);
316: return(mybuff);
317: }
318: ungstab()
319: {
320: seed--;
321: sprintf(mybuff,"/tmp/Li%d.%d",(getpid() & 0xffff),seed-1);
322: if(seed==0) {
323: stabf = 0;
324: fvirgin = 1;
325: }
326: }
327: lispval
328: verify(in,error)
329: register lispval in;
330: char *error;
331: {
332: for(EVER) {
333: switch(TYPE(in)) {
334: case STRNG:
335: return(in);
336: case ATOM:
337: return((lispval)in->a.pname);
338: }
339: in = errorh1(Vermisc,error,nil,TRUE,0,in);
340: }
341: }
342:
343:
344: /* extern int fvirgin; */
345: /* declared in ffasl.c tells if this is original
346: * lisp symbol table.
347: * if fvirgin is 1 then we must copy the symbol
348: * table, else we can overwrite it, since
349: * it is a temporary file which only
350: * one user could be using(was not created
351: * as an original lisp or by a (dumplisp)
352: * or a (savelisp)).
353: */
354:
355: /* copy a block of data from one file to another of size size */
356: copyblock(f1,f2,size)
357: FILE *f1, *f2;
358: long size;
359: {
360: char block[BUFSIZ];
361:
362: while ( size > BUFSIZ ) {
363: size -= BUFSIZ;
364: fread(block,BUFSIZ,1,f1);
365: fwrite(block,BUFSIZ,1,f2);
366: }
367: if (size > 0 ) {
368: fread(block,(int)size,1,f1);
369: fwrite(block,(int)size,1,f2);
370: }
371: }
372:
373: /* removeaddress --
374: *
375: * (removeaddress '|_entry1| '|_entry2| ...)
376: *
377: * removes the given entry points from the run time symbol table,
378: * so that later cfasl'd files can have these label names.
379: *
380: */
381:
382: lispval
383: Lrmadd(){
384: register struct argent *mlbot = lbot;
385: register struct nlist *q;
386: register int i;
387: int numberofargs, strsize;
388: char *gstab();
389: char ostabf[128];
390: char *nstabf,*mytemp();
391: char *strtbl,*alloca();
392: int i2, n, m, nargleft, savem;
393: FILE *f, *fa;
394: FILE *fnew;
395: off_t savesymadd,symadd; /* symbol address */
396: struct exec buf;
397: struct nlist nlbuf[BUFSIZ/sizeof (struct nlist)];
398: int maxlen;
399: int change;
400: Keepxs();
401:
402: numberofargs = (np - lbot);
403: nargleft = numberofargs;
404: maxlen = 0;
405: for ( i=0; i<numberofargs; i++,mlbot ++) {
406: mlbot->val = verify(mlbot->val,"Incorrect entry specification.");
407: n = strlen((char *)mlbot->val);
408: if (n > maxlen)
409: maxlen = n;
410: }
411: /*
412: * Must not disturb object file if it an original file which
413: * other users can execute(signified by the variable fvirgin).
414: * so the entire symbol table is copied to a new file.
415: */
416: if (fvirgin) {
417: strcpyn(ostabf,gstab(),128);
418: nstabf = mytemp();
419: /*
420: * copy over symbol table into a temporary file first
421: *
422: */
423: f = fopen(ostabf, "r");
424: fnew = fopen(nstabf, "w");
425: if (( f == NULL ) || (fnew == NULL)) {Freexs(); return( nil );}
426: /* read exec header on file */
427: #ifndef os_vms
428: fread((char *)&buf, sizeof buf, 1, f);
429: #else os_vms
430: /*
431: * Under VMS/EUNICE we have to try the 1st 512 byte
432: * block and the 2nd 512 byte block (there may be
433: * a VMS header in the 1st 512 bytes).
434: */
435: get_aout_header(fileno(f),&buf);
436: #endif os_vms
437:
438: /* Is this a legitimate a.out file? */
439: if (N_BADMAG(buf)) {
440: unlink(nstabf);
441: ungstab();
442: fclose(f);
443: fclose(fnew);
444: errorh1(Vermisc,"Removeaddress: Bad file",nil,FALSE,0,inewstr(ostabf));
445: {Freexs(); return(nil);}
446: }
447: /* set pointer on read file to symbol table */
448: /* must be done before the structure buf is reassigned
449: * so that it will be accurate for the read file
450: */
451: fseek(f,(long)N_SYMOFF(buf),0);
452: /* reset up exec header structure for new file */
453: buf.a_magic = OMAGIC;
454: buf.a_text = 0;
455: buf.a_data = 0;
456: buf.a_bss = 0;
457: buf.a_entry = 0;
458: buf.a_trsize = 0;
459: buf.a_drsize = 0;
460: fwrite((char *)&buf,
461: sizeof buf,1,fnew); /* write out exec header */
462: copyblock(f,fnew,(long)buf.a_syms); /* copy symbol table */
463: #if ! (os_unisoft | os_unix_ts)
464: fread((char *)&strsize,
465: sizeof (int),1,f); /* find size of string table */
466: fwrite((char *)&strsize,
467: sizeof (int),1,fnew); /* find size of string table */
468: strsize -= 4;
469: strtbl = alloca(strsize);
470: fread(strtbl,strsize,1,f); /* read and save string table*/
471: fwrite(strtbl,strsize,1,fnew); /* copy out string table */
472: #endif
473: fclose(f);fclose(fnew);
474: } else {
475: nstabf = gstab();
476: }
477:
478: /*
479: * now unset the external bits it the entry points specified.
480: */
481: f = fopen(nstabf, "r");
482: fa = fopen(nstabf, "a");
483: if (( f == NULL ) || (fa == NULL)) {
484: unlink(nstabf);
485: ungstab();
486: if (f != NULL ) fclose(f);
487: if (fa != NULL ) fclose(fa);
488: return ( nil );
489: }
490:
491: /* read exec header on file */
492: #ifndef os_vms
493: fread((char *)&buf, sizeof buf, 1, f);
494: #else os_vms
495: /*
496: * Under VMS/EUNICE we have to try the 1st 512 byte
497: * block and the 2nd 512 byte block (there may be
498: * a VMS header in the 1st 512 bytes).
499: */
500: get_aout_header(fileno(f),&buf);
501: #endif os_vms
502:
503: /* Is this a legitimate a.out file? */
504: if (N_BADMAG(buf)) {
505: if (fvirgin) {
506: unlink(nstabf);
507: ungstab();
508: }
509: fclose(f);
510: fclose(fa);
511: errorh1(Vermisc,"Removeaddress: Bad file",nil,FALSE,0,inewstr(ostabf));
512: {Freexs(); return(nil);}
513: } else {
514: symadd = N_SYMOFF(buf);
515: #if ! (os_unisoft | os_unix_ts)
516: /*
517: * read in string table if not done during copying
518: */
519: if (fvirgin==0){
520: fseek(f,(long)N_STROFF(buf),0);
521: fread((char *)&strsize,sizeof (int),1,f);
522: strsize -= 4;
523: strtbl = alloca(strsize);
524: fread(strtbl,strsize,1,f);
525: }
526: #endif
527: n = buf.a_syms;
528: fseek(f, (long)symadd, 0);
529: while (n) {
530: m = sizeof (nlbuf);
531: if (n < m)
532: m = n;
533:
534: /* read next block of symbols from a.out file */
535: fread((char *)nlbuf, m, 1, f);
536: savem = m;
537: savesymadd = symadd;
538: symadd += m;
539: n -= m;
540: change = 0;
541:
542: /* compare block of symbols against list of entry point
543: * names given, if a match occurs, clear the N_EXT bit
544: * for that given symbol and signal a change.
545: */
546: for (q = nlbuf; (m -= sizeof(struct nlist)) >= 0; q++) {
547:
548: /* make sure it is external */
549: if (
550: (q->n_type & N_EXT)==0
551: #if ! (os_unix_ts | os_unisoft)
552: || q->n_un.n_strx == 0 || q->n_type & N_STAB
553: #endif
554: ) continue;
555: for (mlbot=lbot,i2 = 0;i2<numberofargs;i2++,mlbot++) {
556: #if ! (os_unix_ts | os_unisoft)
557: if(strcmp((char *)mlbot->val,
558: strtbl+q->n_un.n_strx-4)!=0)
559: continue;
560: #else
561: if(strcmpn((char *)mlbot->val,
562: q->n_name,8)!=0)
563: continue;
564: #endif
565: change = 1;
566: q->n_type &= ~N_EXT;
567: break;
568: }
569: }
570: if ( change ) {
571: fseek(fa,(long)savesymadd,0);
572: fwrite((char *)nlbuf, savem, 1, fa);
573: if (--nargleft == 0)
574: goto alldone;
575: }
576: }
577: }
578: alldone:
579: fclose(f);
580: fclose(fa);
581: if(fvirgin)
582: fvirgin = 0;
583: stabf = nstabf;
584: {Freexs(); return(tatom);}
585: }
586: char *
587: Ilibdir()
588: {
589: register lispval handy;
590: tryagain:
591: handy = Vlibdir->a.clb;
592: switch(TYPE(handy)) {
593: case ATOM:
594: handy = (lispval) handy->a.pname;
595: case STRNG:
596: break;
597: default:
598: (void) error(
599: "cfasl or load: lisp-library-directory not bound to string or atom",
600: TRUE);
601: goto tryagain;
602: }
603: return((char *) handy);
604: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.