BSD 4 release

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

diff --git a/usr/src/cmd/lisp/lam3.c b/usr/src/cmd/lisp/lam3.c
index c0c51bf..79e37b4 100644 (file)
--- a/usr/src/cmd/lisp/lam3.c
+++ b/usr/src/cmd/lisp/lam3.c
@@ -1,3 +1,5 @@
+static char *sccsid = "@(#)lam3.c      34.2 10/24/80";
+

 # include "global.h"
 lispval
 Lalfalp()
 # include "global.h"
 lispval
 Lalfalp()


@@ -6,13 +8,13 @@ Lalfalp()
        register struct argent *inp;
        snpand(3); /* clobber save mask */
 
        register struct argent *inp;
        snpand(3); /* clobber save mask */
 

-       chkarg(2);
+       chkarg(2,"alphalessp");

        inp = lbot;
        first = (inp)->val;
        second = (inp+1)->val;
        if( (TYPE(first))!=ATOM || (TYPE(second))!=ATOM)
                error("alphalessp expects atoms");
        inp = lbot;
        first = (inp)->val;
        second = (inp+1)->val;
        if( (TYPE(first))!=ATOM || (TYPE(second))!=ATOM)
                error("alphalessp expects atoms");

-       if(strcmp(first->pname,second->pname) <= 0)
+       if(strcmp(first->a.pname,second->a.pname) <= 0)

                return(tatom);
        else
                return(nil);
                return(tatom);
        else
                return(nil);


@@ -24,10 +26,10 @@ Lncons()
        register lispval handy;
        snpand(1); /* clobber save mask */
 
        register lispval handy;
        snpand(1); /* clobber save mask */
 

-       chkarg(1);
+       chkarg(1,"ncons");

        handy = newdot();
        handy = newdot();

-       handy -> cdr = nil;
-       handy -> car = lbot->val;
+       handy->d.cdr = nil;
+       handy->d.car = lbot->val;

        return(handy);
 }
 lispval
        return(handy);
 }
 lispval


@@ -36,7 +38,7 @@ Lzerop()
        register lispval handy;
        snpand(1); /* clobber save mask */
 
        register lispval handy;
        snpand(1); /* clobber save mask */
 

-       chkarg(1);
+       chkarg(1,"zerop");

        handy = lbot->val;
        switch(TYPE(handy)) {
        case INT:
        handy = lbot->val;
        switch(TYPE(handy)) {
        case INT:


@@ -52,7 +54,7 @@ Lonep()
        register lispval handy; lispval Ladd();
        snpand(1); /* clobber save mask */
 
        register lispval handy; lispval Ladd();
        snpand(1); /* clobber save mask */
 

-       chkarg(1);
+       chkarg(1,"onep");

        handy = lbot->val;
        switch(TYPE(handy)) {
        case INT:
        handy = lbot->val;
        switch(TYPE(handy)) {
        case INT:


@@ -102,12 +104,46 @@ cmpx(lssp)
 lispval
 Lgreaterp()
 {
 lispval
 Lgreaterp()
 {

+       register int typ;
+       /* do the easy cases first */
+       if(np-lbot == 2)
+       {   if((typ=TYPE(lbot->val)) == INT)
+           {    if((typ=TYPE(lbot[1].val)) == INT)
+                  return((lbot[0].val->i - lbot[1].val->i) > 0 ? tatom : nil);
+                else if(typ == DOUB)
+                 return((lbot[0].val->i - lbot[1].val->r) > 0.0 ? tatom : nil);
+           }
+           else if(typ == DOUB)
+           {    if((typ=TYPE(lbot[1].val)) == INT)
+                 return((lbot[0].val->r - lbot[1].val->i) > 0.0 ? tatom : nil);
+                else if(typ == DOUB)
+                 return((lbot[0].val->r - lbot[1].val->r) > 0.0 ? tatom : nil);
+           }
+       }
+                 

        return(cmpx(FALSE));
 }
 
 lispval
 Llessp()
 {
        return(cmpx(FALSE));
 }
 
 lispval
 Llessp()
 {

+       register int typ;
+       /* do the easy cases first */
+       if(np-lbot == 2)
+       {   if((typ=TYPE(lbot->val)) == INT)
+           {    if((typ=TYPE(lbot[1].val)) == INT)
+                  return((lbot[0].val->i - lbot[1].val->i) < 0 ? tatom : nil);
+                else if(typ == DOUB)
+                 return((lbot[0].val->i - lbot[1].val->r) < 0.0 ? tatom : nil);
+           }
+           else if(typ == DOUB)
+           {    if((typ=TYPE(lbot[1].val)) == INT)
+                 return((lbot[0].val->r - lbot[1].val->i) < 0.0 ? tatom : nil);
+                else if(typ == DOUB)
+                 return((lbot[0].val->r - lbot[1].val->r) < 0.0 ? tatom : nil);
+           }
+       }
+                 

        return(cmpx(TRUE));
 }
 
        return(cmpx(TRUE));
 }
 


@@ -118,7 +154,7 @@ Ldiff()
        snpand(3); /* clobber save mask */
 
 
        snpand(3); /* clobber save mask */
 
 

-       chkarg(2);
+       chkarg(2,"Ldiff");

        arg1 = lbot->val;
        arg2 = (lbot+1)->val;
        if(TYPE(arg1)==INT && TYPE(arg2)==INT) {
        arg1 = lbot->val;
        arg2 = (lbot+1)->val;
        if(TYPE(arg1)==INT && TYPE(arg2)==INT) {


@@ -137,7 +173,7 @@ Lmod()
        fake1.CDR = 0;
        snpand(2); /* clobber save mask */
 
        fake1.CDR = 0;
        snpand(2); /* clobber save mask */
 

-       chkarg(2);
+       chkarg(2,"mod");

        handy = arg1 = lbot->val;
        arg2 = (lbot+1)->val;
        switch(TYPE(arg1)) {
        handy = arg1 = lbot->val;
        arg2 = (lbot+1)->val;
        switch(TYPE(arg1)) {


@@ -160,7 +196,8 @@ Lmod()
        default:
                error("non-numeric argument",FALSE);
        }
        default:
                error("non-numeric argument",FALSE);
        }

-               if(Lzerop()!=nil) return(handy);
+               if(TYPE((lbot+1)->val)==INT && lbot[1].val->i==0)
+                       return(handy);

                divbig(arg1,arg2,0,&handy);
                if(handy==((lispval)&fake1))
                        handy = inewint(fake1.I);
                divbig(arg1,arg2,0,&handy);
                if(handy==((lispval)&fake1))
                        handy = inewint(fake1.I);


@@ -206,7 +243,7 @@ Lminus()
        lispval subbig();
        snpand(3); /* clobber save mask */
 
        lispval subbig();
        snpand(3); /* clobber save mask */
 

-       chkarg(1);
+       chkarg(1,"minus");

        arg1 = lbot->val;
        handy = nil;
        switch(TYPE(arg1)) {
        arg1 = lbot->val;
        handy = nil;
        switch(TYPE(arg1)) {


@@ -219,8 +256,8 @@ Lminus()
                break;
        case SDOT:
                handy = rdrsdot;
                break;
        case SDOT:
                handy = rdrsdot;

-               handy->I = 0;
-               handy->CDR = (lispval) 0;
+               handy->s.I = 0;
+               handy->s.CDR = (lispval) 0;

                handy = subbig(handy,arg1);
                break;
 
                handy = subbig(handy,arg1);
                break;
 


@@ -246,8 +283,8 @@ loop:
                if(handy->r < 0) flag = TRUE;
                break;
        case SDOT:
                if(handy->r < 0) flag = TRUE;
                break;
        case SDOT:

-               for(work = handy; work->CDR!=(lispval) 0; work = work->CDR);
-               if(work->I < 0) flag = TRUE;
+               for(work = handy; work->s.CDR!=(lispval) 0; work = work->s.CDR);
+               if(work->s.I < 0) flag = TRUE;

                break;
        default:
                handy = errorh(Vermisc,
                break;
        default:
                handy = errorh(Vermisc,


@@ -269,7 +306,7 @@ Labsval()
        register temp;
        snpand(3); /* clobber save mask */
 
        register temp;
        snpand(3); /* clobber save mask */
 

-       chkarg(1);
+       chkarg(1,"absval");

        arg1 = lbot->val;
        if(Lnegp()!=nil) return(Lminus());
 
        arg1 = lbot->val;
        if(Lnegp()!=nil) return(Lminus());
 


@@ -299,7 +336,20 @@ int f;
        register struct frame *myfp; register lispval handy;
        int **fp;       /* this must be the first local */
        int virgin=1;
        register struct frame *myfp; register lispval handy;
        int **fp;       /* this must be the first local */
        int virgin=1;

+       lispval linterp();

        lispval _qfuncl(),tynames();    /* locations in qfuncl */
        lispval _qfuncl(),tynames();    /* locations in qfuncl */

+       extern int prinlevel,prinlength;
+
+       if(TYPE(Vprinlevel->a.clb) == INT)
+       { 
+          prinlevel = Vprinlevel->a.clb->i;
+       }
+       else prinlevel = -1;
+       if(TYPE(Vprinlength->a.clb) == INT)
+       {
+           prinlength = Vprinlength->a.clb->i;
+       }
+       else prinlength = -1;

 
        if(f==1)
                printf("Forms in evaluation:\n");
 
        if(f==1)
                printf("Forms in evaluation:\n");


@@ -313,10 +363,11 @@ int f;
            if( (myfp->pc > eval  &&            /* interpreted code */
                 myfp->pc < popnames)
                ||
            if( (myfp->pc > eval  &&            /* interpreted code */
                 myfp->pc < popnames)
                ||

-               (myfp->pc > _qfuncl &&          /* compiled code */
-                myfp->pc < tynames)  )
+               (myfp->pc > Lfuncal &&          /* compiled code */
+                myfp->pc < linterp)  )

            {
            {

-               handy = (myfp->ap[1]);
+             if(((int) myfp->ap[0]) == 1)              /* only if arg given */
+             { handy = (myfp->ap[1]);

                if(f==1)
                        printr(handy,stdout), putchar('\n');
                else {
                if(f==1)
                        printr(handy,stdout), putchar('\n');
                else {


@@ -324,8 +375,9 @@ int f;
                                virgin = 0;
                        else
                                printf(" -- ");
                                virgin = 0;
                        else
                                printf(" -- ");

-                       printr((TYPE(handy)==DTPR)?handy->car:handy,stdout);
+                       printr((TYPE(handy)==DTPR)?handy->d.car:handy,stdout);

                }
                }

+             }

 
            }
 
 
            }
 


@@ -335,55 +387,63 @@ int f;
        putchar('\n');
        return(nil);
 }
        putchar('\n');
        return(nil);
 }

+
+/*
+ *
+ *     (baktrace)
+ *
+ * baktrace will print the names of all functions being evaluated
+ * from the current one (baktrace) down to the first one.
+ * currently it only prints the function name.  Planned is a
+ * list of local variables in all stack frames.
+ * written by jkf.
+ *
+ */

 lispval
 Lbaktrace()
 {
        isho(0);
 }
 lispval
 Lbaktrace()
 {
        isho(0);
 }

-/* ===========================================================
--
-**** baktrace ****     (moved back by kls)
--
-- baktrace will print the names of all functions being evaluated
-- from the current one (baktrace) down to the first one.
-- currently it only prints the function name.  Planned is a
-- list of local variables in all stack frames.
-- written by jkf.
--
--============================================================*/
-
-/*=============================================================
--
--***  oblist ****
--
-- oblist returns a list of all symbols in the oblist
--
-- written by jkf.
-============================================================*/

 
 

+/*
+ *
+ * (oblist)
+ *
+ * oblist returns a list of all symbols in the oblist
+ *
+ * written by jkf.
+ */

 lispval
 Loblist()
 {
     int indx;
     lispval headp, tailp ;
     struct atom *symb ;
 lispval
 Loblist()
 {
     int indx;
     lispval headp, tailp ;
     struct atom *symb ;

+    extern int hashtop;
+    snpand(0);

 
     headp = tailp = newdot(); /* allocate first DTPR */
     protect(headp);            /*protect the list from garbage collection*/
                                /*line added by kls                       */
 
 
     headp = tailp = newdot(); /* allocate first DTPR */
     protect(headp);            /*protect the list from garbage collection*/
                                /*line added by kls                       */
 

-    for( indx=0 ; indx <= HASHTOP-1 ; indx++ ) /* though oblist */
+    for( indx=0 ; indx <= hashtop-1 ; indx++ ) /* though oblist */

     {
        for( symb = hasht[indx] ;
             symb != (struct atom *) CNIL ;
             symb = symb-> hshlnk)
        {
     {
        for( symb = hasht[indx] ;
             symb != (struct atom *) CNIL ;
             symb = symb-> hshlnk)
        {

-           tailp->car = (lispval) symb  ; /* remember this atom */
-           tailp = tailp->cdr = newdot() ; /* link to next DTPR */
+           if(TYPE(symb) != ATOM) 
+           {   printf(" non symbol in hasht[%d] = %x: ",indx,symb);
+               printr(symb,stdout);
+               printf(" \n");
+               fflush(stdout);
+           }
+           tailp->d.car = (lispval) symb  ; /* remember this atom */
+           tailp = tailp->d.cdr = newdot() ; /* link to next DTPR */

        }
     }
 
        }
     }
 

-    tailp->cdr = nil ; /* close the list unfortunately throwing away
+    tailp->d.cdr = nil ; /* close the list unfortunately throwing away

                          the last DTPR
                          */
     return(headp);
                          the last DTPR
                          */
     return(headp);


@@ -398,10 +458,7 @@ Loblist()
  * (well thats enough for now) if s is a fixnum then we modify the bits
  * for c in the readtable.
  */
  * (well thats enough for now) if s is a fixnum then we modify the bits
  * for c in the readtable.
  */

-#define VMAC   0316
-#define VSPL   0315
-#define VDQ     0212
-#define VESC   0217
+#include "chars.h"

 #include "chkrtab.h"
 
 lispval
 #include "chkrtab.h"
 
 lispval


@@ -411,13 +468,25 @@ Lsetsyn()
        register struct argent *mynp;
        register index;
        register struct argent *lbot, *np;
        register struct argent *mynp;
        register index;
        register struct argent *lbot, *np;

-       lispval x;
+       lispval x,debugmode;

        extern char *ctable;
        extern char *ctable;

+       extern lispval Istsrch();

        int value;
 
        int value;
 

-       chkarg(3);
-       s = Vreadtable->clb;
+       switch(np-lbot) {
+       case 2:
+               protect(nil);
+       case 3:
+               break;
+       default:
+               argerr("setsyntax");
+       }
+       s = Vreadtable->a.clb;

        chkrtab(s);
        chkrtab(s);

+       /* debugging code 
+       debugmode = Istsrch(matom("debugging"))->d.cdr->d.cdr->d.cdr;
+       if(debugmode)  printf("Readtable addr: %x\n",ctable);
+         end debugging code */

        mynp = lbot;
        c = (mynp++)->val;
        s = (mynp++)->val;
        mynp = lbot;
        c = (mynp++)->val;
        s = (mynp++)->val;


@@ -425,20 +494,25 @@ Lsetsyn()
 
        switch(TYPE(c)) {
        default:
 
        switch(TYPE(c)) {
        default:

-               error("neither fixnum nor atom as char to setsyntax",FALSE);
+               error("neither fixnum, atom or string as char to setsyntax",FALSE);

 
        case ATOM:
 
        case ATOM:

-               index = *(c->pname);
-               if((c->pname)[1])error("Only 1 char atoms to setsyntax",FALSE);
+               index = *(c->a.pname);
+               if((c->a.pname)[1])error("Only 1 char atoms to setsyntax",FALSE);

                break;
 
        case INT:
                index = c->i;
                break;
 
        case INT:
                index = c->i;

+               break;
+
+       case STRNG:
+               index = (int) *((char *) c);

        }
        switch(TYPE(s)) {
        case INT:
                if(s->i == VESC) Xesc = (char) index;
                else if(s->i == VDQ) Xdqc = (char) index;
        }
        switch(TYPE(s)) {
        case INT:
                if(s->i == VESC) Xesc = (char) index;
                else if(s->i == VDQ) Xdqc = (char) index;

+               else if(s->i == VSD) Xsdc = (char) index;       /* string */

 
                if(ctable[index] == VESC   /* if we changed the current esc */
                  && s->i != VESC          /* to something else, pick current */
 
                if(ctable[index] == VESC   /* if we changed the current esc */
                  && s->i != VESC          /* to something else, pick current */


@@ -452,6 +526,12 @@ Lsetsyn()
                        ctable[index] = s->i;
                        rpltab(VDQ,&Xdqc);
                }
                        ctable[index] = s->i;
                        rpltab(VDQ,&Xdqc);
                }

+               else if(ctable[index] == VSD  /* and for string delimiter */
+                       && s->i != VSD
+                       && Xsdc == (char) index) {
+                        ctable[index] = s->i;
+                        rpltab(VSD,&Xsdc);
+               }

                else ctable[index] = s->i;
 
                break;
                else ctable[index] = s->i;
 
                break;


@@ -470,14 +550,13 @@ Lsetsyn()
        return(tatom);
 }
 
        return(tatom);
 }
 

-
-
-/* this aux function is used by setsyntax to determine the new current
-   escape or double quote character.  It scans the character table for
-   the first character with the given class (either VESC or VDQ) and
-   puts that character in Xesc or Xdqc (whichever is pointed to by
-   addr).
-*/
+/*
+ * this aux function is used by setsyntax to determine the new current
+ * escape or double quote character.  It scans the character table for
+ * the first character with the given class (either VESC or VDQ) and
+ * puts that character in Xesc or Xdqc (whichever is pointed to by
+ * addr).
+ */

 rpltab(cclass,addr)
 char cclass;
 char *addr;
 rpltab(cclass,addr)
 char cclass;
 char *addr;


@@ -489,8 +568,6 @@ char *addr;
        else *addr = '\0';
 }
 
        else *addr = '\0';
 }
 

-
-

 lispval
 Lzapline()
 {
 lispval
 Lzapline()
 {


@@ -501,4 +578,3 @@ Lzapline()
        while (!feof(port) && (getc(port)!='\n') );
        return(nil);
 }
        while (!feof(port) && (getc(port)!='\n') );
        return(nil);
 }

-