From 96500861d92f0f43ad948514b174866cbf63ac21 Mon Sep 17 00:00:00 2001
From: John Foderaro <jkf@ucbvax.Berkeley.EDU>
Date: Thu, 27 Dec 1979 18:48:51 -0800
Subject: [PATCH] BSD 3 development Work on file usr/src/cmd/lisp/fasl.c

Synthesized-from: 3bsd
---
 usr/src/cmd/lisp/fasl.c | 230 ++++++++++++++++++++++++++++++++++++++++
 1 file changed, 230 insertions(+)
 create mode 100644 usr/src/cmd/lisp/fasl.c

diff --git a/usr/src/cmd/lisp/fasl.c b/usr/src/cmd/lisp/fasl.c
new file mode 100644
index 0000000000..820f8c46e9
--- /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);
+}
+
-- 
2.20.1