![[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] / 43BSDReno / pgrm / lisp / franz|
Return to ffasl.c CVS log | Up to [CSRG BSD Unix] / 43BSDReno / pgrm / lisp / franz |
1.1 root 1: #ifndef lint
2: static char *rcsid =
3: "$Header: ffasl.c,v 1.11 87/12/14 18:48:06 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(), *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: sprintf(filename,"tmp:sym%d.stb",pid);
202: unlink(filename);
203: /*
204: * Rename the new symbol table so it is now the old symbol table
205: */
206: sprintf(symfil,"tmp:sym%d.new",pid);
207: link(symfil,filename);
208: unlink(symfil);
209: sprintf(myname,"tmp:sym%d.stb",pid);
210: stabf = myname;
211: /*
212: * Return Lgetaddress(entry,function_name,discipline)
213: */
214: {
215: struct argent *oldlbot, *oldnp;
216: lispval result;
217:
218: oldlbot = lbot;
219: oldnp = np;
220: lbot = np;
221: np++->val = matom(mlbot[1].val);
222: np++->val = mlbot[2].val;
223: np++->val = matom(mlbot[3].val);
224: result = Lgetaddress();
225: lbot = oldlbot;
226: np = oldnp;
227: return(result);
228: }
229: }
230: #endif
231: }
232: #ifdef os_vms
233: #define M 4
234: #else
235: #define M 1
236: #endif
237: #define oktox(n) \
238: (0==stat(n,&stbuf)&&(stbuf.st_mode&S_IFMT)==S_IFREG&&0==access(n,M))
239: char *
240: gstab()
241: {
242: register char *cp, *cp2; char *getenv();
243: struct stat stbuf;
244: extern char **Xargv;
245:
246: if(stabf==0) {
247: cp = getenv("PATH");
248: if(cp==0)
249: cp=":/usr/ucb:/bin:/usr/bin";
250: if(*cp==':'||*Xargv[0]=='/') {
251: cp++;
252: if(oktox(Xargv[0])) {
253: strcpy(myname,Xargv[0]);
254: return(stabf = myname);
255: }
256: #ifdef os_vms
257: /*
258: * Try Xargv[0] with ".stb" concatenated
259: */
260: strcpy(myname,Xargv[0]);
261: strcat(myname,".stb");
262: if (oktox(myname)) return(stabf = myname);
263: /*
264: * Try Xargv[0] with ".exe" concatenated
265: */
266: strcpy(myname,Xargv[0]);
267: strcat(myname,".exe");
268: if (oktox(myname)) return(stabf = myname);
269: #endif
270: }
271: for(;*cp;) {
272:
273: /* copy over current directory
274: and then append argv[0] */
275:
276: for(cp2=myname;(*cp)!=0 && (*cp)!=':';)
277: *cp2++ = *cp++;
278: *cp2++ = '/';
279: strcpy(cp2,Xargv[0]);
280: if(*cp) cp++;
281: #ifndef os_vms
282: if(!oktox(myname)) continue;
283: #else
284: /*
285: * Also try ".stb" and ".exe" in VMS
286: */
287: if(!oktox(myname)) {
288: char *end_of_name;
289: end_of_name = cp2 + strlen(cp2);
290: strcat(cp2,".stb");
291: if(!oktox(myname)) {
292: /*
293: * Try ".exe"
294: */
295: *end_of_name = 0; /* Kill ".stb" */
296: strcat(cp2,".exe");
297: if (!oktox(myname)) continue;
298: }
299: }
300: #endif
301: return(stabf = myname);
302: }
303: /* one last try for dual systems */
304: strcpy(myname,Xargv[0]);
305: if(oktox(myname)) return(stabf = myname);
306: error("Could not find which file is being executed.",FALSE);
307: /* NOTREACHED */
308: } else return (stabf);
309: }
310: static char mybuff[40];
311: char *
312: mytemp()
313: {
314: /*if(mypid==0) mypid = (getpid() & 0xffff);
315: fails if you do a dumplisp after doing a
316: cfasl */
317: sprintf(mybuff,"/tmp/Li%d.%d",(getpid() & 0xffff),seed++);
318: return(mybuff);
319: }
320: ungstab()
321: {
322: seed--;
323: sprintf(mybuff,"/tmp/Li%d.%d",(getpid() & 0xffff),seed-1);
324: if(seed==0) {
325: stabf = 0;
326: fvirgin = 1;
327: }
328: }
329: lispval
330: verify(in,error)
331: register lispval in;
332: char *error;
333: {
334: for(EVER) {
335: switch(TYPE(in)) {
336: case STRNG:
337: return(in);
338: case ATOM:
339: return((lispval)in->a.pname);
340: }
341: in = errorh1(Vermisc,error,nil,TRUE,0,in);
342: }
343: }
344:
345:
346: /* extern int fvirgin; */
347: /* declared in ffasl.c tells if this is original
348: * lisp symbol table.
349: * if fvirgin is 1 then we must copy the symbol
350: * table, else we can overwrite it, since
351: * it is a temporary file which only
352: * one user could be using(was not created
353: * as an original lisp or by a (dumplisp)
354: * or a (savelisp)).
355: */
356:
357: /* copy a block of data from one file to another of size size */
358: copyblock(f1,f2,size)
359: FILE *f1, *f2;
360: long size;
361: {
362: char block[BUFSIZ];
363:
364: while ( size > BUFSIZ ) {
365: size -= BUFSIZ;
366: fread(block,BUFSIZ,1,f1);
367: fwrite(block,BUFSIZ,1,f2);
368: }
369: if (size > 0 ) {
370: fread(block,(int)size,1,f1);
371: fwrite(block,(int)size,1,f2);
372: }
373: }
374:
375: /* removeaddress --
376: *
377: * (removeaddress '|_entry1| '|_entry2| ...)
378: *
379: * removes the given entry points from the run time symbol table,
380: * so that later cfasl'd files can have these label names.
381: *
382: */
383:
384: lispval
385: Lrmadd(){
386: register struct argent *mlbot = lbot;
387: register struct nlist *q;
388: register int i;
389: int numberofargs, strsize;
390: char *gstab();
391: char ostabf[128];
392: char *nstabf,*mytemp();
393: char *strtbl,*alloca();
394: int i2, n, m, nargleft, savem;
395: FILE *f, *fa;
396: FILE *fnew;
397: off_t savesymadd,symadd; /* symbol address */
398: struct exec buf;
399: struct nlist nlbuf[BUFSIZ/sizeof (struct nlist)];
400: int maxlen;
401: int change;
402: Keepxs();
403:
404: numberofargs = (np - lbot);
405: nargleft = numberofargs;
406: maxlen = 0;
407: for ( i=0; i<numberofargs; i++,mlbot ++) {
408: mlbot->val = verify(mlbot->val,"Incorrect entry specification.");
409: n = strlen((char *)mlbot->val);
410: if (n > maxlen)
411: maxlen = n;
412: }
413: /*
414: * Must not disturb object file if it an original file which
415: * other users can execute(signified by the variable fvirgin).
416: * so the entire symbol table is copied to a new file.
417: */
418: if (fvirgin) {
419: strncpy(ostabf,gstab(),128);
420: nstabf = mytemp();
421: /*
422: * copy over symbol table into a temporary file first
423: *
424: */
425: f = fopen(ostabf, "r");
426: fnew = fopen(nstabf, "w");
427: if (( f == NULL ) || (fnew == NULL)) {Freexs(); return( nil );}
428: /* read exec header on file */
429: #ifndef os_vms
430: fread((char *)&buf, sizeof buf, 1, f);
431: #else os_vms
432: /*
433: * Under VMS/EUNICE we have to try the 1st 512 byte
434: * block and the 2nd 512 byte block (there may be
435: * a VMS header in the 1st 512 bytes).
436: */
437: get_aout_header(fileno(f),&buf);
438: #endif os_vms
439:
440: /* Is this a legitimate a.out file? */
441: if (N_BADMAG(buf)) {
442: unlink(nstabf);
443: ungstab();
444: fclose(f);
445: fclose(fnew);
446: errorh1(Vermisc,"Removeaddress: Bad file",nil,FALSE,0,inewstr(ostabf));
447: {Freexs(); return(nil);}
448: }
449: /* set pointer on read file to symbol table */
450: /* must be done before the structure buf is reassigned
451: * so that it will be accurate for the read file
452: */
453: fseek(f,(long)N_SYMOFF(buf),0);
454: /* reset up exec header structure for new file */
455: buf.a_magic = OMAGIC;
456: buf.a_text = 0;
457: buf.a_data = 0;
458: buf.a_bss = 0;
459: buf.a_entry = 0;
460: buf.a_trsize = 0;
461: buf.a_drsize = 0;
462: fwrite((char *)&buf,
463: sizeof buf,1,fnew); /* write out exec header */
464: copyblock(f,fnew,(long)buf.a_syms); /* copy symbol table */
465: #if ! (os_unisoft | os_unix_ts)
466: fread((char *)&strsize,
467: sizeof (int),1,f); /* find size of string table */
468: fwrite((char *)&strsize,
469: sizeof (int),1,fnew); /* find size of string table */
470: strsize -= 4;
471: strtbl = alloca(strsize);
472: fread(strtbl,strsize,1,f); /* read and save string table*/
473: fwrite(strtbl,strsize,1,fnew); /* copy out string table */
474: #endif
475: fclose(f);fclose(fnew);
476: } else {
477: nstabf = gstab();
478: }
479:
480: /*
481: * now unset the external bits it the entry points specified.
482: */
483: f = fopen(nstabf, "r");
484: fa = fopen(nstabf, "a");
485: if (( f == NULL ) || (fa == NULL)) {
486: unlink(nstabf);
487: ungstab();
488: if (f != NULL ) fclose(f);
489: if (fa != NULL ) fclose(fa);
490: return ( nil );
491: }
492:
493: /* read exec header on file */
494: #ifndef os_vms
495: fread((char *)&buf, sizeof buf, 1, f);
496: #else os_vms
497: /*
498: * Under VMS/EUNICE we have to try the 1st 512 byte
499: * block and the 2nd 512 byte block (there may be
500: * a VMS header in the 1st 512 bytes).
501: */
502: get_aout_header(fileno(f),&buf);
503: #endif os_vms
504:
505: /* Is this a legitimate a.out file? */
506: if (N_BADMAG(buf)) {
507: if (fvirgin) {
508: unlink(nstabf);
509: ungstab();
510: }
511: fclose(f);
512: fclose(fa);
513: errorh1(Vermisc,"Removeaddress: Bad file",nil,FALSE,0,inewstr(ostabf));
514: {Freexs(); return(nil);}
515: } else {
516: symadd = N_SYMOFF(buf);
517: #if ! (os_unisoft | os_unix_ts)
518: /*
519: * read in string table if not done during copying
520: */
521: if (fvirgin==0){
522: fseek(f,(long)N_STROFF(buf),0);
523: fread((char *)&strsize,sizeof (int),1,f);
524: strsize -= 4;
525: strtbl = alloca(strsize);
526: fread(strtbl,strsize,1,f);
527: }
528: #endif
529: n = buf.a_syms;
530: fseek(f, (long)symadd, 0);
531: while (n) {
532: m = sizeof (nlbuf);
533: if (n < m)
534: m = n;
535:
536: /* read next block of symbols from a.out file */
537: fread((char *)nlbuf, m, 1, f);
538: savem = m;
539: savesymadd = symadd;
540: symadd += m;
541: n -= m;
542: change = 0;
543:
544: /* compare block of symbols against list of entry point
545: * names given, if a match occurs, clear the N_EXT bit
546: * for that given symbol and signal a change.
547: */
548: for (q = nlbuf; (m -= sizeof(struct nlist)) >= 0; q++) {
549:
550: /* make sure it is external */
551: if (
552: (q->n_type & N_EXT)==0
553: #if ! (os_unix_ts | os_unisoft)
554: || q->n_un.n_strx == 0 || q->n_type & N_STAB
555: #endif
556: ) continue;
557: for (mlbot=lbot,i2 = 0;i2<numberofargs;i2++,mlbot++) {
558: #if ! (os_unix_ts | os_unisoft)
559: if(strcmp((char *)mlbot->val,
560: strtbl+q->n_un.n_strx-4)!=0)
561: continue;
562: #else
563: if(strncmp((char *)mlbot->val,
564: q->n_name,8)!=0)
565: continue;
566: #endif
567: change = 1;
568: q->n_type &= ~N_EXT;
569: break;
570: }
571: }
572: if ( change ) {
573: fseek(fa,(long)savesymadd,0);
574: fwrite((char *)nlbuf, savem, 1, fa);
575: if (--nargleft == 0)
576: goto alldone;
577: }
578: }
579: }
580: alldone:
581: fclose(f);
582: fclose(fa);
583: if(fvirgin)
584: fvirgin = 0;
585: stabf = nstabf;
586: {Freexs(); return(tatom);}
587: }
588: char *
589: Ilibdir()
590: {
591: register lispval handy;
592: tryagain:
593: handy = Vlibdir->a.clb;
594: switch(TYPE(handy)) {
595: case ATOM:
596: handy = (lispval) handy->a.pname;
597: case STRNG:
598: break;
599: default:
600: (void) error(
601: "cfasl or load: lisp-library-directory not bound to string or atom",
602: TRUE);
603: goto tryagain;
604: }
605: return((char *) handy);
606: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.