4.3BSD - /usr/src/ucb/lisp/franz/ffasl.c

   1: #ifndef lint
   2: static char *rcsid =
   3:    "$Header: ffasl.c,v 1.10 83/12/09 16:45:04 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:         strncpy(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(strncmp((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: }

Defined functions

Defined variables

Defined macros