X-Git-Url: https://git.subgeniuskitty.com/unix-history/.git/blobdiff_plain/2b84abb596f52ab2068d52108adc96838ad4340a..31cef89cb428866f787983e68246030321893df4:/usr/src/cmd/lisp/fex1.c

diff --git a/usr/src/cmd/lisp/fex1.c b/usr/src/cmd/lisp/fex1.c
index dfdf9b57bf..8ac1040482 100644
--- a/usr/src/cmd/lisp/fex1.c
+++ b/usr/src/cmd/lisp/fex1.c
@@ -1,3 +1,5 @@
+static char *sccsid = "@(#)fex1.c	34.2 11/7/80";
+
 #include "global.h"
 /* Nprog ****************************************************************/
 /* This first sets the local variables to nil while saving their old	*/
@@ -16,21 +18,21 @@ Nprog() {
 	struct argent *savedlbot;
 	struct nament *savedbnp;
 	struct nament *topbind;
-	int myerrp; extern int errp;
+	long myerrp; extern long errp;
 
 	savednp = np;
 	savedlbot = lbot;
 	savedbnp = bnp;
-	temp = where = (lbot->val)->car;
+	temp = where = (lbot->val)->d.car;
 	while (TYPE(temp) == DTPR)
 	{
-		temp = where->car;
+		temp = where->d.car;
 		if (TYPE(temp) == ATOM)
 			{
 			bnp->atm = temp;
-			bnp->val = (temp)->clb;
-			(temp)->clb = nil;
-			temp = where = where->cdr;
+			bnp->val = (temp)->a.clb;
+			(temp)->a.clb = nil;
+			temp = where = where->d.cdr;
 			if(bnp++ > bnplim)
 				binderr();
 			}
@@ -39,7 +41,7 @@ Nprog() {
 	topbind = bnp;
 	myerrp = errp;
 	if (where != nil) return(CNIL);
-	temp = where = savedlbot->val->cdr;
+	temp = where = savedlbot->val->d.cdr;
 	getexit(saveme);
 	while (retval = setexit()) {
 		errp = myerrp;
@@ -50,11 +52,12 @@ Nprog() {
 				lbot = savedlbot;
 				return(contval);
 
-		case BRGOTO:	where = (savedlbot->val)->cdr;
-				while ((TYPE(where) == DTPR) && (where->car != contval))
-					where = where->cdr;
-				if (where->car == contval) {
-					resexit(saveme);
+		case BRGOTO:	where = (savedlbot->val)->d.cdr;
+				while ((TYPE(where) == DTPR) && (where->d.car != contval))
+					where = where->d.cdr;
+				if (where->d.car == contval) {
+					/* This seems wrong - M Marcus
+					resexit(saveme);	*/
 					popnames(topbind);
 					lbot = savedlbot;
 					break;
@@ -68,9 +71,9 @@ Nprog() {
 	}
 	while (TYPE(where) == DTPR)
 		{
-		temp = where->car;
+		temp = where->d.car;
 		if((TYPE(temp))!=ATOM) eval(temp);
-		where = where->cdr;
+		where = where->d.cdr;
 		}
 	resexit(saveme);
 	return((where == nil) ? nil : CNIL);
@@ -99,16 +102,16 @@ Ncatch()
 
 	where = lbot->val;
 	if((TYPE(where))!=DTPR) return(nil);
-	todo = where->cdr->car;
-	tag = eval(where->car);
-	while(TYPE(tag)!=ATOM)
-		tag = error("Non symbolic tag in *catch.",TRUE);
+	todo = where->d.cdr->d.car;
+	tag = eval(where->d.car);
+	while((TYPE(tag)!=ATOM) && (TYPE(tag) != DTPR))
+		tag = error("Bad type of tag in *catch.",TRUE);
 	asm("	pushab	On1");
 	asm("	pushr	$0x2540");
-	asm("	subl2	$40,sp");	/* THIS IS A CROCK ....
+	asm("	subl2	$44,sp");	/* THIS IS A CROCK ....
 					   saves current environment
 					   for (return) z.B. */
-	asm("	movc3	$40,_setsav,(sp)");
+	asm("	movc3	$44,_setsav,(sp)");
 	asm("	pushl	_bnp");
 	asm("	pushl	r10");
 	asm("	pushl	$1");
@@ -138,19 +141,19 @@ lispval Nerrset()
 
 	if(TYPE(where) != DTPR) return(nil);	/* no form */
 
-	todo = where->car;		/* form to eval */
-	flag = where->cdr;
-	if(flag != nil) flag = eval(flag->car);	/* tag to tell if er messg */
+	todo = where->d.car;		/* form to eval */
+	flag = where->d.cdr;
+	if(flag != nil) flag = eval(flag->d.car);	/* tag to tell if er messg */
 	else flag = tatom; 	/* if not present , assume t */
 
 	/* push on a catch frame */
 
 	asm("	pushab	On2");		/* where to jump if error */
 	asm("	pushr	$0x2540");
-	asm("	subl2	$40,sp");	/* THIS IS A CROCK ....
+	asm("	subl2	$44,sp");	/* THIS IS A CROCK ....
 					   saves current environment
 					   for (return) z.B. */
-	asm("	movc3	$40,_setsav,(sp)");
+	asm("	movc3	$44,_setsav,(sp)");
 	asm("	pushl	_bnp");
 	asm("	pushl	r8");	/* tag , (ER%all) 	*/
 	asm("	pushl	r11");		/* flag    		*/
@@ -162,7 +165,7 @@ lispval Nerrset()
 	handy = eval(todo);
 	asm("	movl	(sp),_errp");	/* unlink this frame 	*/
 	protect(handy);			/* may gc on nxt call  	*/
-	(flag = newdot()) ->car = handy; /* listify arg */
+	(flag = newdot()) ->d.car = handy; /* listify arg */
 
 	return(flag);
 
@@ -178,49 +181,103 @@ Nthrow()
 	register lispval todo, where;
 	lispval globtag,contval;
 	snpand(2);  /* save register mask */
-	chkarg(2);
+	switch(np-lbot) {
+	case 0:
+		protect(nil);
+	case 1:
+		protect(nil);
+	case 2: break;
+	default:
+		argerr("throw");
+	}
 	globtag = lbot->val;
 	contval = (lbot+1)->val;
 	Idothrow(globtag,contval);
 	error("Uncaught throw",FALSE);
 }
-#include "catchframe.h"
+#include "catchfram.h"
 
 Idothrow(tag,value)
 lispval tag,value;
 {
 	typedef struct catchfr *cp;
 	register cp curp;	/* must be first register */
-	extern int errp;
+	extern long errp;
 	extern lispval globtag;
+	int pass1,founduw;
+	lispval handy,handy2;
+	snpand(1);
 
 	globtag = tag;
+	/*
+	printf("throw,value ");printr(tag,stdout); printf(" ");
+	printr(value,stdout); fflush(stdout);
+	*/
+	pass1 = TRUE;
+  ps2:
+	founduw = FALSE;
+
 	for (curp=(cp)errp ; curp != (cp) nil ; curp =curp->link)
 	{
-	    if(curp->labl == nil || curp->labl == tag)
+	  /*  printf(" lbl: ");printr(curp->labl,stdout);fflush(stdout); */
+	    if(curp->labl == Veruwpt) 
+	    {  founduw = TRUE;
+	       if(!pass1) goto foundit;
+	    }
+	    if(curp->labl == nil || curp->labl == tag) goto foundit;
+	    if(TYPE(curp->labl) == DTPR)
 	    {
+	       for( handy = curp->labl ; handy != nil ; handy = handy->d.cdr)
+	       {
+		   if(handy->d.car == tag) goto foundit;
+	       }
+	    }
+	}
+	return;
+
+	   foundit: 			/* restore context at catch */
+	       if(pass1 && founduw)
+	       {   pass1 = FALSE;
+		   goto ps2;
+		}
+		if(founduw)		/* remember the state */
+		{   protect(handy2 = newdot());
+		    handy2->d.car = Veruwpt;
+		    handy = handy2->d.cdr = newdot();
+		    handy->d.car = tatom;	/* t for throw */
+		    handy = handy->d.cdr = newdot();
+		    handy->d.car = tag;
+		    handy = handy->d.cdr = newdot();
+		    handy->d.car = value;
+		    value = handy2;
+		 /*   printf("Ret uwp: ");printr(value,stdout);fflush(stdout);*/
+		}
+
 		popnames(curp->svbnp);
 		errp = (int) curp->link;
+		/* 
+		 * return value must go into r7 until after movc3 since
+		 * a movc3 clobbers r0
+		 */
+		asm("	movl	8(ap),r7");   /* return value */
 		asm("	addl3	$16,r11,sp");
 				/* account for current (return) */
-		asm("	movc3	$40,(sp),_setsav");
-		asm("	addl2	$40,sp");
+		asm("	movc3	$44,(sp),_setsav");
+		asm("	addl2	$44,sp");
 		asm("	popr	$0x2540");
-		asm("	movl	8(ap),r0");
+		asm("	movl	r7,r0");
 		asm("	rsb");
-		}
-	}
-
-	return;
+		
 }
 
 
+
 /* Ngo ******************************************************************/
 /* First argument only is checked - and must be an atom or evaluate	*/
 /* to one.								*/
 Ngo()
 	{
-	contval = (lbot->val)->car;
+	contval = (lbot->val)->d.car;
 	while (TYPE(contval) != ATOM)
 		{
 		contval = eval(contval);
@@ -260,16 +317,16 @@ lispval
 Nbreak()
 {
 	register lispval hold; register FILE *port;
-	port = okport(Vpoport->clb,stdout);
+	port = okport(Vpoport->a.clb,stdout);
 	fprintf(port,"Breaking:");
 
-	if ((hold = lbot->val) != nil && ((hold = hold->car) != nil))
+	if ((hold = lbot->val) != nil && ((hold = hold->d.car) != nil))
 	{
 		printr(hold,port);
 	}
 	putc('\n',port);
 	dmpport(port);
-	return(error("",TRUE));
+	return(errorh(Verbrk,"",nil,TRUE,0));
 }
 
 
@@ -299,13 +356,13 @@ Ndef() {
 	snpand(4);
 	
 	form = lbot->val;
-	name = form->car;
-	body = form->cdr->car;
-	arglist = body->cdr->car;
+	name = form->d.car;
+	body = form->d.cdr->d.car;
+	arglist = body->d.cdr->d.car;
 	if((TYPE(arglist))!=DTPR && arglist != nil)
 		error("Warning: defining function with nonlist of args",
 			TRUE);
-	name->fnbnd = body;
+	name->a.fnbnd = body;
 	return(name);
 }
 
@@ -314,7 +371,7 @@ lispval
 Nquote()
 {
 	snpand(0);
-	return((lbot->val)->car);
+	return((lbot->val)->d.car);
 }
 
 
@@ -325,16 +382,16 @@ Nsetq()
 	register struct argent *lbot, *np;
 
 
-	for(where = lbot->val; where != nil; where = handy->cdr) {
-		handy = where -> cdr;
+	for(where = lbot->val; where != nil; where = handy->d.cdr) {
+		handy = where->d.cdr;
 		if((TYPE(handy))!=DTPR)
 			error("odd number of args to setq",FALSE);
-		if((lefttype=TYPE(where->car))==ATOM) {
-			if(where->car==nil)
+		if((lefttype=TYPE(where->d.car))==ATOM) {
+			if(where->d.car==nil)
 				error("Attempt to set nil",FALSE);
-			where->car->clb = value = eval(handy->car);
+			where->d.car->a.clb = value = eval(handy->d.car);
 		 }else if(lefttype==VALUE)
-			where->car->l = value = eval(handy->car);
+			where->d.car->l = value = eval(handy->d.car);
 		else error("CAN ONLY SETQ ATOMS OR VALUES",FALSE);
 	}
 	return(value);
@@ -352,19 +409,19 @@ Ncond()
 	for(;;) {
 		if ((TYPE(where))!=DTPR)
 			break;
-		if ((TYPE(where->car))!=DTPR)
+		if ((TYPE(where->d.car))!=DTPR)
 			break;
-		if ((last=eval((where->car)->car)) != nil)
+		if ((last=eval((where->d.car)->d.car)) != nil)
 			break;
-		where = where->cdr;
+		where = where->d.cdr;
 	}
 
 	if ((TYPE(where)) != DTPR)
 			return(nil);
-	where = (where->car)->cdr;
+	where = (where->d.car)->d.cdr;
 	while ((TYPE(where))==DTPR) {
-			last = eval(where->car);
-			where = where->cdr;
+			last = eval(where->d.car);
+			where = where->d.cdr;
 	}
 	return(last);
 }
@@ -378,8 +435,8 @@ Nand()
 	current = lbot->val;
 	temp = tatom;
 	while (current != nil)
-		if ( (temp = current->car)!=nil && (temp = eval(temp))!=nil) 
-			current = current->cdr;
+		if ( (temp = current->d.car)!=nil && (temp = eval(temp))!=nil) 
+			current = current->d.cdr;
 		else {
 			current = nil;
 			temp = nil;
@@ -397,8 +454,8 @@ Nor()
 	current = lbot->val;
 	temp = nil;
 	while (current != nil)
-		if ( (temp = eval(current->car)) == nil)
-			current = current->cdr;
+		if ( (temp = eval(current->d.car)) == nil)
+			current = current->d.cdr;
 		else
 			break;
 	return(temp);
@@ -420,13 +477,13 @@ Nprocess() {
 	current = lbot->val;
 	if( (TYPE(current))!=DTPR )
 		return(nil);
-	temp = current->car;
+	temp = current->d.car;
 	if( (TYPE(temp))!=ATOM )
 		return(nil);
 
-	sharg = temp -> pname;
+	sharg = temp->a.pname;
 
-	if( (current = current->cdr)!=nil && (TYPE((temp = current->car)))==ATOM ) {
+	if( (current = current->d.cdr)!=nil && (TYPE((temp = current->d.car)))==ATOM ) {
 	
 		if (temp == tatom) {
 			wflag = 0;
@@ -434,22 +491,22 @@ Nprocess() {
 		} else if (temp != nil) {
 			fpipe(bufs);
 			wflag = 0;
-			temp->clb = (lispval)bufs[1];
+			temp->a.clb = P(bufs[1]);
 			childsi = fileno(bufs[0]);
 		}
 	
-		if( (current = current->cdr)!=nil && (TYPE((temp = current->car)))==ATOM ) {
+		if( (current = current->d.cdr)!=nil && (TYPE((temp = current->d.car)))==ATOM ) {
 	
 			if (temp != nil) {
 				fpipe(obufs);
-				temp->clb = (lispval)obufs[0];
+				temp->a.clb = P(obufs[0]);
 				childso = fileno(obufs[1]);
 			}
 		}
 	}
 	handler = signal(2,1);
 	if((child = fork()) == 0 ) {
-		if(wflag!=0 && handler!=1)
+		if(wflag!=0 && handler !=1)
 			signal(2,0);
 		else
 			signal(2,1);