BSD 3 development

Work on file usr/src/cmd/lisp/eval.c
Work on file usr/src/cmd/lisp/lam5.c
Work on file usr/src/cmd/lisp/lam8.c
Work on file usr/src/cmd/lisp/sysat.c

Synthesized-from: 3bsd

diff --git a/usr/src/cmd/lisp/eval.c b/usr/src/cmd/lisp/eval.c
new file mode 100644 (file)
index 0000000..93b0a83
--- /dev/null
+++ b/usr/src/cmd/lisp/eval.c
@@ -0,0 +1,517 @@
+#include "global.h"
+/************************************************************************/
+/*                                                                     */
+/*   file: eval.i                                                      */
+/*   contents: evaluator and namestack maintenance routines            */
+/*                                                                     */
+/************************************************************************/
+
+
+/* eval *****************************************************************/
+/* returns the value of the pointer passed as the argument.            */
+
+lispval
+eval(actarg)
+lispval actarg;
+{
+#define argptr handy
+       register lispval a = actarg;
+       register lispval handy;
+       register struct nament *namptr;
+       register struct argent *workp;
+       register struct argent *lbot;
+       register struct argent *np;
+       struct argent *poplbot;
+       struct nament *oldbnp = bnp;
+       lispval Ifcall(), Iarray();
+
+       /*debugging 
+       printf("Eval:");
+       printr(a,stdout);
+       fflush(stdout);  */
+       switch (TYPE(a))
+       {
+       case ATOM:
+               handy = a->clb;
+               if(handy==CNIL) {
+                       handy = errorh(Vermisc,"Unbound Variable:",nil,TRUE,0,a);
+               }
+               return(handy);
+
+       case VALUE:
+               return(a->l);
+
+       case DTPR:
+               (np++)->val = a;        /* push form on namestack */
+               lbot = np;              /* define beginning of argstack */
+               oldbnp = bnp;           /* remember start of bind stack */
+               a = a->car;             /* function name or lambda-expr */
+               for(EVER)
+                       {
+                       switch(TYPE(a))
+                               {
+                       case ATOM:
+                                       /*  get function binding  */
+                               if(a->fnbnd==nil && a->clb!=nil) {
+                                       a=a->clb;
+                                       if(TYPE(a)==ATOM)
+                                               a=a->fnbnd;
+                               } else
+                                       a = a->fnbnd;
+                               break;
+                       case VALUE:
+                               a = a->l;       /*  get value  */
+                               break;
+                               }
+
+                       vtemp = (CNIL-1);       /* sentinel value for error test */
+
+               funcal: switch (TYPE(a))
+                               {
+                       case BCD:       /* function */
+                               argptr = actarg->cdr;
+
+                               /* decide whether lambda, nlambda or
+                                  macro and push args onto argstack
+                                  accordingly.                         */
+
+                               if(a->discipline==nlambda) {
+                                       (np++)->val = argptr;
+                                       TNP;
+                               }else if(a->discipline==macro) {
+                                       (np++)->val = actarg;
+                                       TNP;
+                               } else for(;argptr!=nil; argptr = argptr->cdr) {
+                                       (np++)->val = eval(argptr->car);
+                                       TNP;
+                               }
+                               /* go for it */
+
+                               if(TYPE(a->discipline)==INT)
+                                       vtemp = Ifcall(a);
+                               else
+                                       vtemp = (*(lispval (*)())(a->entry))();
+                               break;
+
+                       case ARRAY:
+                               vtemp = Iarray(a,actarg->cdr);
+                               break;
+
+
+                       case DTPR:
+                                       /* push args on argstack according to
+                                          type                         */
+
+                               argptr = a->car;
+                               if (argptr==lambda) {
+                                       for(argptr = actarg->cdr;
+                                           argptr!=nil; argptr=argptr->cdr) {
+                                               
+                                               (np++)->val = eval(argptr->car);
+                                               TNP;
+                                       }
+                               } else if (argptr==nlambda) {
+                                       (np++)->val = actarg->cdr;
+                                       TNP;
+                               } else if(argptr==macro) {
+                                       (np++)->val = actarg;
+                                       TNP;
+                               } else if(argptr==lexpr) {
+                                       for(argptr = actarg->cdr;
+                                           argptr!=nil; argptr=argptr->cdr) {
+                                               
+                                               (np++)->val = eval(argptr->car);
+                                               TNP;
+                                       }
+                                       handy = newdot();
+                                       handy->car = (lispval)lbot;
+                                       handy->cdr = (lispval)np;
+                                       PUSHDOWN(lexpr_atom,handy);
+                                       lbot = np;
+                                       (np++)->val = inewint(((lispval *)handy->cdr) - (lispval *)handy->car);
+
+                               } else break;   /* something is wrong - this isn't a proper function */
+
+                               argptr = (a->cdr)->car;
+                               namptr =  bnp;
+                               workp = lbot;
+                               if(bnp + (np - lbot)> bnplim)
+                                       binderr();
+                               for(;argptr != (lispval)nil;
+                                    workp++,argptr = argptr->cdr)      /* rebind formal names (shallow) */
+                               {
+                                       if(argptr->car==nil)
+                                               continue;
+                                       /*if(((namptr)->atm = argptr->car)==nil)
+                                               error("Attempt to lambda bind nil",FALSE);*/
+                                       namptr->atm = argptr->car;
+                                       if (workp < np) {
+                                               namptr->val = namptr->atm->clb;
+                                               namptr->atm->clb = workp->val;
+                                       } else
+                                               bnp = namptr,
+                                               error("Too few actual parameters",FALSE);
+                                       namptr++;
+                               }
+                               bnp = namptr;
+                               if (workp < np)
+                                       error("Too many actual parameters",FALSE);
+
+                               /* execute body, implied prog allowed */
+
+                               for (handy = a->cdr->cdr;
+                                       handy != nil;
+                                       handy = handy->cdr) {
+                                               vtemp = eval(handy->car);
+                                       }
+                               }
+                       if (vtemp != (CNIL-1))
+                               /* if we get here with a believable value, */
+                               /* we must have executed a function. */
+                               {
+                               popnames(oldbnp);
+
+                               /* in case some clown trashed t */
+
+                               tatom->clb = (lispval) tatom;
+                               if(a->car==macro) return(eval(vtemp));
+                                       /* It is of the most wonderful 
+                                          coincidence that the offset
+                                          for car is the same as for
+                                          discipline so we get bcd macros
+                                          for free here ! */
+                               else return(vtemp);
+                               }
+                       popnames(oldbnp);
+                       a = (lispval) errorh(Vermisc,"BAD FUNCTION",nil,TRUE,0,actarg);
+                       }
+
+               }
+       return(a);      /* other data types are considered constants */
+       }
+
+
+
+
+/* popnames *************************************************************/
+/* removes from the name stack all entries above the first argument.   */
+/* routine should usually be used to clean up the name stack as it     */
+/* knows about the special cases.  np is returned pointing to the      */
+/* same place as the argument passed.                                  */
+lispval
+popnames(llimit)
+register struct nament *llimit;
+{
+       register struct nament *rnp;
+
+       for(rnp = bnp - 1; rnp >= llimit; rnp--)
+               rnp->atm->clb = rnp->val;
+       bnp = llimit;
+}
+
+
+/************************************************************************/
+/*                                                                     */
+/*   file: apply.c                                                     */
+/*     Caveat -- Work in Progress -- not guaranteed! not tested!
+/*                                                                     */
+/* apply  ***************************************************************/
+lispval
+Lapply()
+{
+       register lispval a;
+       register lispval handy;
+       register struct argent *workp;
+       register struct nament *namptr;
+       register struct argent *lbot;
+       register struct argent *np;
+       lispval vtemp;
+       struct nament *oldbnp = bnp;
+       struct argent *oldlbot = lbot; /* Bottom of my frame! */
+
+       a = lbot->val;
+       argptr = lbot[1].val;
+       if(np-lbot!=2)
+               errorh(Vermisc,"Apply: Wrong number of args.",nil,FALSE,
+                      999,a,argptr);
+       if(TYPE(argptr)!=DTPR && argptr!=nil)
+               argptr = errorh(Vermisc,"Apply: non-list of args",nil,TRUE,
+                               998,argptr);
+       (np++)->val = a;        /* push form on namestack */
+       TNP;
+       lbot = np;              /* bottom of current frame */
+       for(EVER)
+               {
+               if (TYPE(a) == ATOM) a = a->fnbnd;
+                       /* get function defn (unless calling form */
+                       /* is itself a lambda-expr) */
+               vtemp = CNIL;                   /* sentinel value for error test */
+               switch (TYPE(a))
+                       {
+               case BCD:       /* printf("BCD\n");*/
+                               /* push arguments - value of a */
+                       if(a->discipline==nlambda || a->discipline==macro) {
+                               (np++)->val=argptr;
+                               TNP;
+                       } else for (; argptr!=nil; argptr = argptr->cdr) {
+                               (np++)->val=argptr->car;
+                               TNP;
+                       }
+
+                       vtemp = (*(lispval (*)())(a->entry))(); /* go for it */
+                       break;
+
+               case ARRAY:
+                       vtemp = Iarray(a,argptr);
+                       break;
+
+
+               case DTPR:
+                       if (a->car==nlambda || a->car==macro) {
+                               (np++)->val = argptr;
+                               TNP;
+                       } else if (a->car==lambda)
+                               for (; argptr!=nil; argptr = argptr->cdr) {
+                                       (np++)->val = argptr->car;
+                                       TNP;
+                               }
+                       else if(a->car==lexpr) {
+                               for (; argptr!=nil; argptr = argptr->cdr) {
+                                       
+                                       (np++)->val = argptr->car;
+                                       TNP;
+                               }
+                               handy = newdot();
+                               handy->car = (lispval)lbot;
+                               handy->cdr = (lispval)np;
+                               PUSHDOWN(lexpr_atom,handy);
+                               lbot = np;
+                               (np++)->val = inewint(((lispval *)handy->cdr) - (lispval *)handy->car);
+
+                       } else break;   /* something is wrong - this isn't a proper function */
+                       rebind(a->cdr->car,lbot);
+                       np = lbot;
+                       for (handy = a->cdr->cdr;
+                               handy != nil;
+                               handy = handy->cdr) {
+                                       vtemp = eval(handy->car);       /* go for it */
+                               }
+                       }
+               if (vtemp != CNIL)
+                       /* if we get here with a believable value, */
+                       /* we must have executed a function. */
+                       {
+                       popnames(oldbnp);
+
+                       /* in case some clown trashed t */
+
+                       tatom->clb = (lispval) tatom;
+                       return(vtemp);
+                       }
+               popnames(oldbnp);
+               printr(oldlbot->val,stdout);
+               a = (lispval) error("BAD FUNCTION",TRUE);
+       }
+       /*NOT REACHED*/
+}
+
+
+/*
+ * Rebind -- rebind formal names
+ */
+rebind(argptr,workp)
+register lispval argptr;               /* argptr points to list of atoms */
+register struct argent * workp;                /* workp points to position on stack
+                                          where evaluated args begin */
+{
+       register lispval vtemp;
+       register struct nament *namptr = bnp;
+       register struct argent *lbot;
+       register struct argent *np;
+
+       for(;argptr != (lispval)nil;
+            workp++,argptr = argptr->cdr)  /* rebind formal names (shallow) */
+       {
+               if(argptr->car==nil)
+                       continue;
+               namptr->atm = argptr->car;
+               if (workp < np) {
+                       namptr->val = namptr->atm->clb;
+                       namptr->atm->clb = workp->val;
+               } else
+                       bnp = namptr,
+                       error("Too few actual parameters",FALSE);
+               namptr++;
+               if(namptr > bnplim)
+                       binderr();
+       }
+       bnp = namptr;
+       if (workp < np)
+               error("Too many actual parameters",FALSE);
+}
+
+lispval
+Lfuncal()
+{
+       register lispval a;
+       register lispval handy; 
+       register struct argent *oldlbot;
+       register struct nament **namptr;
+       register struct argent *lbot;
+       register struct argent *np;
+
+       lispval Ifcall(),Llist(),Iarray();
+       lispval vtemp;
+       struct nament *oldbnp = bnp;
+       int typ;
+       extern lispval end[];
+
+       /*debugging stufff 
+       printf("In funcal: ");
+       printr(lbot->val,stdout);
+       fflush(stdout); 
+       printf("\n"); */
+
+       oldlbot = lbot;         /* bottom of my namestack frame */
+       a = lbot->val;          /* function I am evaling.       */
+       lbot++;
+
+       for(EVER)
+       {
+               typ = TYPE(a);
+               if (typ == ATOM) a = a->fnbnd, typ = TYPE(a);
+
+                       /* get function defn (unless calling form */
+                       /* is itself a lambda-expr) */
+               vtemp = CNIL;                   /* sentinel value for error test */
+               switch (typ) {
+               case ARRAY:
+                       vtemp = Iarray(a,Llist());
+                       break;
+               case BCD:
+                       if(a->discipline==nlambda)
+                           {   if(np==lbot) protect(nil);  /* default is nil */
+                               while(np-lbot!=1 || (lbot->val != nil &&
+                                                 TYPE(lbot->val)!=DTPR)) {
+                                       lbot->val = error("Bad funcall arg(s) to fexpr.",TRUE);
+                                       np = lbot+1;
+                                       }
+                           }
+                       /* go for it */
+
+                       if(TYPE(a->discipline)==INT)
+                               vtemp = Ifcall(a);
+                       else
+                               vtemp = (*(lispval (*)())(a->entry))();
+                       if(a->discipline==macro)
+                               vtemp = eval(vtemp);
+                       break;
+
+
+               case DTPR:
+                       if (a->car == lambda) {
+                               ;/* VOID */
+                       } else if (a->car == nlambda || a->car==macro) {
+                               if( np==lbot ) protect(nil);    /* default */
+                               while(np-lbot!=1 || (lbot->val != nil &&
+                                                 TYPE(lbot->val)!=DTPR)) {
+                                       lbot->val = error("Bad funcall arg(s) to fexpr.",TRUE);
+                                       np = lbot+1;
+                                       }
+                       } else if (a->car == lexpr) {
+                               handy = newdot();
+                               handy->car = (lispval) lbot;
+                               handy->cdr = (lispval) np;
+                               PUSHDOWN(lexpr_atom,handy);
+                               lbot = np;
+                               (np++)->val = inewint(((lispval *)handy->cdr) - (lispval *)handy->car);
+                       } else break;           /* something is wrong - this isn't a proper function */
+                       rebind(a->cdr->car,lbot);
+                       np = lbot;
+                       for (handy = a->cdr->cdr;
+                               handy != nil;
+                               handy = handy->cdr) {
+                                       vtemp = eval(handy->car);       /* go for it */
+                               }
+                       if(a->car==macro)
+                               vtemp = eval(vtemp);
+               }
+               if (vtemp != CNIL)
+                       /* if we get here with a believable value, */
+                       /* we must have executed a function. */
+                       {
+                       popnames(oldbnp);
+
+                       /* in case some clown trashed t */
+
+                       tatom->clb = (lispval) tatom;
+                       /*debugging
+                       if(a>(lispval) end){printf(" leaving:");
+                       printr(a,stdout);
+                       fflush(stdout);} */
+                       return(vtemp);
+                       }
+               popnames(oldbnp);
+               printr(oldlbot->val,stdout);
+               a = (lispval) error("BAD FUNCTION",TRUE);
+
+       }
+       /*NOT REACHED*/
+}
+
+/* protect **************************************************************/
+/* pushes the first argument onto namestack, thereby protecting from gc */
+lispval
+protect(a)
+lispval a;
+{
+       /* (np++)->val = a;
+          if (np >=  nplim)
+               namerr();
+        */
+       asm("   movl    4(ap),(r6)+");
+       asm("   cmpl    r6,_nplim");
+       asm("   jlss    out1");
+       asm("   calls   $0,_namerr");
+       asm("out1:      ret");
+       }
+
+
+/* unprot ****************************************************************/
+/* returns the top thing on the name stack.  Underflow had better not  */
+/* occur.                                                              */
+lispval
+unprot()
+       {
+       asm("   movl    -(r6),r0");
+       }
+
+lispval
+linterp()
+       {
+       error("BYTE INTERPRETER CALLED ERRONEOUSLY",FALSE);
+       }
+
+/* Undeff - called from qfuncl when it detects a call to a undefined
+       function from compiled code, we print out a message and
+       dont allow continuation
+*/
+lispval
+Undeff(atmn)
+lispval atmn;
+{
+       printf("\n%s - ",atmn->pname);
+       error("Undefined function called from compiled code",FALSE);
+}
+bindfix(firstarg)
+lispval firstarg;
+{
+       register lispval *argp = &firstarg;
+       register struct nament *mybnp = bnp;
+       while(*argp != nil) {
+               mybnp->atm = *argp++;
+               mybnp->val = mybnp->atm->clb;
+               mybnp->atm->clb = *argp++;
+               bnp = mybnp++;
+       }
+}

diff --git a/usr/src/cmd/lisp/lam5.c b/usr/src/cmd/lisp/lam5.c
new file mode 100644 (file)
index 0000000..8b21343
--- /dev/null
+++ b/usr/src/cmd/lisp/lam5.c
@@ -0,0 +1,430 @@
+#include "global.h"
+#include "chkrtab.h"
+
+/*===========================================
+-
+-      explode functions
+- The following function partially implement two explode functions,
+- explodec and exploden.  They only work for atom arguments.
+-
+-===========================================*/
+
+#include "chars.h"
+lispval
+Lexpldx(kind,slashify)
+int kind, slashify;    /* 0=explodec   1=exploden  */
+{
+       int typ, i;
+       char ch, *strb, strbb[BUFSIZ];  /* temporary string buffer */
+       register lispval last, handy;
+       char Idqc = Xdqc;
+       snpand(4); /* kludge register save mask */
+
+       chkarg(1);
+
+       handy = Vreadtable->clb;
+       chkrtab(handy);
+       handy = lbot->val;
+       *strbuf = 0;
+       typ=TYPE(handy);        /* we only work for a few types */
+
+
+       /* put the characters to return in the string buffer strb */
+
+       switch(typ) {
+       case STRNG:
+               strb = (char *) handy;
+               if(Xsdc)Idqc = Xsdc;
+               goto common;
+       case ATOM:
+               strb = handy->pname;
+               if(strb[0]==0) {
+                       strb = strbb;
+                       strbb[0] = Xdqc;
+                       strbb[1] = Xdqc;
+                       strbb[2] = 0;
+               } else
+       common:
+               if(slashify != 0)
+               {
+                       register char *cp, *out = strbb;
+                       cp = strb;
+                       strb = strbb;
+                       if(ctable[(*cp)&0177]==VNUM)
+                               *out++ = Xesc;
+                       for(; *cp; cp++)
+                       {
+                               if(ctable[*cp]& QUTMASK)
+                                       *out++ = Xesc;
+                               *out++ = *cp;
+                       }
+                       *out = 0;
+               }
+                               
+               break;
+       case INT:
+               strb = strbb;
+               sprintf(strb, "%d", lbot->val->i);
+               break;
+       case DOUB:
+               strb = strbb;
+               sprintf(strb, "%0.16G", lbot->val->r);
+               break;
+       case SDOT:
+       {
+               struct _iobuf _strbuf;
+               register count;
+               for((handy = lbot->val), count = 12;
+                   handy->CDR!=(lispval) 0;
+                   (handy = handy->CDR), count += 12);
+               strb = (char *) alloca(count);
+
+               _strbuf._flag = _IOWRT+_IOSTRG;
+               _strbuf._ptr = strb;
+               _strbuf._cnt = count;
+               pbignum(lbot->val,&_strbuf);
+               putc('.',&_strbuf);
+               putc(0,&_strbuf);
+               break;
+       }
+       default:
+                       errorh(Vermisc,"EXPLODE ARG MUST BE STRING, SYMBOL, FIXNUM, OR FLONUM",nil,FALSE,0,handy);
+                       return(nil);
+               }
+
+
+       if( strb[0] != NULL_CHAR )      /* if there is something to do */
+       {
+           register lispval prev;
+
+           protect(handy = last = newdot()); 
+           strbuf[1] = NULL_CHAR ;     /* set up for getatom */
+           atmlen = 2;
+
+           for(i=0; ch = strb[i++]; ) {
+               switch(kind) {
+
+                 case 0: strbuf[0] = hash = ch;   /* character explode */
+                         hash = 177 & hash;    /* cut 1st bit off if any */
+                         last->car = (lispval) getatom(); /* look in oblist */
+                         break;
+
+                 case 1: 
+                         last->car = inewint(ch);
+                         break;
+               }
+
+               /* advance pointers */
+               prev = last;
+               last->cdr = newdot();
+               last = last->cdr;
+           }
+
+           /* end list with a nil pointer */
+           prev->cdr = nil;
+           return(handy);
+       }
+       else return(nil);       /* return nil if no characters */
+}
+
+/*===========================
+-
+- (explodec 'atm) returns (a t m)
+- (explodec 234) returns (\2 \3 \4)
+-===========================*/
+
+lispval
+Lexpldc()
+{ return(Lexpldx(0,0)); }
+
+
+/*===========================
+-
+- (exploden 'abc) returns (65 66 67)
+- (exploden 123)  returns (49 50 51)
+-=============================*/
+
+
+lispval
+Lexpldn()
+{ return(Lexpldx(1,0)); }
+
+/*===========================
+-
+- (explodea "123")  returns (\\ \1 \2 \3);
+- (explodea 123)  returns (\1 \2 \3);
+-=============================*/
+
+lispval
+Lexplda()
+{ return(Lexpldx(0,1)); }
+
+/*
+ * (argv) returns how many arguments where on the command line which invoked
+ * lisp; (argv i) returns the i'th argument made into an atom;
+ */
+
+lispval
+Largv()
+{
+       register lispval handy;
+       register index;
+       register char c, *base;
+       extern int Xargc;
+       extern char **Xargv;
+
+       chkarg(1);
+       handy = lbot->val;
+       
+       if(TYPE(handy)==INT && handy->i>=0 && handy->i<Xargc) {
+               strcpy(strbuf,Xargv[handy->i]);
+               return(getatom());
+       } else { 
+               return(inewint(Xargc));
+       }
+}
+/*
+ * (chdir <atom>) executes a chdir command
+ * if successful, return t otherwise returns nil
+ */
+lispval Lchdir(){
+       register lispval handy;
+
+       chkarg(1);
+       handy=lbot->val;
+       if(TYPE(handy)==ATOM && (chdir(handy->pname)>=0))
+               return(tatom);
+       else
+               return(nil);
+}
+
+/* ==========================================================
+-
+-      ascii   - convert from number to ascii character
+-
+- form:(ascii number)
+-
+-      the number is checked so that it is in the range 0-255
+- then it is made a character and returned
+- =========================================================*/
+
+lispval
+Lascii() 
+{
+       register lispval handy;
+
+       handy = lbot->val;              /* get argument */
+
+       if(TYPE(handy) != INT)          /* insure that it is an integer */
+       {       error("argument not an integer",FALSE);
+               return(nil);
+       }
+
+       if(handy->i < 0 || handy->i > 0377)     /* insure that it is in range*/
+       {       error("argument is out of ascii range",FALSE);
+               return(nil);
+       }
+
+       strbuf[0] = handy->i ;  /* ok value, make into a char */
+       strbuf[1] = NULL_CHAR;
+
+       /* lookup and possibly intern the atom given in strbuf */
+
+       return( (lispval) getatom() );
+}
+
+/*
+ *  boole - maclisp bitwise boolean function
+ *  (boole k x y) where k determines which of 16 possible bitwise 
+ *  truth tables may be applied.  Common values are 1 (and) 6 (xor) 7 (or)
+ *  the result is mapped over each pair of bits on input
+ */
+lispval
+Lboole(){
+       register x, y;
+       register lispval result;
+       register struct argent *mynp;
+       int k;
+
+       if(np - lbot < 3)
+               error("Boole demands at least 3 args",FALSE);
+       mynp = lbot+AD;
+       k = mynp->val->i & 15;
+       x = (mynp+1)->val->i;
+       for(mynp += 2; mynp < np; mynp++) {
+               y = mynp->val->i;
+               switch(k) {
+
+               case 0: x = 0;
+                       break;
+               case 1: x = x & y;
+                       break;
+               case 2: x = y & ~x;
+                       break;
+               case 3: x = y;
+                       break;
+               case 4: x = x & ~y;
+                       break;
+               /* case 5:      x = x; break; */
+               case 6: x = x ^ y;
+                       break;
+               case 7: x = x | y;
+                       break;
+               case 8: x = ~(x | y);
+                       break;
+               case 9: x = ~(x ^ y);
+                       break;
+               case 10: x = ~x;
+                       break;
+               case 11: x = ~x | y;
+                       break;
+               case 12: x = ~y;
+                       break;
+               case 13: x = x | ~y;
+                       break;
+               case 14: x = ~x | ~y;
+                       break;
+               case 15: x = -1;
+               }
+       }
+       return(inewint(x));
+}
+lispval
+Lfact()
+{
+       register lispval result, handy;
+       register itemp;
+       snpand(3); /* fixup entry mask */
+
+       result = lbot->val;
+       if(TYPE(result)!=INT) error("Factorial of Non-fixnum.  If you want me\
+to calculate fact of > 2^30 We will be here till doomsday!.",FALSE);
+       itemp = result->i;
+       protect(result = newsdot());
+       result->CDR=(lispval)0;
+       result->i = 1;
+       for(; itemp > 1; itemp--)
+               dmlad(result,itemp,0);
+       if(result->CDR) return(result);
+       (handy = newint())->i = result->i;
+       return(handy);
+}
+/*
+ * fix -- maclisp floating to fixnum conversion
+ * for the moment, mereley convert floats to ints.
+ * eventual convert to bignum if too big to fit.
+ */
+ lispval Lfix() 
+ {
+       register lispval result, handy;
+
+       chkarg(1);
+       handy = lbot->val;
+       switch(TYPE(handy)) {
+       default:
+               error("innaproriate arg to fix.",FALSE);
+       case INT:
+       case SDOT:
+               return(handy);
+       case DOUB:
+               if(handy->r >= 0)
+                       return(inewint((int)handy->r));
+               else
+                       return(inewint(((int)handy->r)-1));
+       }
+}
+
+lispval
+Lfloat()
+{
+       register lispval handy,result;
+       chkarg(1);
+       handy = lbot->val;
+       switch(TYPE(handy))
+       {
+         case DOUB: return(handy);
+
+
+         case INT:  result = newdoub();
+                    result->r = (double) handy->i;
+                    return(result);
+                    
+
+         default: error(Vermisc,"Bad argument to float",nil,FALSE,0,handy);
+       }
+}
+
+/* Lbreak ***************************************************************/
+/* If first argument is not nil, this is evaluated and printed.  Then  */
+/* error is called with the "breaking" message.                                */
+lispval Lbreak() {
+       register lispval hold;
+
+       if (np > lbot) {
+               printr(lbot->val,poport);
+               dmpport(poport);
+       }
+       return(error("",TRUE));
+}
+
+
+lispval LDivide() {
+       register lispval result, work, temp;
+       register struct argent *mynp;
+       register struct argent *lbot, *np;
+       int typ;
+       lispval quo, rem; struct sdot dummy;
+
+       chkarg(2);
+       mynp = lbot;
+       result = mynp->val;
+       work = (mynp+1)->val;
+
+       if((typ=TYPE(result))==INT) {
+               protect(temp=newsdot());
+               temp->i = result->i;
+               result = temp;
+       } else if (typ!=SDOT)
+               error("First arg to divide neither a bignum nor int.",FALSE);
+       typ = TYPE(work);
+       if(typ != INT && typ != SDOT)
+               error("second arg to Divide neither an sdot nor an int.",FALSE);
+       if(typ == INT) {
+               dummy.CDR = (lispval) 0;
+               dummy.I = work->i;
+               work = (lispval) &dummy;
+       }
+       divbig(result,work, &quo, &rem);
+       protect(quo);
+       if(rem==((lispval) &dummy))
+               protect(rem = inewint(dummy.I));
+       protect(result = work = newdot());
+       work->car = quo;
+       (work->cdr = newdot())->car = rem;
+       return(result);
+}
+lispval LEmuldiv(){
+       register struct argent * mynp = lbot+AD;
+       register lispval work, result;
+       int quo, rem;
+       snpand(3); /* fix register mask */
+
+       /* (Emuldiv mul1 mult2 add quo) => 
+               temp = mul1 + mul2 + sext(add);
+               result = (list temp/quo temp%quo);
+               to mix C and lisp a bit */
+
+       Imuldiv(mynp[0].val->i, mynp[1].val->i, mynp[2].val->i,
+               mynp[3].val->i, &quo, &rem);
+       protect(result=newdot());
+       (result->car=inewint(quo));
+       work = result->cdr = newdot();
+       (work->car=inewint(rem));
+       return(result);
+}
+static Imuldiv() {
+asm("  emul    4(ap),8(ap),12(ap),r0");
+asm("  ediv    16(ap),r0,*20(ap),*24(ap)");
+}
+
+

diff --git a/usr/src/cmd/lisp/lam8.c b/usr/src/cmd/lisp/lam8.c
new file mode 100644 (file)
index 0000000..1afb28c
--- /dev/null
+++ b/usr/src/cmd/lisp/lam8.c
@@ -0,0 +1,156 @@
+#include "global.h"
+
+/* various functions from the c math library */
+double sin(),cos(),asin(),acos(),atan2(),sqrt(), log(), exp();
+
+lispval Imath(func)
+double func();
+{
+       register lispval handy;
+       register double res;
+       chkarg(1);
+
+       switch(TYPE(handy=lbot->val)) {
+        case INT: res = func((double)handy->i); 
+                  break;
+
+        case DOUB: res = func(handy->r);
+                  break;
+
+        default:  error("Non fixnum or flonum to math function",FALSE);
+       }
+       handy = newdoub();
+       handy->r = res;
+       return(handy);
+}
+lispval Lsin()
+{
+       return(Imath(sin));
+}
+
+lispval Lcos()
+{
+       return(Imath(cos));
+}
+
+lispval Lasin()
+{
+       return(Imath(asin));
+}
+
+lispval Lacos()
+{
+       return(Imath(acos));
+}
+
+lispval Lsqrt()
+{
+       return(Imath(sqrt));
+}
+lispval Lexp()
+{
+       return(Imath(exp));
+}
+
+lispval Llog()
+{
+       return(Imath(log));
+}
+
+/* although we call this atan, it is really atan2 to the c-world,
+   that is, it takes two args
+ */
+lispval Latan()
+{
+       register lispval arg;
+       register double arg1v;
+       register double res;
+       chkarg(2);
+
+       switch(TYPE(arg=lbot->val)) {
+
+       case INT:  arg1v = (double) arg->i;
+                  break;
+
+       case DOUB: arg1v = arg->r;
+                  break;
+
+       default:   error("Non fixnum or flonum arg to atan2",FALSE);
+       }
+
+       switch(TYPE(arg = (lbot+1)->val)) {
+
+       case INT: res = atan2(arg1v,(double) arg->i);
+                 break;
+
+       case DOUB: res = atan2(arg1v, arg->r);
+                 break;
+
+       default:  error("Non fixnum or flonum to atan2",FALSE);
+       }
+       arg = newdoub();
+       arg->r = res;
+       return(arg);
+}
+
+/* (random) returns a fixnum in the range -2**30 to 2**30 -1
+   (random fixnum) returns a fixnum in the range 0 to fixnum-1
+ */
+lispval
+Lrandom()
+{
+       register int curval;
+       float pow();
+
+       curval = rand();        /* get numb from 0 to 2**31-1 */
+
+       if(np==lbot) return(inewint(curval-(int)pow((double)2,(double)30)));
+
+       if((TYPE(lbot->val) != INT)
+           || (lbot->val->i <= 0)) errorh(Vermisc,"random: non fixnum arg:",
+                                                nil, FALSE, 0, lbot->val);
+
+       return(inewint(curval % lbot->val->i )); 
+
+}
+lispval
+Lmakunb()
+{
+       register lispval work;
+
+       chkarg(1);
+       work = lbot->val;
+       if(work==nil || (TYPE(work)!=ATOM))
+               return(work);
+       work->clb = CNIL;
+       return(work);
+}
+lispval
+Lpolyev()
+{
+       register int count; 
+       register double *handy, *base;
+       register struct argent *argp, *lbot, *np;
+       lispval result; int type;
+
+       count = 2 * (((int) np) - (int) lbot);
+       if(count == 0) 
+               return(inewint(0));
+       if(count == 8)
+               return(lbot->val);
+       base = handy = (double *) alloca(count);
+       for(argp = lbot; argp < np; argp++) {
+               while((type = TYPE(argp->val))!=DOUB && type!=INT)
+                       argp->val = (lispval) errorh(Vermisc,"%%machine-polyev:non-real arg",nil,TRUE,73,lbot,argp->val);
+               if(TYPE(argp->val)==INT) {
+                       *handy++ = argp->val->i;
+               } else
+                       *handy++ = argp->val->r;
+       }
+       count = count/sizeof(double) - 2;
+       asm("polyd      (r9),r11,8(r9)");
+       asm("movd       r0,(r9)");
+       result = newdoub();
+       result->r = *base;
+       return(result);
+}

diff --git a/usr/src/cmd/lisp/sysat.c b/usr/src/cmd/lisp/sysat.c
new file mode 100644 (file)
index 0000000..84a54ac
--- /dev/null
+++ b/usr/src/cmd/lisp/sysat.c
@@ -0,0 +1,466 @@
+#include "global.h"
+#include "lfuncs.h"
+#define MK(x,y,z) mfun(x,y,z)
+#define FIDDLE(a,b,c,d) a->clb=newdot(); (a->clb->car=newint())->i=b->i; \
+       a->clb->cdr=newdot(); (a->clb->cdr->car=newint())->i=c->i; \
+       a->clb->cdr->cdr=newdot(); (a->clb->cdr->cdr->car=newint())->i=d; \
+       b = a->clb->car; c = a->clb->cdr->car; \
+       copval(a,a->clb); a->clb = nil;
+
+#define cforget(x) protect(x); Lforget(); unprot();
+
+/*  The following array serves as the temporary counters of the items  */
+/*  and pages used in each space.                                      */
+
+long int tint[18]={0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0};
+
+long int tgcthresh = 15;
+int initflag = TRUE;   /*  starts off TRUE to indicate unsafe to gc  */
+
+#define PAGE_LIMIT 3800
+
+extern Iaddstat();
+
+makevals()
+       {
+       lispval temp;
+
+       /*  system list structure and atoms are initialized.  */
+
+       /*  Before any lisp data can be created, the space usage */
+       /*  counters must be set up, temporarily in array tint.  */
+
+       atom_items = (lispval) &tint[0];
+       atom_pages = (lispval) &tint[1];
+       str_items = (lispval) &tint[2];
+       str_pages = (lispval) &tint[3];
+       int_items = (lispval) &tint[4];
+       int_pages = (lispval) &tint[5];
+       dtpr_items = (lispval) &tint[6];
+       dtpr_pages = (lispval) &tint[7];
+       doub_items = (lispval) &tint[8];
+       doub_pages = (lispval) &tint[9];
+       sdot_items = (lispval) &tint[10];
+       sdot_pages = (lispval) &tint[11];
+       array_items = (lispval) &tint[12];
+       array_pages = (lispval) &tint[13];
+       val_items = (lispval) &tint[14];
+       val_pages = (lispval) &tint[15];
+       funct_items = (lispval) &tint[16];
+       funct_pages = (lispval) &tint[17];
+
+       /*  This also applies to the garbage collection threshhold  */
+
+       gcthresh = (lispval) &tgcthresh;
+
+       /*  Now we commence constructing system lisp structures.  */
+
+       /*  nil is a special case, constructed especially at location zero  */
+
+       hasht['n'^'i'^'l'] = (struct atom *)nil;
+
+
+       atom_name = matom("symbol");
+       str_name = matom("string");
+       int_name = matom("fixnum");
+       dtpr_name = matom("list");
+       doub_name = matom("flonum");
+       sdot_name = matom("bignum");
+       array_name = matom("array");
+       val_name = matom("value");
+       funct_name = matom("binary");
+
+
+       /*  set up the name stack as an array of pointers */
+
+       lbot = orgnp = np = ((struct argent *)csegment(val_name,NAMESIZE));
+       nplim = orgnp+NAMESIZE-5;
+       temp = matom("namestack");
+       nstack = temp->fnbnd = newarray();
+       nstack->data = (char *) (np);
+       (nstack->length = newint())->i = NAMESIZE;
+       (nstack->delta = newint())->i = sizeof(struct argent);
+
+       /* set up the binding stack as an array of dotted pairs */
+
+       orgbnp = bnp = ((struct nament *)csegment(dtpr_name,NAMESIZE));
+       bnplim = orgbnp+NAMESIZE-5;
+       temp = matom("bindstack");
+       bstack = temp->fnbnd = newarray();
+       bstack->data = (char *) (bnp);
+       (bstack->length = newint())->i = NAMESIZE;
+       (nstack->delta = newint())->i = sizeof(struct nament);
+
+       /* more atoms */
+
+       tatom = matom("t");
+       tatom->clb = tatom;
+       lambda = matom("lambda");
+       nlambda = matom("nlambda");
+       macro = matom("macro");
+       ibase = matom("ibase");         /* base for input conversion */
+       ibase->clb = inewint(10);
+       Vpiport = matom("piport");
+       Vpiport->clb = P(piport = stdin);       /* standard input */
+       Vpoport = matom("poport");
+       Vpoport->clb = P(poport = stdout);      /* stand. output */
+       matom("errport")->clb = (P(errport = stderr));/* stand. err. */
+       (Vreadtable = matom("readtable"))->clb  = Imkrtab(0);
+       strtab = Imkrtab(0);
+
+       /*  The following atoms are used as tokens by the reader  */
+
+       perda = matom(".");
+       lpara = matom("(");
+       rpara = matom(")");
+       lbkta = matom("[");
+       rbkta = matom("]");
+       snqta = matom("'");
+       exclpa = matom("!");
+
+
+       (Eofa = matom("eof"))->clb = eofa;
+       cara = MK("car",Lcar,lambda);
+       cdra = MK("cdr",Lcdr,lambda);
+
+       /*  The following few atoms have values the reader tokens.  */
+       /*  Perhaps this is a kludge which should be abandoned.  */
+       /*  On the other hand, perhaps it is an inspiration.    */
+
+       matom("perd")->clb = perda;
+       matom("lpar")->clb = lpara;
+       matom("rpar")->clb = rpara;
+       matom("lbkt")->clb = lbkta;
+       matom("rbkt")->clb = rbkta;
+
+       noptop = matom("noptop");
+
+       /*  atoms used in connection with comments.  */
+
+       commta = matom("comment");
+       rcomms = matom("readcomments");
+
+       /*  the following atoms are used for lexprs */
+
+       lexpr_atom = matom("last lexpr binding\7");
+       lexpr = matom("lexpr");
+
+       sysa = matom("sys");
+       plima = matom("pagelimit");     /*  max number of pages  */
+       Veval = MK("eval",Leval,lambda);
+       MK("asin",Lasin,lambda);
+       MK("acos",Lacos,lambda);
+       MK("atan",Latan,lambda);
+       MK("cos",Lcos,lambda);
+       MK("sin",Lsin,lambda);
+       MK("sqrt",Lsqrt,lambda);
+       MK("exp",Lexp,lambda);
+       MK("log",Llog,lambda);
+       MK("random",Lrandom,lambda);
+       MK("atom",Latom,lambda);
+       MK("apply",Lapply,lambda);
+       MK("funcall",Lfuncal,lambda);
+       MK("return",Lreturn,lambda);
+       MK("retbrk",Lretbrk,lambda);
+       MK("cont",Lreturn,lambda);
+       MK("cons",Lcons,lambda);
+       MK("scons",Lscons,lambda);
+       MK("cadr",Lcadr,lambda);
+       MK("caar",Lcaar,lambda);
+       MK("cddr",Lc02r,lambda);
+       MK("caddr",Lc12r,lambda);
+       MK("cdddr",Lc03r,lambda);
+       MK("cadddr",Lc13r,lambda);
+       MK("cddddr",Lc04r,lambda);
+       MK("caddddr",Lc14r,lambda);
+       MK("nthelem",Lnthelem,lambda);
+       MK("eq",Leq,lambda);
+       MK("equal",Lequal,lambda);
+       MK("numberp",Lnumberp,lambda);
+       MK("dtpr",Ldtpr,lambda);
+       MK("bcdp",Lbcdp,lambda);
+       MK("portp",Lportp,lambda);
+       MK("arrayp",Larrayp,lambda);
+       MK("valuep",Lvaluep,lambda);
+       MK("get_pname",Lpname,lambda);
+       MK("arrayref",Larrayref,lambda);
+       MK("marray",Lmarray,lambda);
+       MK("getlength",Lgetl,lambda);
+       MK("putlength",Lputl,lambda);
+       MK("getaccess",Lgeta,lambda);
+       MK("putaccess",Lputa,lambda);
+       MK("getdelta",Lgetdel,lambda);
+       MK("putdelta",Lputdel,lambda);
+       MK("getaux",Lgetaux,lambda);
+       MK("putaux",Lputaux,lambda);
+       MK("mfunction",Lmfunction,lambda);
+       MK("getentry",Lgetentry,lambda);
+       MK("getdisc",Lgetdisc,lambda);
+       MK("segment",Lsegment,lambda);
+       MK("rplaca",Lrplaca,lambda);
+       MK("rplacd",Lrplacd,lambda);
+       MK("set",Lset,lambda);
+       MK("replace",Lreplace,lambda);
+       MK("infile",Linfile,lambda);
+       MK("outfile",Loutfile,lambda);
+       MK("terpr",Lterpr,lambda);
+       MK("print",Lprint,lambda);
+       MK("close",Lclose,lambda);
+       MK("patom",Lpatom,lambda);
+       MK("pntlen",Lpntlen,lambda);
+       MK("read",Lread,lambda);
+       MK("ratom",Lratom,lambda);
+       MK("readc",Lreadc,lambda);
+       MK("implode",Limplode,lambda);
+       MK("maknam",Lmaknam,lambda);
+       MK("concat",Lconcat,lambda);
+       MK("uconcat",Luconcat,lambda);
+       MK("putprop",Lputprop,lambda);
+       MK("get",Lget,lambda);
+       MK("getd",Lgetd,lambda);
+       MK("putd",Lputd,lambda);
+       MK("prog",Nprog,nlambda);
+       quota = MK("quote",Nquote,nlambda);
+       MK("function",Nfunction,nlambda);
+       MK("go",Ngo,nlambda);
+       MK("*catch",Ncatch,nlambda);
+       MK("errset",Nerrset,nlambda);
+       MK("status",Nstatus,nlambda);
+       MK("sstatus",Nsstatus,nlambda);
+       MK("err",Lerr,lambda);
+       MK("*throw",Nthrow,lambda);     /* this is a lambda now !! */
+       MK("reset",Nreset,nlambda);
+       MK("break",Nbreak,nlambda);
+       MK("exit",Lexit,lambda);
+       MK("def",Ndef,nlambda);
+       MK("null",Lnull,lambda);
+       MK("and",Nand,nlambda);
+       MK("or",Nor,nlambda);
+       MK("setq",Nsetq,nlambda);
+       MK("cond",Ncond,nlambda);
+       MK("list",Llist,lambda);
+       MK("load",Lload,lambda);
+       MK("nwritn",Lnwritn,lambda);
+       MK("process",Nprocess,nlambda); /*  execute a shell command  */
+       MK("allocate",Lalloc,lambda);   /*  allocate a page  */
+       MK("sizeof",Lsizeof,lambda);    /*  size of one item of a data type  */
+       MK("dumplisp",Ndumpli,nlambda); /*  save the world  */
+       MK("top-level",Ntpl,nlambda);   /*  top level eval-print read loop  */
+       startup = matom("startup");     /*  used by save and restore  */
+       MK("mapcar",Lmapcar,lambda);
+       MK("maplist",Lmaplist,lambda);
+       MK("mapcan",Lmapcan,lambda);
+       MK("mapcon",Lmapcon,lambda);
+       MK("assq",Lassq,lambda);
+       MK("mapc",Lmapc,lambda);
+       MK("map",Lmap,lambda);
+       MK("flatsize",Lflatsi,lambda);
+       MK("alphalessp",Lalfalp,lambda);
+       MK("drain",Ldrain,lambda);
+       MK("killcopy",Lkilcopy,lambda); /*  forks aand aborts for adb */
+       MK("opval",Lopval,lambda);      /*  sets and retrieves system variables  */
+       MK("ncons",Lncons,lambda);
+       sysa = matom("sys");    /*  sys indicator for system variables  */
+       MK("remob",Lforget,lambda);     /*  function to take atom out of hash table  */
+       splice = matom("splicing");
+       MK("not",Lnull,lambda);
+       MK("plus",Ladd,lambda);
+       MK("add",Ladd,lambda);
+       MK("times",Ltimes,lambda);
+       MK("difference",Lsub,lambda);
+       MK("quotient",Lquo,lambda);
+       MK("mod",Lmod,lambda);
+       MK("minus",Lminus,lambda);
+       MK("absval",Labsval,lambda);
+       MK("add1",Ladd1,lambda);
+       MK("sub1",Lsub1,lambda);
+       MK("greaterp",Lgreaterp,lambda);
+       MK("lessp",Llessp,lambda);
+       MK("zerop",Lzerop,lambda);
+       MK("minusp",Lnegp,lambda);
+       MK("onep",Lonep,lambda);
+       MK("sum",Ladd,lambda);
+       MK("product",Ltimes,lambda);
+       MK("do",Ndo,nlambda);
+       MK("progv",Nprogv,nlambda);
+       MK("progn",Nprogn,nlambda);
+       MK("prog2",Nprog2,nlambda);
+       MK("oblist",Loblist,lambda);
+       MK("baktrace",Lbaktra,lambda);
+       MK("tyi",Ltyi,lambda);
+       MK("tyipeek",Ltyipeek,lambda);
+       MK("tyo",Ltyo,lambda);
+       MK("setsyntax",Lsetsyn,lambda);
+       MK("makereadtable",Lmakertbl,lambda);
+       MK("zapline",Lzaplin,lambda);
+       MK("aexplode",Lexplda,lambda);
+       MK("aexplodec",Lexpldc,lambda);
+       MK("aexploden",Lexpldn,lambda);
+       MK("argv",Largv,lambda);
+       MK("arg",Larg,lambda);
+       MK("showstack",Lshostk,lambda);
+       MK("resetio",Nreseti,nlambda);
+       MK("chdir",Lchdir,lambda);
+       MK("ascii",Lascii,lambda);
+       MK("boole",Lboole,lambda);
+       MK("type",Ltype,lambda);        /* returns type-name of argument */
+       MK("fix",Lfix,lambda);
+       MK("float",Lfloat,lambda);
+       MK("fact",Lfact,lambda);
+       MK("cpy1",Lcpy1,lambda);
+       MK("Divide",LDivide,lambda);
+       MK("Emuldiv",LEmuldiv,lambda);
+       MK("readlist",Lreadli,lambda);
+       MK("plist",Lplist,lambda);      /* gives the plist of an atom */
+       MK("setplist",Lsetpli,lambda);  /* get plist of an atom  */
+       MK("eval-when",Nevwhen,nlambda);
+       MK("syscall",Nsyscall,nlambda);
+       MK("ptime",Lptime,lambda);      /* return process user time */
+/*
+       MK("fork",Lfork,lambda);
+       MK("wait",Lwait,lambda);
+       MK("pipe",Lpipe,lambda);
+       MK("fdopen",Lfdopen,lambda);
+       MK("exece",Lexece,lambda);
+ */
+       MK("gensym",Lgensym,lambda);
+       MK("remprop",Lremprop,lambda);
+       MK("bcdad",Lbcdad,lambda);
+       MK("symbolp",Lsymbolp,lambda);
+       MK("stringp",Lstringp,lambda);
+       MK("rematom",Lrematom,lambda);
+       MK("prname",Lprname,lambda);
+       MK("getenv",Lgetenv,lambda);
+       MK("makunbound",Lmakunb,lambda);
+       MK("haipart",Lhaipar,lambda);
+       MK("haulong",Lhau,lambda);
+       MK("signal",Lsignal,lambda);
+       MK("fasl",Lfasl,lambda);        /* read in compiled file */
+       MK("bind",Lbind,lambda);        /* like fasl but for functions
+                                          loaded in when the lisp system
+                                          was constructed by ld */
+       MK("boundp",Lboundp,lambda);    /* tells if an atom is bound */
+       MK("fake",Lfake,lambda);        /* makes a fake lisp pointer */
+       MK("od",Lod,lambda);            /* dumps info */
+       MK("what",Lwhat,lambda);        /* converts a pointer to an integer */
+       MK("pv%",Lpolyev,lambda);       /* polynomial evaluation instruction */
+       odform = matom("odformat");     /* format for printf's used in od */
+       rdrsdot = newsdot();            /* used in io conversions of bignums */
+       rdrint = newint();              /* used as a temporary integer */
+       (nilplist = newdot())->cdr = newdot();
+                                       /* used as property list for nil,
+                                          since nil will eventually be put at
+                                          0 (consequently in text and not
+                                          writable) */
+
+       /* error variables */
+       (Vererr = matom("ER%err"))->clb = nil;
+       (Vertpl = matom("ER%tpl"))->clb = nil;
+       (Verall = matom("ER%all"))->clb = nil;
+       (Vermisc = matom("ER%misc"))->clb = nil;
+       (Vlerall = newdot())->car = Verall;     /* list (ER%all) */
+
+
+       /* set up the initial status list */
+
+       stlist = nil;                   /* initially nil */
+       Iaddstat(matom("features"),ST_READ,ST_NO,nil);
+       Iaddstat(matom("feature"),ST_FEATR,ST_FEATW,nil);
+       Isstatus(matom("feature"),matom("franz"));
+
+       Iaddstat(matom("nofeature"),ST_NFETR,ST_NFETW,nil);
+       Iaddstat(matom("syntax"),ST_SYNT,ST_NO,nil);
+       Iaddstat(matom("uctolc"),ST_READ,ST_TOLC,nil);
+       Iaddstat(matom("dumpcore"),ST_READ,ST_CORE,nil);
+       Isstatus(matom("dumpcore"),nil);        /*set up signals*/
+
+       Iaddstat(matom("chainatom"),ST_RINTB,ST_INTB,inewint(0));
+       Iaddstat(matom("dumpmode"),ST_DMPR,ST_DMPW,nil);
+       /* garbage collector things */
+
+       MK("gc",Ngc,nlambda);
+       gcafter = MK("gcafter",Ngcafter,nlambda);       /* garbage collection wind-up */
+       gcport = matom("gcport");       /* port for gc dumping */
+       gccheck = matom("gccheck");     /* flag for checking during gc */
+       gcdis = matom("gcdisable");     /* option for disabling the gc */
+       gcload = matom("gcload");       /* option for gc while loading */
+       loading = matom("loading");     /* flag--in loader if = t  */
+       noautot = matom("noautotrace"); /* option to inhibit auto-trace */
+       (gcthresh = newint())->i = tgcthresh;
+       gccall1 = newdot();  gccall2 = newdot();  /* used to call gcafter */
+       gccall1->car = gcafter;  /* start constructing a form for eval */
+
+       arrayst = mstr("ARRAY");        /* array marker in name stack */
+       bcdst = mstr("BINARY");         /* binary function marker */
+       listst = mstr("INTERPRETED");   /* interpreted function marker */
+       macrost = mstr("MACRO");        /* macro marker */
+       protst = mstr("PROTECTED");     /* protection marker */
+       badst = mstr("BADPTR");         /* bad pointer marker */
+       argst = mstr("ARGST");          /* argument marker */
+
+       /* type names */
+
+       FIDDLE(atom_name,atom_items,atom_pages,ATOMSPP);
+       FIDDLE(str_name,str_items,str_pages,STRSPP);
+       FIDDLE(int_name,int_items,int_pages,INTSPP);
+       FIDDLE(dtpr_name,dtpr_items,dtpr_pages,DTPRSPP);
+       FIDDLE(doub_name,doub_items,doub_pages,DOUBSPP);
+       FIDDLE(sdot_name,sdot_items,sdot_pages,SDOTSPP);
+       FIDDLE(array_name,array_items,array_pages,ARRAYSPP);
+       FIDDLE(val_name,val_items,val_pages,VALSPP);
+       FIDDLE(funct_name,funct_items,funct_pages,BCDSPP);
+
+       (plimit = newint())->i = PAGE_LIMIT;
+       copval(plima,plimit);  /*  default value  */
+
+       /* the following atom is used when reading caar, cdar, etc. */
+
+       xatom = matom("??");
+
+       /*  now it is OK to collect garbage  */
+
+       initflag = FALSE;
+       }
+
+/*  matom("name")  ******************************************************/
+/*                                                                     */
+/*  simulates an atom being read in from the reader and returns a      */
+/*  pointer to it.                                                     */
+/*                                                                     */
+/*  BEWARE:  if an atom becomes "truly worthless" and is collected,    */
+/*  the pointer becomes obsolete.                                      */
+/*                                                                     */
+lispval
+matom(string)
+char *string;
+       {
+       strcpy(strbuf,string);
+       return(getatom());
+       }
+
+/*  mstr  ***************************************************************/
+/*                                                                     */
+/*  Makes a string.  Uses matom.                                       */
+/*  Not the most efficient but will do until the string from the code  */
+/*  itself can be used as a lispval.                                   */
+
+lispval mstr(string) char *string;
+       {
+       return((lispval)(inewstr(string)));
+       }
+
+/*  mfun("name",entry)  *************************************************/
+/*                                                                     */
+/*  Same as matom, but entry point to c code is associated with                */
+/*  "name" as function binding.                                                */
+/*  A pointer to the atom is returned.                                 */
+/*                                                                     */
+lispval mfun(string,entry,discip) char *string; lispval (*entry)(), discip;
+       {
+       lispval v;
+       v = matom(string);
+       v -> fnbnd = newfunct();
+       v->fnbnd->entry = entry;
+       v->fnbnd->discipline = discip;
+       return(v);
+       }