BSD 4 release

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

diff --git a/usr/src/cmd/lisp/lam2.c b/usr/src/cmd/lisp/lam2.c
index 85607b1..c136a69 100644 (file)
--- a/usr/src/cmd/lisp/lam2.c
+++ b/usr/src/cmd/lisp/lam2.c
@@ -1,7 +1,11 @@
+static char *sccsid = "@(#)lam2.c      34.1 10/3/80";
+

 # include "global.h"
 # include "global.h"

+# include <signal.h>

 /*
 /*

- * (flatsize thing max) returns the smaller of max and the number of chars
+ * (flatc thing max) returns the smaller of max and the number of chars

  * required to print thing linearly.
  * required to print thing linearly.

+ * if max argument is not given, we assume the second arg is infinity

  */
 static flen; /*Internal to this module, used as a running counter of flatsize*/
 static fmax; /*used for maximum for quick reference */
  */
 static flen; /*Internal to this module, used as a running counter of flatsize*/
 static fmax; /*used for maximum for quick reference */


@@ -13,15 +17,16 @@ Lflatsi()
        register struct argent *mylbot = lbot;
        snpand(3); /* fixup entry mask */
 
        register struct argent *mylbot = lbot;
        snpand(3); /* fixup entry mask */
 

-       chkarg(2);
-       flen = 0; fmax = mylbot[1].val->i;
+       if( np-lbot == 1) fmax = 0x7fffffff;    /* biggest integer */
+       else fmax = mylbot[1].val->i;
+       flen = 0; 

        current = mylbot->val;
        protect(nil);                   /*create space for argument to pntlen*/
        Iflatsi(current);
        return(inewint(flen));
 }
 /*
        current = mylbot->val;
        protect(nil);                   /*create space for argument to pntlen*/
        Iflatsi(current);
        return(inewint(flen));
 }
 /*

- * Iflatsi does the real work of the calculation for flatsize
+ * Iflatsi does the real work of the calculation for flatc

  */
 Iflatsi(current)
 register lispval current;
  */
 Iflatsi(current)
 register lispval current;


@@ -33,7 +38,7 @@ register lispval current;
        switch(TYPE(current)) {
 
        patom:
        switch(TYPE(current)) {
 
        patom:

-       case INT: case ATOM: case DOUB:
+       case INT: case ATOM: case DOUB: case STRNG:

                np[-1].val = current;
                flen += Ipntlen();
                return;
                np[-1].val = current;
                flen += Ipntlen();
                return;


@@ -41,8 +46,8 @@ register lispval current;
        pthing:
        case DTPR:
                flen++;
        pthing:
        case DTPR:
                flen++;

-               Iflatsi(current->car);
-               current = current->cdr;
+               Iflatsi(current->d.car);
+               current = current->d.cdr;

                if(current == nil) {
                        flen++;
                        return;
                if(current == nil) {
                        flen++;
                        return;


@@ -74,6 +79,7 @@ Lreadc()
 { return (r(EADC)); }
 
 #include "chars.h"
 { return (r(EADC)); }
 
 #include "chars.h"

+#include "chkrtab.h"

 
 extern char *ctable;
 /* r *********************************************************************/
 
 extern char *ctable;
 /* r *********************************************************************/


@@ -89,11 +95,20 @@ int op;
        struct nament *oldbnp = bnp;
        snpand(2);
 
        struct nament *oldbnp = bnp;
        snpand(2);
 

-       chkarg(2);
-       result = Vreadtable->clb;
+       switch(np-lbot) {
+       case 0:
+               protect(nil);
+       case 1:
+               protect(nil);
+       case 2: break;
+       default:
+               argerr("read or ratom or readc");
+       }
+       result = Vreadtable->a.clb;
+       chkrtab(result);

        orlevel = rlevel;
        rlevel = 0;
        orlevel = rlevel;
        rlevel = 0;

-       ttemp = okport(Vpiport->clb,stdin);
+       ttemp = okport(Vpiport->a.clb,stdin);

        ttemp = okport(lbot->val,ttemp);
 /*printf("entering switch\n");*/
        fflush(stdout);         /* flush any pending characters */
        ttemp = okport(lbot->val,ttemp);
 /*printf("entering switch\n");*/
        fflush(stdout);         /* flush any pending characters */


@@ -101,7 +116,7 @@ int op;
        switch (op)
        {
        case EADC:      rlevel = orlevel;
        switch (op)
        {
        case EADC:      rlevel = orlevel;

-                       switch (ctable[c = getc(ttemp)] & 0377)
+                       switch (ctable[c = getc(ttemp) & 0177] & 0377)

                        {
                        case VEOF:
                                return(lbot[1].val);
                        {
                        case VEOF:
                                return(lbot[1].val);


@@ -118,7 +133,10 @@ int op;
        case EAD:       PUSHDOWN(Vpiport,P(ttemp)); /* rebind Vpiport */
                        result = readr(ttemp);
        out:            if(result==eofa)
        case EAD:       PUSHDOWN(Vpiport,P(ttemp)); /* rebind Vpiport */
                        result = readr(ttemp);
        out:            if(result==eofa)

-                               result = lbot[1].val;
+                       {    
+                            if(sigintcnt > 0) sigcall(SIGINT);
+                            result = lbot[1].val;
+                       }

                        rlevel = orlevel;
                        popnames(oldbnp);       /* unwind bindings */
                        return(result);
                        rlevel = orlevel;
                        popnames(oldbnp);       /* unwind bindings */
                        return(result);


@@ -134,20 +152,24 @@ lispval
 Lload()
 {
        register FILE *port;
 Lload()
 {
        register FILE *port;

-       register char *p; register lispval ttemp, vtemp;
+       register char *p, *ttemp; register lispval vtemp;

        register struct argent *lbot, *np;
        struct nament *oldbnp = bnp;
        register struct argent *lbot, *np;
        struct nament *oldbnp = bnp;

-       int orlevel;
+       int orlevel,typ;

        char longname[100];
        char *shortname, *end2;
 
        char longname[100];
        char *shortname, *end2;
 

-       chkarg(1);
-       ttemp = lbot->val;
-       if(TYPE(ttemp)!=ATOM) return(error("FILENAME MUST BE ATOMIC",FALSE));
+       chkarg(1,"load");
+       if((typ = TYPE(lbot->val)) == ATOM)
+           ttemp =  lbot->val->a.pname ;  /* ttemp will point to name */
+       else if(typ == STRNG)
+           ttemp = (char *) lbot->val;
+       else 
+            return(error("FILENAME MUST BE ATOMIC",FALSE));

        strcpy(longname,"/usr/lib/lisp/" );
        for(p = longname; *p; p++);
                shortname = p;
        strcpy(longname,"/usr/lib/lisp/" );
        for(p = longname; *p; p++);
                shortname = p;

-       strcpy(p,ttemp->pname);
+       strcpy(p,ttemp);

        for(; *p; p++);
                end2 = p;
        strcpy(p,".l");
        for(; *p; p++);
                end2 = p;
        strcpy(p,".l");


@@ -156,13 +178,14 @@ Lload()
                        *end2 = 0;
                        if ((port = fopen(shortname,"r")) == NULL &&
                                (port = fopen(longname, "r")) == NULL)
                        *end2 = 0;
                        if ((port = fopen(shortname,"r")) == NULL &&
                                (port = fopen(longname, "r")) == NULL)

-                                       error("CAN'T OPEN FILE", FALSE);
+                                       errorh(Vermisc,"Can't open file: ", 
+                                                    nil,FALSE,0,lbot->val);

        }
        orlevel = rlevel;
        rlevel = 0;
 
        if(ISNIL(copval(gcload,CNIL)) &&
        }
        orlevel = rlevel;
        rlevel = 0;
 
        if(ISNIL(copval(gcload,CNIL)) &&

-               loading->clb != tatom &&
+               loading->a.clb != tatom &&

                ISNIL(copval(gcdis,CNIL)))
                gc(CNIL);       /*  do a gc if gc will be off  */
 
                ISNIL(copval(gcdis,CNIL)))
                gc(CNIL);       /*  do a gc if gc will be off  */
 


@@ -197,6 +220,7 @@ Iconcat(unintern)
                                sense calculated by newstr          */
        int i;
        lispval cur;
                                sense calculated by newstr          */
        int i;
        lispval cur;

+       char lstrbf[200];       /* local string buffer needed if sdot seen */

        snpand(2);
 
        atmlen = 0 ;    
        snpand(2);
 
        atmlen = 0 ;    


@@ -212,6 +236,10 @@ Iconcat(unintern)
                 strcpy(&strbuf[atmlen], ((struct atom *) cur) -> pname) ;
                 break;
 
                 strcpy(&strbuf[atmlen], ((struct atom *) cur) -> pname) ;
                 break;
 

+           case STRNG:
+                strcpy(&strbuf[atmlen], cur);
+                break;
+

            case INT:
                 sprintf(&strbuf[atmlen],"%d",cur->i);
                 break;
            case INT:
                 sprintf(&strbuf[atmlen],"%d",cur->i);
                 break;


@@ -220,6 +248,19 @@ Iconcat(unintern)
                 sprintf(&strbuf[atmlen],"%f",cur->f);
                 break;
 
                 sprintf(&strbuf[atmlen],"%f",cur->f);
                 break;
 

+           case SDOT:
+                if(atmlen > 200) error("concat: string buffer overflow",FALSE);
+                strcpy(lstrbf,strbuf);  /* save around explode */
+                lbot = np;
+                protect(cur);          /* must explode */
+                cur= Lexplda();
+                np = lbot;
+                strcpy(strbuf,lstrbf);
+                for( ; cur != nil ; cur = cur->d.cdr)
+                  strbuf[atmlen++] = cur->d.car->a.pname[0]; 
+                strbuf[atmlen] = '\0';
+                break;
+                   

            default:
                 cur = error("Non atom or number to concat",TRUE);
                 goto loop;    /* if returns value, try it */
            default:
                 cur = error("Non atom or number to concat",TRUE);
                 goto loop;    /* if returns value, try it */


@@ -248,7 +289,7 @@ Lputprop()
        register struct argent *argp = lbot;
        lispval Iputprop();
        snpand(1);
        register struct argent *argp = lbot;
        lispval Iputprop();
        snpand(1);

-       chkarg(3);
+       chkarg(3,"putprop");

        return(Iputprop(argp->val,argp[1].val,argp[2].val));
 }
 
        return(Iputprop(argp->val,argp[1].val,argp[2].val));
 }
 


@@ -263,34 +304,34 @@ register lispval prop, ind, atm;
        switch (TYPE(atm)) {
        case ATOM:
                if(atm == nil) tack = &nilplist;
        switch (TYPE(atm)) {
        case ATOM:
                if(atm == nil) tack = &nilplist;

-               else tack =  &(atm->plist);
+               else tack =  &(atm->a.plist);

                break;
        case DTPR:
                break;
        case DTPR:

-               for (pptr = atm->cdr ; pptr != nil ; pptr = pptr->cdr->cdr)
-                   if(TYPE(pptr) != DTPR || TYPE(pptr->cdr) != DTPR) break;
+               for (pptr = atm->d.cdr ; pptr != nil ; pptr = pptr->d.cdr->d.cdr)
+                   if(TYPE(pptr) != DTPR || TYPE(pptr->d.cdr) != DTPR) break;

                if(pptr != nil) 
                {   atm = errorh(Vermisc,
                                 "putprop: bad disembodied property list",
                                 nil,TRUE,0,atm);
                    goto top;
                }
                if(pptr != nil) 
                {   atm = errorh(Vermisc,
                                 "putprop: bad disembodied property list",
                                 nil,TRUE,0,atm);
                    goto top;
                }

-               tack = (lispval *) &(atm->cdr);
+               tack = (lispval *) &(atm->d.cdr);

                break;
        default:
                errorh(Vermisc,"putprop: Bad first argument: ",nil,FALSE,0,atm);
        }
        pptr = *tack;   /* start of property list */
        findit:
                break;
        default:
                errorh(Vermisc,"putprop: Bad first argument: ",nil,FALSE,0,atm);
        }
        pptr = *tack;   /* start of property list */
        findit:

-       for (pptr = *tack ; pptr != nil ; pptr = pptr->cdr->cdr)
-               if (pptr->car == ind) {
-                       (pptr->cdr)->car = prop;
+       for (pptr = *tack ; pptr != nil ; pptr = pptr->d.cdr->d.cdr)
+               if (pptr->d.car == ind) {
+                       (pptr->d.cdr)->d.car = prop;

                        return(prop);
                }
                        return(prop);
                }

-               else tack = &(pptr->cdr->cdr) ;
+               else tack = &(pptr->d.cdr->d.cdr) ;

        *tack = pptr = newdot();
        *tack = pptr = newdot();

-       pptr->car = ind;
-       pptr = pptr->cdr = (lispval) newdot();
-       pptr->car = prop;
+       pptr->d.car = ind;
+       pptr = pptr->d.cdr = (lispval) newdot();
+       pptr->d.car = prop;

        return(prop);
 }
 
        return(prop);
 }
 


@@ -311,27 +352,27 @@ Lget()
        lispval Igetplist();
        snpand(2);
 
        lispval Igetplist();
        snpand(2);
 

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

        ind = lbot[1].val;
        atm = lbot[0].val;
 top:
        switch(TYPE(atm)) {
        case ATOM:
                if(atm==nil) atm = nilplist;
        ind = lbot[1].val;
        atm = lbot[0].val;
 top:
        switch(TYPE(atm)) {
        case ATOM:
                if(atm==nil) atm = nilplist;

-               else atm = atm->plist;
+               else atm = atm->a.plist;

                break;          
 
        case DTPR:
                break;          
 
        case DTPR:

-               for (dum1 = atm->cdr; dum1 != nil; dum1 = dum1->cdr->cdr)
+               for (dum1 = atm->d.cdr; dum1 != nil; dum1 = dum1->d.cdr->d.cdr)

                    if((TYPE(dum1) != DTPR) || 
                    if((TYPE(dum1) != DTPR) || 

-                      (TYPE(dum1->cdr) != DTPR)) break; /* bad prop list */
+                      (TYPE(dum1->d.cdr) != DTPR)) break; /* bad prop list */

                if(dum1 != nil) 
                {   atm = errorh(Vermisc,
                if(dum1 != nil) 
                {   atm = errorh(Vermisc,

-                                "putprop: bad disembodied property list",
+                                "get: bad disembodied property list",

                                 nil,TRUE,0,atm);
                    goto top;
                }
                                 nil,TRUE,0,atm);
                    goto top;
                }

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

                break;
        default:
                /* remove since maclisp doesnt treat
                break;
        default:
                /* remove since maclisp doesnt treat


@@ -341,7 +382,14 @@ top:
                 */
                 return(nil);
        }
                 */
                 return(nil);
        }

-       return(Igetplist(atm,ind));
+
+       while (atm != nil)
+               {
+                       if (atm->d.car == ind)
+                               return ((atm->d.cdr)->d.car);
+                       atm = (atm->d.cdr)->d.cdr;
+               }
+       return(nil);

 }
 /*
  * Iget - the first arg must be a symbol.
 }
 /*
  * Iget - the first arg must be a symbol.


@@ -356,7 +404,7 @@ register lispval atm, ind;
        if(atm==nil)
                atm = nilplist;
        else
        if(atm==nil)
                atm = nilplist;
        else

-               atm = atm->plist;
+               atm = atm->a.plist;

        return(Igetplist(atm,ind));
 }
 
        return(Igetplist(atm,ind));
 }
 


@@ -372,9 +420,9 @@ register lispval pptr,ind;
 {
        while (pptr != nil)
                {
 {
        while (pptr != nil)
                {

-                       if (pptr->car == ind)
-                               return ((pptr->cdr)->car);
-                       pptr = (pptr->cdr)->cdr;
+                       if (pptr->d.car == ind)
+                               return ((pptr->d.cdr)->d.car);
+                       pptr = (pptr->d.cdr)->d.cdr;

                }
        return(nil);
 }
                }
        return(nil);
 }


@@ -384,7 +432,7 @@ Lgetd()
        register lispval typ;
        snpand(1);
        
        register lispval typ;
        snpand(1);
        

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

        typ = lbot->val;
        if (TYPE(typ) != ATOM) 
           errorh(Vermisc,
        typ = lbot->val;
        if (TYPE(typ) != ATOM) 
           errorh(Vermisc,


@@ -393,7 +441,7 @@ Lgetd()
                  FALSE,
                  0,
                  typ);
                  FALSE,
                  0,
                  typ);

-       return(typ->fnbnd);
+       return(typ->a.fnbnd);

 }
 lispval
 Lputd()
 }
 lispval
 Lputd()


@@ -403,11 +451,11 @@ Lputd()
        register struct argent *lbot, *np;
        snpand(2);
        
        register struct argent *lbot, *np;
        snpand(2);
        

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

        list = lbot[1].val;
        atom = lbot->val;
        if (TYPE(atom) != ATOM) error("ONLY ATOMS HAVE FUNCTION DEFINITIONS",FALSE);
        list = lbot[1].val;
        atom = lbot->val;
        if (TYPE(atom) != ATOM) error("ONLY ATOMS HAVE FUNCTION DEFINITIONS",FALSE);

-       atom->fnbnd = list;
+       atom->a.fnbnd = list;

        return(list);
 }
 
        return(list);
 }
 


@@ -454,21 +502,21 @@ int join;         /* 0 = the above, 1 = s/car/can/ */
                        temp = lists[index];
                        if(temp==nil) goto done;
 
                        temp = lists[index];
                        if(temp==nil) goto done;
 

-                       if(maptyp==0) (namptr++)->val = temp->car;
+                       if(maptyp==0) (namptr++)->val = temp->d.car;

                        else (namptr++)->val = temp;
 
                        else (namptr++)->val = temp;
 

-                       lists[index] = temp->cdr;
+                       lists[index] = temp->d.cdr;

                }
                if (join == 0) {
                        current->l = newdot();
                }
                if (join == 0) {
                        current->l = newdot();

-                       current->l->car = Lfuncal();
-                       current = (lispval) &current->l->cdr;
+                       current->l->d.car = Lfuncal();
+                       current = (lispval) &current->l->d.cdr;

                } else {
                        current->l = Lfuncal();
                        if ( TYPE ( current -> l) != DTPR && current->l != nil)
                                error("bad type returned from funcall inside map",FALSE);
                        else  while ( current -> l  != nil )
                } else {
                        current->l = Lfuncal();
                        if ( TYPE ( current -> l) != DTPR && current->l != nil)
                                error("bad type returned from funcall inside map",FALSE);
                        else  while ( current -> l  != nil )

-                                       current = (lispval) & (current ->l ->cdr);
+                                       current = (lispval) & (current ->l ->d.cdr);

                }
                np = last;
        }
                }
                np = last;
        }


@@ -542,10 +590,10 @@ int maptyp;               /* 0= mapc   , 1= map  */
                        if(temp==nil)
                                goto done;
                        if(maptyp==0)
                        if(temp==nil)
                                goto done;
                        if(maptyp==0)

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

                        else
                                (namptr++)->val = temp;
                        else
                                (namptr++)->val = temp;

-                       lists[index] = temp->cdr;
+                       lists[index] = temp->d.cdr;

                }
                Lfuncal();
        }
                }
                Lfuncal();
        }