BSD 4 release

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

diff --git a/usr/src/cmd/lisp/fex4.c b/usr/src/cmd/lisp/fex4.c
index da0b941..fc3472c 100644 (file)
--- a/usr/src/cmd/lisp/fex4.c
+++ b/usr/src/cmd/lisp/fex4.c
@@ -1,40 +1,53 @@
+static char *sccsid = "@(#)fex4.c      34.1 10/3/80";
+

 #include "global.h"
 #include "lfuncs.h"
 #include "chkrtab.h"
 #include <signal.h>
 
 #include "global.h"
 #include "lfuncs.h"
 #include "chkrtab.h"
 #include <signal.h>
 

+/* this is now a lambda function instead of a nlambda.
+   the only reason that it wasn't a lambda to begin with is that 
+   the person who wrote it didn't know how to write a lexpr
+                                               - jkf
+*/

 lispval
 lispval

-Nsyscall() {
-       register lispval aptr, temp;
+Lsyscall() {
+       register lispval temp;
+       register struct argent *aptr;

        register int acount = 0;
        int args[50];
        snpand(3);
 
        register int acount = 0;
        int args[50];
        snpand(3);
 

-       aptr = lbot->val;
-       temp = eval(aptr->car);
+       /* there must be at least one argument */
+
+       if (np==lbot) { chkarg(1,"syscall"); }
+
+       aptr = lbot;
+       temp = lbot->val;

        if (TYPE(temp) != INT)
        if (TYPE(temp) != INT)

-               return(error("syscall", FALSE));
+               return(error("syscall: bad first argument ", FALSE));

        args[acount++] = temp->i;
        args[acount++] = temp->i;

-       aptr = aptr->cdr;
-       while( aptr != nil && acount < 49) {
-               temp = eval(aptr->car);
+       while( ++aptr < np && acount < 49) {
+               temp = aptr->val;

                switch(TYPE(temp)) {
 
                        case ATOM:      
                                args[acount++] = (int)temp->a.pname;
                                break;
 
                switch(TYPE(temp)) {
 
                        case ATOM:      
                                args[acount++] = (int)temp->a.pname;
                                break;
 

+                       case STRNG:
+                               args[acount++] = (int) temp;
+                               break;
+

                        case INT:
                                args[acount++] = (int)temp->i;
                                break;
 
                        default:
                        case INT:
                                args[acount++] = (int)temp->i;
                                break;
 
                        default:

-                               return(error("syscall", FALSE));
+                               return(error("syscall: arg not symbol, string or fixnum", FALSE));

                }
                }

-               aptr = aptr->cdr;

        }
 
        }
 

-       if (acount==0) chkarg(2);       /* produce arg count message */

        temp = newint();
        temp->i = vsyscall(args);
        return(temp);
        temp = newint();
        temp->i = vsyscall(args);
        return(temp);


@@ -52,9 +65,9 @@ Nevwhen()
        register lispval handy;
        snpand(1);
 
        register lispval handy;
        snpand(1);
 

-       for(handy=(lbot->val)->car ; handy != nil ; handy = handy->cdr)
-          if (handy->car == (lispval) Veval) { lbot=np ;
-                                               protect(((lbot-1)->val)->cdr);
+       for(handy=(lbot->val)->d.car ; handy != nil ; handy = handy->d.cdr)
+          if (handy->d.car == (lispval) Veval) { lbot=np ;
+                                               protect(((lbot-1)->val)->d.cdr);

                                                return(Nprogn()); } ;
 
 
                                                return(Nprogn()); } ;
 
 


@@ -89,6 +102,7 @@ Nevwhen()
  *     ST_NFETR - used in (status nofeature xxx) where we test for xxx not
  *               being in the status features list
  *     ST_DMPR - read the dumpmode 
  *     ST_NFETR - used in (status nofeature xxx) where we test for xxx not
  *               being in the status features list
  *     ST_DMPR - read the dumpmode 

+ *     ST_UNDEF - return the undefined functions in the transfer table

  * 
  * Setcodes:
  *     ST_NO -  if not allowed to set this status through sstatus.
  * 
  * Setcodes:
  *     ST_NO -  if not allowed to set this status through sstatus.


@@ -102,44 +116,51 @@ Nevwhen()
  *     ST_NFETW - use in (sstatus nofeature xxx) where we wish to remove xxx
  *                from the status feature list.
  *     ST_DMPW - set the dumpmode
  *     ST_NFETW - use in (sstatus nofeature xxx) where we wish to remove xxx
  *                from the status feature list.
  *     ST_DMPW - set the dumpmode

+ *     ST_BCDTR - (ifdef RSET) if non nil, creat trace stack entries for
+ *                calls from BCD functions to BCD functions

  */
  */

-
+#include <time.h>

 
 lispval
 Nstatus()
 {
        register lispval handy,curitm,valarg;
 
 lispval
 Nstatus()
 {
        register lispval handy,curitm,valarg;

-       int indx;
+       int indx,ctim;

        int typ;
        int typ;

+       char *cp;
+       char *ctime();
+       struct tm *lctime,*localtime();

        extern char *ctable;
        extern int dmpmode;
        extern char *ctable;
        extern int dmpmode;

+       extern lispval chktt();

        lispval Istsrch();
        lispval Istsrch();

+       snpand(3);

 
        if(lbot->val == nil) return(nil);
        handy = lbot->val;              /* arg list */
 
        while(TYPE(handy) != DTPR) handy = error("status: bad arg list",TRUE); 
        
 
        if(lbot->val == nil) return(nil);
        handy = lbot->val;              /* arg list */
 
        while(TYPE(handy) != DTPR) handy = error("status: bad arg list",TRUE); 
        

-       curitm = Istsrch(handy->car);   /* look for feature */
+       curitm = Istsrch(handy->d.car); /* look for feature */

 
        if( curitm == nil ) return(nil);        /* non existant */
 
 
        if( curitm == nil ) return(nil);        /* non existant */
 

-       if( handy->cdr == nil ) valarg = (lispval) CNIL;
-       else valarg = handy->cdr->car;
+       if( handy->d.cdr == nil ) valarg = (lispval) CNIL;
+       else valarg = handy->d.cdr->d.car;

 
        /* now do the processing with curitm pointing to the requested
           item in the status list 
         */
        
 
        /* now do the processing with curitm pointing to the requested
           item in the status list 
         */
        

-       switch( typ = curitm->cdr->car->i ) {           /* look at readcode */
+       switch( typ = curitm->d.cdr->d.car->i ) {               /* look at readcode */

 
 
        case ST_READ:
 
 
        case ST_READ:

-               curitm = Istsrch(handy->car);   /* look for name */
+               curitm = Istsrch(handy->d.car); /* look for name */

                if(curitm == nil) return(nil);
                if( valarg != (lispval) CNIL) 
                    error("status: Second arg not allowed.",FALSE);
                if(curitm == nil) return(nil);
                if( valarg != (lispval) CNIL) 
                    error("status: Second arg not allowed.",FALSE);

-               else return(curitm->cdr->cdr->cdr);
+               else return(curitm->d.cdr->d.cdr->d.cdr);

 
        case ST_NFETR:                          /* look for feature present */
        case ST_FEATR:                          /* look for feature */
 
        case ST_NFETR:                          /* look for feature present */
        case ST_FEATR:                          /* look for feature */


@@ -147,16 +168,16 @@ Nstatus()
                if( valarg == (lispval) CNIL) 
                    error("status: need second arg",FALSE);
 
                if( valarg == (lispval) CNIL) 
                    error("status: need second arg",FALSE);
 

-               for( handy = curitm->cdr->cdr->cdr;
+               for( handy = curitm->d.cdr->d.cdr->d.cdr;

                     handy != nil;
                     handy != nil;

-                    handy = handy->cdr)
-                  if(handy->car == valarg) 
+                    handy = handy->d.cdr)
+                  if(handy->d.car == valarg) 

                         return(typ == ST_FEATR ? tatom : nil);
                
                return(typ == ST_FEATR ? nil : tatom);
 
                         return(typ == ST_FEATR ? tatom : nil);
                
                return(typ == ST_FEATR ? nil : tatom);
 

-       case ST_SYNT:                           /* want characcter syntax */
-               handy = Vreadtable->clb;
+       case ST_SYNT:                           /* want character syntax */
+               handy = Vreadtable->a.clb;

                chkrtab(handy);
                if( valarg == (lispval) CNIL)
                        error("status: need second arg",FALSE);
                chkrtab(handy);
                if( valarg == (lispval) CNIL)
                        error("status: need second arg",FALSE);


@@ -164,20 +185,54 @@ Nstatus()
                while (TYPE(valarg) != ATOM) 
                    valarg = error("status: second arg must be atom",TRUE);
                
                while (TYPE(valarg) != ATOM) 
                    valarg = error("status: second arg must be atom",TRUE);
                

-               indx = valarg->pname[0];        /* get first char */
+               indx = valarg->a.pname[0];      /* get first char */

 
 

-               if(valarg->pname[1] != '\0')
+               if(valarg->a.pname[1] != '\0')

                        error("status: only one character atom allowed",FALSE);
 
                        error("status: only one character atom allowed",FALSE);
 

-               (handy = newint())->i = ctable[indx] & 0377;
+               handy = inewint(ctable[indx] & 0377);

                return(handy);
 
        case ST_RINTB:
                return(handy);
 
        case ST_RINTB:

-               return(stattab[curitm->cdr->cdr->cdr->i]);
+               return(stattab[curitm->d.cdr->d.cdr->d.cdr->i]);

 
        case ST_DMPR:
                return(inewint(dmpmode));
                
 
        case ST_DMPR:
                return(inewint(dmpmode));
                

+       case ST_CTIM:
+                ctim = time(0);
+                cp = ctime(&ctim);
+                cp[24] = '\0';
+                return(matom(cp));
+
+       case ST_LOCT:
+                ctim = time(0);
+                lctime = localtime(&ctim);
+                (handy = newdot())->d.car = inewint(lctime->tm_sec);
+                protect(handy);
+                handy->d.cdr =  (valarg = newdot());
+                valarg->d.car = inewint(lctime->tm_min);
+                valarg->d.cdr = (curitm = newdot());
+                curitm->d.car = inewint(lctime->tm_hour);
+                curitm->d.cdr = (valarg = newdot());
+                valarg->d.car = inewint(lctime->tm_mday);
+                valarg->d.cdr = (curitm = newdot());
+                curitm->d.car = inewint(lctime->tm_mon);
+                curitm->d.cdr = (valarg = newdot());
+                valarg->d.car = inewint(lctime->tm_year);
+                valarg->d.cdr = (curitm = newdot());
+                curitm->d.car = inewint(lctime->tm_wday);
+                curitm->d.cdr = (valarg = newdot());
+                valarg->d.car = inewint(lctime->tm_yday);
+                valarg->d.cdr = (curitm = newdot());
+                valarg->d.car = inewint(lctime->tm_isdst);
+                return(handy);
+
+       case ST_ISTTY:
+               return( (isatty(0) == TRUE ? tatom : nil));
+
+       case ST_UNDEF:
+               return(chktt());

        }
 }
 lispval
        }
 }
 lispval


@@ -188,10 +243,10 @@ Nsstatus()
 
        handy = lbot->val;
 
 
        handy = lbot->val;
 

-       while( TYPE(handy) != DTPR || TYPE(handy->cdr) != DTPR)
+       while( TYPE(handy) != DTPR || TYPE(handy->d.cdr) != DTPR)

             handy = error("sstatus: Bad args",TRUE);
        
             handy = error("sstatus: Bad args",TRUE);
        

-       return(Isstatus(handy->car,handy->cdr->car));
+       return(Isstatus(handy->d.car,handy->d.cdr->d.car));

 }
 
 /* Isstatus - internal routine to do a set status.     */
 }
 
 /* Isstatus - internal routine to do a set status.     */


@@ -201,31 +256,31 @@ lispval curnam,curval;
 {
        register lispval curitm,head;
        lispval Istsrch(),Iaddstat();
 {
        register lispval curitm,head;
        lispval Istsrch(),Iaddstat();

-       int badmemr();
-       extern int uctolc, dmpmode;
+       int badmemr(),clrtt();
+       extern int uctolc, dmpmode, bcdtrsw;

 
        curitm = Istsrch(curnam);
        /* if doesnt exist, make one up */
 
        if(curitm == nil) curitm = Iaddstat(curnam,ST_READ,ST_SET,nil);
 
 
        curitm = Istsrch(curnam);
        /* if doesnt exist, make one up */
 
        if(curitm == nil) curitm = Iaddstat(curnam,ST_READ,ST_SET,nil);
 

-       switch (curitm->cdr->cdr->car->i) {
+       switch (curitm->d.cdr->d.cdr->d.car->i) {

 
        case ST_NO: error("sstatus: cannot set this status",FALSE);
 
        case ST_SET: goto setit;
 
        case ST_FEATW: curitm = Istsrch(matom("features"));
 
        case ST_NO: error("sstatus: cannot set this status",FALSE);
 
        case ST_SET: goto setit;
 
        case ST_FEATW: curitm = Istsrch(matom("features"));

-                     (curnam = newdot())->car = curval;
-                     curnam->cdr = curitm->cdr->cdr->cdr;      /* old val */
-                     curitm->cdr->cdr->cdr = curnam;
+                     (curnam = newdot())->d.car = curval;
+                     curnam->d.cdr = curitm->d.cdr->d.cdr->d.cdr;      /* old val */
+                     curitm->d.cdr->d.cdr->d.cdr = curnam;

                      return(curval);
 
        case ST_NFETW:  /* remove from features list */
                      return(curval);
 
        case ST_NFETW:  /* remove from features list */

-                     curitm = Istsrch(matom("features"))->cdr->cdr;
-                     for(head = curitm->cdr; head != nil; head = head->cdr)
+                     curitm = Istsrch(matom("features"))->d.cdr->d.cdr;
+                     for(head = curitm->d.cdr; head != nil; head = head->d.cdr)

                      {
                      {

-                          if(head->car == curval) curitm->cdr = head->cdr;
+                          if(head->d.car == curval) curitm->d.cdr = head->d.cdr;

                           else curitm = head;
                      }
                      return(nil);
                           else curitm = head;
                      }
                      return(nil);


@@ -247,7 +302,7 @@ lispval curnam,curval;
                      goto setit;
 
        case ST_INTB: 
                      goto setit;
 
        case ST_INTB: 

-                     stattab[curitm->cdr->cdr->cdr->i] = curval;
+                     stattab[curitm->d.cdr->d.cdr->d.cdr->i] = curval;

                      return(curval);
 
        case ST_DMPW:   
                      return(curval);
 
        case ST_DMPW:   


@@ -257,10 +312,34 @@ lispval curnam,curval;
                                                  nil,FALSE,0,curval);
                      dmpmode= curval->i;       
                      return(curval);
                                                  nil,FALSE,0,curval);
                      dmpmode= curval->i;       
                      return(curval);

+
+        case ST_AUTR:
+                     if(curval != nil) Sautor = (lispval) TRUE;
+                     else Sautor = FALSE;
+                     goto setit;
+                       
+        case ST_TRAN:
+                     if(curval != nil) 
+                     {     
+                            Strans = (lispval) TRUE;
+                            /* the atom `on' set to set up all table
+                             * to their bcd fcn if possible
+                             */
+                            if(curval == matom("on")) clrtt(1);
+                     } 
+                     else { 
+                            Strans = (lispval) FALSE;
+                            clrtt(0);  /* clear all transfer tables */
+                     }
+                     goto setit;
+       case ST_BCDTR:
+                     if(curval == nil) bcdtrsw = FALSE;
+                     else bcdtrsw = TRUE;
+                     goto setit;

        }
 
     setit:           /* store value in status list */
        }
 
     setit:           /* store value in status list */

-                     curitm->cdr->cdr->cdr = curval;
+                     curitm->d.cdr->d.cdr->d.cdr = curval;

                      return(curval);
 
 
                      return(curval);
 
 


@@ -276,8 +355,8 @@ lispval nam;
 {
        register lispval handy; 
 
 {
        register lispval handy; 
 

-       for(handy = stlist ; handy != nil ; handy = handy->cdr)
-         if(handy->car->car == nam) return(handy->car);
+       for(handy = stlist ; handy != nil ; handy = handy->d.cdr)
+         if(handy->d.car->d.car == nam) return(handy->d.car);

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


@@ -296,22 +375,22 @@ int readcode,setcode;
 
        protect(handy=newdot());        /* build status list here */
 
 
        protect(handy=newdot());        /* build status list here */
 

-       (handy2 = newdot())->car = name;
+       (handy2 = newdot())->d.car = name;

 
 

-       handy->car = handy2;
+       handy->d.car = handy2;

 
 

-       ((handy2->cdr = newdot())->car = newint())->i = readcode;
+       ((handy2->d.cdr = newdot())->d.car = newint())->i = readcode;

 
 

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

 
 

-       ((handy2->cdr = newdot())->car = newint())->i = setcode;
+       ((handy2->d.cdr = newdot())->d.car = newint())->i = setcode;

 
 

-       handy2->cdr->cdr = valu;
+       handy2->d.cdr->d.cdr = valu;

 
        /* link this one in */
 
 
        /* link this one in */
 

-       handy->cdr = stlist;    
+       handy->d.cdr = stlist;  

        stlist = handy;
 
        stlist = handy;
 

-       return(handy->car);     /* return new item in stlist */
+       return(handy->d.car);   /* return new item in stlist */

 }
 }