BSD 4 release

[unix-history] / usr / src / cmd / lisp / ffasl.c

static char *sccsid = "@(#)ffasl.c      34.3 10/23/80";

#include "global.h"
#include <sys/types.h>
#include <pagsiz.h>
#include <sys/stat.h>
#include "naout.h"
#define round(x,s) ((((x)-1) & ~((s)-1)) + (s))

char *stabf = 0;
int fvirgin = 1;
static seed=0, mypid = 0;
lispval verify();

/* dispget - get discipline of function
* this is used to handle the tricky defaulting of the discipline
* field of such functions as cfasl and getaddress.
* dispget is given the value supplied by the caller,
*      the error message to print if something goes wrong,
*      the default to use if nil was supplied.
* the discipline can be an atom or string.  If an atom it is supplied
* it must be lambda, nlambda or macro.  Otherwise the atoms pname
* is used.
*/

lispval 
dispget(given,messg,defult)
lispval given,defult;
char *messg;
{
       int typ;

       while(TRUE)
       {
               if(given == nil) 
                  return(defult);
               if((typ=TYPE(given)) == ATOM)
               {  if(given == lambda ||
                     given == nlambda ||
                     given == macro) return(given);
                  else return((lispval) given->a.pname);
               } else if(typ == STRNG) return(given);

               given = errorh(Vermisc,messg,nil,TRUE,0,given);
       }
}

lispval
Lcfasl(){
       register struct argent *mlbot = lbot;
       register lispval work;
       register int fildes, totsize;
       int readsize;
       register struct argent *lbot, *np;
       lispval csegment();
       char *sbrk(), *currend, *tfile, cbuf[6000], *mytemp(), *gstab();
       char ostabf[128];
       struct exec header;
       char *largs;
       snpand(4);

       switch(np-lbot) {
          case 3: protect(nil);        /* no discipline given */
          case 4: protect(nil);        /* no library given  */
       }
       chkarg(5,"cfasl");
       mlbot[0].val = verify(mlbot[0].val,"Incorrect .o file specification");
       mlbot[1].val = verify(mlbot[1].val,"Incorrect entry specification for cfasl");
       mlbot[3].val = dispget(mlbot[3].val,"Incorrect discipline specification for cfasl",Vsubrou->a.pname);
       while(TYPE(mlbot[2].val)!= ATOM) 
       mlbot[2].val = errorh(Vermisc,"Bad associated atom name for fasl",
                                                nil,TRUE,0,mlbot[2].val);
       work = mlbot[4].val;
       if(work==nil)
               largs = 0;
       else 
               largs = (char *) verify(work,"Bad loader flags");

       /*
        * Invoke loader.
        */
       strcpy(ostabf,gstab());
       currend = sbrk(0);
       tfile = mytemp();
       sprintf(cbuf,
               "/usr/lib/lisp/nld -N -A %s -T %x %s -e %s -o %s %s -lc",
               ostabf,
               currend,
               mlbot[0].val,
               mlbot[1].val,
               tfile,
               largs);
       printf(cbuf); fflush(stdout);
       if(system(cbuf)!=0) {
               unlink(tfile);
               ungstab();
               fprintf(stderr,"Ld returns error status\n");
               return(nil);
       }
       putchar('\n'); fflush(stdout);
       if(fvirgin)
               fvirgin = 0;
       else
               unlink(ostabf);
       stabf = tfile;
       if((fildes = open(tfile,0))<0) {
               fprintf(stderr,"Couldn't open temporary file: %s\n",tfile);
               return(nil);
       }
       /*
        * Read a.out header to find out how much room to
        * allocate and attempt to do so.
        */
       if(read(fildes,(char *)&header,sizeof(header)) <= 0) {
               close(fildes);
               return(nil);
       }
       readsize = round(header.a_text,4) + round(header.a_data,4);
       totsize  = readsize + header.a_bss;
       totsize  = round(totsize,512);
       /*
        * Fix up system indicators, typing info, etc.
        */
       currend = (char *)csegment(str_name,totsize,FALSE);
       
       if(readsize!=read(fildes,currend,readsize))
               return(nil);
       work = newfunct();
       work->bcd.entry = (lispval (*)())header.a_entry;
       work->bcd.discipline = mlbot[3].val;
       return(mlbot[2].val->a.fnbnd = work);
}
static char myname[100];
char *
gstab()
{
       register char *cp, *cp2; char *getenv();
       struct stat stbuf;
       extern char **Xargv;

       if(stabf==0) {
               cp = getenv("PATH");
               if(cp==0)
                       cp=":/usr/ucb:/bin:/usr/bin";
               if(*cp==':'||*Xargv[0]=='/') {
                       cp++;
                       if(stat(Xargv[0],&stbuf)==0) {
                               strcpy(myname,Xargv[0]);
                               return(stabf = myname);
                       }
               }
               for(;*cp;) {

                       /* copy over current directory
                          and then append argv[0] */

                       for(cp2=myname;(*cp)!=0 && (*cp)!=':';)
                               *cp2++ = *cp++;
                       *cp2++ = '/';
                       strcpy(cp2,Xargv[0]);
                       if(*cp) cp++;
                       if(0!=stat(myname,&stbuf)) continue;
                       return(stabf = myname);
               }
               error("Could not find which file is being executed.",FALSE);
       } else return (stabf);
}

static char mybuff[40]; 
char *
mytemp()
{
       if(mypid==0) mypid = getpid();
       sprintf(mybuff,"/tmp/Li%d.%d",mypid,seed++);
       return(mybuff);
}
ungstab()
{
       seed--;
       sprintf(mybuff,"/tmp/Li%d.%d",mypid,seed-1);
       if(seed==0) {
               stabf = 0;
               fvirgin = 1;
       }
}
lispval
verify(in,error)
register lispval in;
char *error;
{
       for(EVER) {
               switch(TYPE(in)) {
               case STRNG:
                       return(in);
               case ATOM:
                       return((lispval)in->a.pname);
               }
               in = errorh(Vermisc,error,nil,TRUE,0,in);
       }
}