BSD 3 development

Work on file usr/src/cmd/lisp/fasl.c

Synthesized-from: 3bsd

diff --git a/usr/src/cmd/lisp/fasl.c b/usr/src/cmd/lisp/fasl.c
new file mode 100644 (file)
index 0000000..820f8c4
--- /dev/null
+++ b/usr/src/cmd/lisp/fasl.c
@@ -0,0 +1,230 @@
+#include "global.h"
+#include "lfuncs.h"
+#include "chkrtab.h"
+#include <a.out.h>
+#define round(x,s) ((((x)-1) & ~((s)-1)) + (s))
+#define STRLIM 2048
+
+/* this is the original fasl, which used nld to do relocation.
+ * On nov 4, it was replaced by rfasl
+ */
+
+static lispval mkptr();
+static char stabbuf[32]="";
+static struct exec header;
+static lispval *linkaddr;
+static int fildes;
+static char *currend;
+extern char *stabf;
+extern int  fvirgin;
+static lispval currtab;
+static lispval curibase;
+lispval
+Loldfasl(){
+       register struct argent *mlbot = lbot;
+       register lispval work;
+       int totsize, readsize;
+       lispval csegment(), errorh();
+       char *sbrk(), *tfile, cbuf[512], *mytemp(), *gstab();
+       struct nament *obnp = bnp;
+
+       snpand(2);
+       if(np - mlbot != 1 || TYPE(mlbot[0].val)!=ATOM)
+               mlbot[0].val = errorh(Vermisc,
+                                     "fasl: Incorrect .o file specification:",
+                                     nil,
+                                     TRUE,
+                                     0,
+                                     mlbot[0].val);
+
+       /*
+        * Invoke loader.
+        */
+       currend = sbrk(0);
+       tfile = mytemp();
+       sprintf(cbuf,
+               "/usr/lib/lisp/nld -A %s -T %x -N %s -o %s",
+               gstab(),
+               currend,
+               mlbot[0].val->pname,
+               tfile);
+       /* printf(cbuf); fflush(stdout);   debugging */
+       printf("[fasl: %s]",mlbot[0].val->pname);
+       fflush(stdout);
+       if(system(cbuf)!=0) {
+               unlink(tfile);
+               return(nil);
+       }
+       putchar('\n');                  /* signal end of nld */
+       fflush(stdout);
+       if((fildes = open(tfile,0))<0)
+               return(nil);
+       if(fvirgin)
+               fvirgin = 0;
+       else
+               unlink(stabf);
+       strcpyn(stabbuf,tfile,31);
+       stabf = stabbuf;
+       /*
+        * 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 = header.a_text;
+       totsize  = readsize;
+       totsize  = round(totsize,PAGSIZ);
+       /*
+        * Fix up system indicators, typing info, etc.
+        */
+       currend = (char *)csegment(int_name,totsize/(sizeof(int)));
+       
+       if(readsize!=read(fildes,currend,readsize))
+               return(nil);
+       linkaddr = (lispval *)*(int *)currend;
+       currtab = Vreadtable->clb;
+       Vreadtable->clb = strtab;
+       curibase = ibase->clb;
+       ibase->clb = inewint(10);
+       do_linker();
+       do_binder();
+       ibase->clb=curibase;
+       Vreadtable->clb = currtab;
+       chkrtab(currtab);       /* added by jkf, shouldnt be needed */
+       return(tatom);
+}
+static char mybuff[40]; 
+char *
+mytemp()
+{
+       static seed=0, mypid = 0;
+       if(mypid==0) mypid = getpid();
+       sprintf(mybuff,"/tmp/Li%d.%d",mypid,seed++);
+       return(mybuff);
+}
+
+static
+do_linker()
+{
+       register int *i, *end, temp;
+       char array[STRLIM];
+       extern lispval *bind_lists;
+
+       /* first link this linkage table to the garbage
+          collector's list.  We will try to be tricky
+       so that if the garbage collector is invoked
+       by mkptr we will not cause markdp() to go off
+       the deep end.
+       */
+       *(linkaddr-1) = (lispval) bind_lists;
+       bind_lists = linkaddr;
+       i = (int *)linkaddr;
+       end = (int *)(currend + header.a_text - 7);
+       for(; i<end; i++) {
+               temp = *i;
+               *i = -1;    /* clobber to short circuit gc */
+               findstr(temp, array);
+               *i = (int)mkptr(array);
+       }
+}
+static
+do_binder()
+{
+       char array[STRLIM];
+       struct argent *onp = np;
+       int pos;
+       register lispval handy;
+       struct {lispval (*b_entry)();
+                       int b_atmlnk;
+                       int b_type;} bindage;
+
+       snpand(0);
+       pos = lseek(fildes, (sizeof header)+header.a_text, 0);
+       while(read(fildes, &bindage, sizeof bindage)==sizeof bindage
+                       && bindage.b_atmlnk != -1) {
+               np = onp;
+               if( bindage.b_type == 99) {
+                       /* we must evaluate this form for effect */
+                       /* and must take care that setsyntax works
+                          on the proper read table */
+ 
+                       findstr(bindage.b_atmlnk, array);
+                       if(ISNIL(copval(gcload,CNIL)) && loading->clb != tatom)
+                               gc(CNIL);       /*  do a gc if gc will be off  */
+                       handy = (mkptr(array));
+                       ibase->clb=curibase;
+                       Vreadtable->clb = currtab;
+                       eval(handy);
+                       Vreadtable->clb = strtab;
+                       curibase = ibase->clb;
+                       ibase->clb = inewint(10);
+                       goto out;
+               }
+               handy = newfunct();
+               protect(handy);
+               handy->entry = bindage.b_entry;
+               handy->discipline = (bindage.b_type == 0 ? lambda :
+                                                        bindage.b_type == 1 ? nlambda :
+                                                                              macro);
+
+               findstr(bindage.b_atmlnk, array);
+               if(*array != '(')
+                       mkptr(array)->fnbnd = handy;
+               else {
+                       char *i,*j,*index();
+                       lispval prop, atom;
+
+                       i = index(array, ':');
+                       j = index(array, ')');
+                       *i = 0;
+                       *j = 0;
+                       protect(prop = mkptr(array+1));
+                       atom = mkptr(i+1);
+                       Iputprop(atom,handy,prop);
+               }
+       out:
+               pos = lseek(fildes, pos + sizeof bindage, 0);
+       }
+}
+
+static
+findstr(ptr,array)
+int ptr;
+char *array;
+{
+       int cnt = 0;
+
+       lseek(fildes, sizeof header + header.a_text + ptr, 0);
+       while(cnt<STRLIM && read(fildes,&array[cnt],1)==1
+                               && array[cnt]!=0) cnt++;
+       if(cnt >= STRLIM) error("fasl string table overflow",FALSE);
+}
+
+static lispval
+mkptr(str)
+register char *str;
+{
+       lispval work;
+       register FILE *p=stdin;
+       snpand(2);
+
+       /* find free file descriptor */
+       for(;p->_flag&(_IOREAD|_IOWRT);p++)
+               if(p >= _iob + _NFILE)
+                       error("Too many open files to do readlist",FALSE);
+       p->_flag = _IOREAD | _IOSTRG;
+       p->_base = p->_ptr = str;
+       p->_cnt = strlen(str) + 1;
+       
+       lbot = np;
+       protect(P(p));
+       work = Lread();
+       p->_cnt = 0;
+       p->_ptr = p->_base = 0;
+       p->_file = 0;
+       p->_flag=0;
+       return(work);
+}
+