BSD 4 release

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

diff --git a/usr/src/cmd/lisp/fex1.c b/usr/src/cmd/lisp/fex1.c
index dfdf9b5..8ac1040 100644 (file)
--- 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   */
 #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;
        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;
 
        savednp = np;
        savedlbot = lbot;
        savedbnp = bnp;

-       temp = where = (lbot->val)->car;
+       temp = where = (lbot->val)->d.car;

        while (TYPE(temp) == DTPR)
        {
        while (TYPE(temp) == DTPR)
        {

-               temp = where->car;
+               temp = where->d.car;

                if (TYPE(temp) == ATOM)
                        {
                        bnp->atm = temp;
                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();
                        }
                        if(bnp++ > bnplim)
                                binderr();
                        }


@@ -39,7 +41,7 @@ Nprog() {
        topbind = bnp;
        myerrp = errp;
        if (where != nil) return(CNIL);
        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;
        getexit(saveme);
        while (retval = setexit()) {
                errp = myerrp;


@@ -50,11 +52,12 @@ Nprog() {
                                lbot = savedlbot;
                                return(contval);
 
                                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;
                                        popnames(topbind);
                                        lbot = savedlbot;
                                        break;


@@ -68,9 +71,9 @@ Nprog() {
        }
        while (TYPE(where) == DTPR)
                {
        }
        while (TYPE(where) == DTPR)
                {

-               temp = where->car;
+               temp = where->d.car;

                if((TYPE(temp))!=ATOM) eval(temp);
                if((TYPE(temp))!=ATOM) eval(temp);

-               where = where->cdr;
+               where = where->d.cdr;

                }
        resexit(saveme);
        return((where == nil) ? nil : CNIL);
                }
        resexit(saveme);
        return((where == nil) ? nil : CNIL);


@@ -99,16 +102,16 @@ Ncatch()
 
        where = lbot->val;
        if((TYPE(where))!=DTPR) return(nil);
 
        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("   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. */
                                           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");
        asm("   pushl   _bnp");
        asm("   pushl   r10");
        asm("   pushl   $1");


@@ -138,19 +141,19 @@ lispval Nerrset()
 
        if(TYPE(where) != DTPR) return(nil);    /* no form */
 
 
        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");
        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. */
                                           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                 */
        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   */
        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);
 
 
        return(flag);
 


@@ -178,49 +181,103 @@ Nthrow()
        register lispval todo, where;
        lispval globtag,contval;
        snpand(2);  /* save register mask */
        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);
 }
        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 */
 
 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;
        extern lispval globtag;

+       int pass1,founduw;
+       lispval handy,handy2;
+       snpand(1);

 
        globtag = tag;
 
        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)
        {
        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;
                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("   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("   popr    $0x2540");

-               asm("   movl    8(ap),r0");
+               asm("   movl    r7,r0");

                asm("   rsb");
                asm("   rsb");

-               }
-       }
-
-       return;
+               

 }
 
 
 }
 
 

+

 /* Ngo ******************************************************************/
 /* First argument only is checked - and must be an atom or evaluate    */
 /* to one.                                                             */
 Ngo()
        {
 /* 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);
        while (TYPE(contval) != ATOM)
                {
                contval = eval(contval);


@@ -260,16 +317,16 @@ lispval
 Nbreak()
 {
        register lispval hold; register FILE *port;
 Nbreak()
 {
        register lispval hold; register FILE *port;

-       port = okport(Vpoport->clb,stdout);
+       port = okport(Vpoport->a.clb,stdout);

        fprintf(port,"Breaking:");
 
        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);
        {
                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;
        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);
        if((TYPE(arglist))!=DTPR && arglist != nil)
                error("Warning: defining function with nonlist of args",
                        TRUE);

-       name->fnbnd = body;
+       name->a.fnbnd = body;

        return(name);
 }
 
        return(name);
 }
 


@@ -314,7 +371,7 @@ lispval
 Nquote()
 {
        snpand(0);
 Nquote()
 {
        snpand(0);

-       return((lbot->val)->car);
+       return((lbot->val)->d.car);

 }
 
 
 }
 
 


@@ -325,16 +382,16 @@ Nsetq()
        register struct argent *lbot, *np;
 
 
        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((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);
                                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)
                 }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);
                else error("CAN ONLY SETQ ATOMS OR VALUES",FALSE);
        }
        return(value);


@@ -352,19 +409,19 @@ Ncond()
        for(;;) {
                if ((TYPE(where))!=DTPR)
                        break;
        for(;;) {
                if ((TYPE(where))!=DTPR)
                        break;

-               if ((TYPE(where->car))!=DTPR)
+               if ((TYPE(where->d.car))!=DTPR)

                        break;
                        break;

-               if ((last=eval((where->car)->car)) != nil)
+               if ((last=eval((where->d.car)->d.car)) != nil)

                        break;
                        break;

-               where = where->cdr;
+               where = where->d.cdr;

        }
 
        if ((TYPE(where)) != DTPR)
                        return(nil);
        }
 
        if ((TYPE(where)) != DTPR)
                        return(nil);

-       where = (where->car)->cdr;
+       where = (where->d.car)->d.cdr;

        while ((TYPE(where))==DTPR) {
        while ((TYPE(where))==DTPR) {

-                       last = eval(where->car);
-                       where = where->cdr;
+                       last = eval(where->d.car);
+                       where = where->d.cdr;

        }
        return(last);
 }
        }
        return(last);
 }


@@ -378,8 +435,8 @@ Nand()
        current = lbot->val;
        temp = tatom;
        while (current != nil)
        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;
                else {
                        current = nil;
                        temp = nil;


@@ -397,8 +454,8 @@ Nor()
        current = lbot->val;
        temp = nil;
        while (current != nil)
        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);
                else
                        break;
        return(temp);


@@ -420,13 +477,13 @@ Nprocess() {
        current = lbot->val;
        if( (TYPE(current))!=DTPR )
                return(nil);
        current = lbot->val;
        if( (TYPE(current))!=DTPR )
                return(nil);

-       temp = current->car;
+       temp = current->d.car;

        if( (TYPE(temp))!=ATOM )
                return(nil);
 
        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;
        
                if (temp == tatom) {
                        wflag = 0;


@@ -434,22 +491,22 @@ Nprocess() {
                } else if (temp != nil) {
                        fpipe(bufs);
                        wflag = 0;
                } else if (temp != nil) {
                        fpipe(bufs);
                        wflag = 0;

-                       temp->clb = (lispval)bufs[1];
+                       temp->a.clb = P(bufs[1]);

                        childsi = fileno(bufs[0]);
                }
        
                        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);
        
                        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 ) {
                                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);
                        signal(2,0);
                else
                        signal(2,1);