--- /dev/null
+#include "global.h"
+
+lispval
+Lfork() {
+ register lispval temp;
+ int pid;
+
+ chkarg(0);
+ if ((pid=fork())) {
+ temp = newint();
+ temp->i = pid;
+ return(temp);
+ } else
+ return(nil);
+}
+
+lispval
+Lwait()
+{
+ register lispval ret, temp;
+ int status = -1, pid;
+ snpand(2);
+
+
+ chkarg(0);
+ pid = wait(&status);
+ ret = newdot();
+ protect(ret);
+ temp = newint();
+ temp->i = pid;
+ ret->car = temp;
+ temp = newint();
+ temp->i = status;
+ ret->cdr = temp;
+ return(ret);
+}
+
+lispval
+Lpipe()
+{
+ register lispval ret, temp;
+ int pipes[2];
+
+ chkarg(0);
+ pipes[0] = -1;
+ pipes[1] = -1;
+ pipe(pipes);
+ ret = newdot();
+ protect(ret);
+ temp = newint();
+ temp->i = pipes[0];
+ ret->car = temp;
+ temp = newint();
+ temp->i = pipes[1];
+ ret->cdr = temp;
+ return(ret);
+}
+
+lispval
+Lfdopen()
+{
+ register lispval fd, type;
+ FILE *ptr;
+
+ chkarg(2);
+ type = (np-1)->val;
+ fd = lbot->val;
+ if( TYPE(fd)!=INT )
+ return(nil);
+ if ( (ptr=fdopen((int)fd->i, (char *)type->a.pname))==NULL)
+ return(nil);
+ return(P(ptr));
+}
+
+lispval
+Lexece()
+{
+ lispval fname, arglist, envlist, temp;
+ char *args[100], *envs[100], estrs[1024];
+ char *p, *cp, **sp;
+ snpand(0);
+
+ chkarg(3);
+ envlist = (--np)->val;
+ arglist = (--np)->val;
+ fname = (--np)->val;
+ if (TYPE(fname)!=ATOM)
+ return(nil);
+ if (TYPE(arglist)!=DTPR && arglist!=nil)
+ return(nil);
+ for (sp=args; arglist!=nil; arglist=arglist->d.cdr) {
+ temp = arglist->d.car;
+ if (TYPE(temp)!=ATOM)
+ return(nil);
+ *sp++ = temp->a.pname;
+ }
+ *sp = 0;
+ if (TYPE(envlist)!=DTPR && envlist!=nil)
+ return(nil);
+ for (sp=envs,cp=estrs; envlist!=nil; envlist=envlist->d.cdr) {
+ temp = envlist->d.car;
+ if (TYPE(temp)!=DTPR || TYPE(temp->d.car)!=ATOM
+ || TYPE(temp->d.cdr)!=ATOM)
+ return(nil);
+ *sp++ = cp;
+ for (p=temp->d.car->a.pname; (*cp++ = *p++);) ;
+ *(cp-1) = '=';
+ for (p=temp->d.cdr->a.pname; (*cp++ = *p++);) ;
+ }
+ *sp = 0;
+ execve(fname->a.pname, args, envs);
+ return(nil);
+}
+
+lispval
+Lgensym()
+{
+ lispval arg;
+ char leader;
+ static int counter = 0;
+
+ chkarg(1);
+ arg = lbot->val;
+ leader = 'g';
+ if (arg != nil && TYPE(arg)==ATOM)
+ leader = arg->a.pname[0];
+ sprintf(strbuf, "%c%05d", leader, counter++);
+ atmlen = 7;
+ return((lispval)newatom());
+}
+extern struct types {
+char *next_free;
+int space_left,
+ space,
+ type,
+ type_len; /* note type_len is in units of int */
+lispval *items,
+ *pages,
+ *type_name;
+struct heads
+ *first;
+} atom_str ;
+
+lispval
+Lremprop()
+{
+ register struct argent *argp;
+ register lispval pptr, ind, opptr;
+ register struct argent *lbot, *np;
+ lispval atm;
+ int disemp = FALSE;
+
+ chkarg(2);
+ argp = lbot;
+ ind = argp[1].val;
+ atm = argp->val;
+ switch (TYPE(atm)) {
+ case DTPR:
+ pptr = atm->cdr;
+ disemp = TRUE;
+ break;
+ case ATOM:
+ if((lispval)atm==nil)
+ pptr = nilplist;
+ else
+ pptr = atm->plist;
+ break;
+ default:
+ errorh(Vermisc, "remprop: Illegal first argument :",
+ nil, FALSE, 0, atm);
+ }
+ opptr = nil;
+ if (pptr==nil)
+ return(nil);
+ while(TRUE) {
+ if (TYPE(pptr->cdr)!=DTPR)
+ errorh(Vermisc, "remprop: Bad property list",
+ nil, FALSE, 0,atm);
+ if (pptr->car == ind) {
+ if( opptr != nil)
+ opptr->cdr = pptr->cdr->cdr;
+ else if(disemp)
+ atm->cdr = pptr->cdr->cdr;
+ else if(atm==nil)
+ nilplist = pptr->cdr->cdr;
+ else
+ atm->plist = pptr->cdr->cdr;
+ return(pptr->cdr);
+ }
+ if ((pptr->cdr)->cdr == nil) return(nil);
+ opptr = pptr->cdr;
+ pptr = (pptr->cdr)->cdr;
+ }
+}
+
+lispval
+Lbcdad()
+{
+ lispval ret, temp;
+
+ chkarg(1);
+ temp = lbot->val;
+ if (TYPE(temp)!=ATOM)
+ error("ONLY ATOMS HAVE FUNCTION BINDINGS", FALSE);
+ temp = temp->fnbnd;
+ if (TYPE(temp)!=BCD)
+ return(nil);
+ ret = newint();
+ ret->i = (int)temp;
+ return(ret);
+}
+
+lispval
+Lstringp()
+{
+ chkarg(1);
+ if (TYPE(lbot->val)==STRNG)
+ return(tatom);
+ return(nil);
+}
+
+lispval
+Lsymbolp()
+{
+ chkarg(1);
+ if (TYPE(lbot->val)==ATOM)
+ return(tatom);
+ return(nil);
+}
+
+lispval
+Lrematom()
+{
+ register lispval temp;
+
+ chkarg(1);
+ temp = lbot->val;
+ if (TYPE(temp)!=ATOM)
+ return(nil);
+ temp->a.fnbnd = nil;
+ temp->a.pname = (char *)CNIL;
+ temp->a.plist = nil;
+ (atom_items->i)--;
+ (atom_str.space_left)++;
+ temp->a.clb=(lispval)atom_str.next_free;
+ atom_str.next_free=(char *) temp;
+ return(tatom);
+}
+
+#define QUTMASK 0200
+#define VNUM 0000
+
+lispval
+Lprname()
+{
+ lispval a, ret;
+ register lispval work, prev;
+ char *front, *temp; int clean;
+ char ctemp[100];
+ extern char *ctable;
+ snpand(2);
+
+ chkarg(1);
+ a = lbot->val;
+ switch (TYPE(a)) {
+ case INT:
+ sprintf(ctemp,"%d",a->i);
+ break;
+
+ case DOUB:
+ sprintf(ctemp,"%f",a->r);
+ break;
+
+ case ATOM:
+ temp = front = a->pname;
+ clean = *temp;
+ if (*temp == '-') temp++;
+ clean = clean && (ctable[*temp] != VNUM);
+ while (clean && *temp)
+ clean = (!(ctable[*temp++] & QUTMASK));
+ if (clean)
+ strcpyn(ctemp, front, 99);
+ else
+ sprintf(ctemp,"\"%s\"",front);
+ break;
+
+ default:
+ error("prname does not support this type", FALSE);
+ }
+ temp = ctemp;
+ protect(ret = prev = newdot());
+ while (*temp) {
+ prev->cdr = work = newdot();
+ strbuf[0] = *temp++;
+ strbuf[1] = 0;
+ work->car = getatom();
+ work->cdr = nil;
+ prev = work;
+ }
+ return(ret->cdr);
+}
+Lexit()
+{
+ register lispval handy;
+ if(np-lbot==0) exit(0);
+ handy = lbot->val;
+ if(TYPE(handy)==INT)
+ exit(handy->i);
+ exit(-1);
+}
+lispval
+Iimplode(unintern)
+{
+ register lispval handy, work;
+ register char *cp = strbuf;
+ extern int atmlen; /* used by newatom and getatom */
+
+ chkarg(1);
+ for(handy = lbot->val; handy!=nil; handy = handy->cdr)
+ {
+ work = handy->car;
+ if(cp >= endstrb)
+ errorh(Vermisc,"maknam/impode argument exceeds buffer",nil,FALSE,43,lbot->val);
+ again:
+ switch(TYPE(work))
+ {
+ case ATOM:
+ *cp++ = work->pname[0];
+ break;
+ case SDOT:
+ case INT:
+ *cp++ = work->i;
+ break;
+ case STRNG:
+ *cp++ = * (char *) work;
+ break;
+ default:
+ work = errorh(Vermisc,"implode/maknam: Illegal type for this arg:",nil,FALSE,44,work);
+ goto again;
+ }
+ }
+ *cp = 0;
+ if(unintern) return((lispval)newatom());
+ else return((lispval) getatom());
+}
+
+lispval
+Lmaknam()
+{
+ return(Iimplode(TRUE)); /* unintern result */
+}
+
+lispval
+Limplode()
+{
+ return(Iimplode(FALSE)); /* intern result */
+}
--- /dev/null
+# include "global.h"
+# include <a.out.h>
+
+/************************************************************************/
+/* */
+/* Lalloc */
+/* */
+/* This lambda allows allocation of pages from lisp. The first */
+/* argument is the name of a space, n pages of which are allocated, */
+/* if possible. Returns the number of pages allocated. */
+
+lispval
+Lalloc()
+ {
+ int n;
+ register struct argent *mylbot = lbot;
+ snpand(1);
+ chkarg(2);
+ if(TYPE((mylbot+1)->val) != INT && (mylbot+1)->val != nil )
+ error("2nd ARGUMENT TO ALLOCATE MUST BE AN INTEGER",FALSE);
+ n = 1;
+ if((mylbot+1)->val != nil) n = (mylbot+1)->val->i;
+ return(alloc((mylbot)->val,n)); /* call alloc to do the work */
+ }
+
+lispval
+Lsizeof()
+ {
+ chkarg(1);
+ return(inewint(csizeof(lbot->val)));
+ }
+
+lispval
+Lsegment()
+ {
+ chkarg(2);
+chek: while(TYPE(np[-1].val) != INT )
+ np[-1].val=error("LENGTH ARG TO SEGMENT MUST BE INTEGER",TRUE);
+ if( np[-1].val->i < 0 )
+ {
+ np[-1].val = error("LENGTH ARG TO SEGMENT MUST BE POSITIVE",TRUE);
+ goto chek;
+ }
+ return(csegment((lbot)->val,np[-1].val->i));
+ }
+
+/* Lforget *************************************************************/
+/* */
+/* This function removes an atom from the hash table. */
+
+lispval
+Lforget()
+ {
+ char c,*name;
+ struct atom *buckpt;
+ int hash;
+ chkarg(1);
+ if(TYPE(lbot->val) != ATOM)
+ error("CANNOT FORGET NON-ATOM",FALSE);
+ name = lbot->val->pname;
+ hash = 0;
+ while( (c = *name++) != NULL_CHAR) hash ^= c;
+ hash = hash & 0177;
+
+ /* We have found the hash bucket for the atom, now we remove it */
+
+ if( hasht[hash] == (struct atom *)lbot->val )
+ {
+ hasht[hash] = lbot->val->hshlnk;
+ lbot->val->hshlnk = (struct atom *)CNIL;
+ return(lbot->val);
+ }
+
+ buckpt = hasht[hash];
+ while(buckpt != (struct atom *)CNIL)
+ {
+ if(buckpt->hshlnk == (struct atom *)lbot->val)
+ {
+ buckpt->hshlnk = lbot->val->hshlnk;
+ lbot->val->hshlnk = (struct atom *)CNIL;
+ return(lbot->val);
+ }
+ buckpt = buckpt->hshlnk;
+ }
+
+ /* Whoops! Guess it wasn't in the hash table after all. */
+
+ return(lbot->val);
+ }
+
+lispval
+Lgetl()
+ {
+ chkarg(1);
+ if(TYPE(lbot->val) != ARRAY)
+ error("ARG TO GETLENGTH MUST BE AN ARRAY",TRUE);
+ return(lbot->val->length);
+ }
+
+lispval
+Lputl()
+ {
+ chkarg(2);
+ if(TYPE((lbot)->val) != ARRAY)
+ error("ARG TO PUTLENGTH MUST BE AN ARRAY",FALSE);
+chek: while(TYPE(np[-1].val) != INT)
+ np[-1].val = error("ARRAY LENGTH MUST BE AN INTEGER",FALSE);
+ if(np[-1].val->i <= 0)
+ {
+ np[-1].val = error("ARRAY LENGTH MUST BE POSITIVE",TRUE);
+ goto chek;
+ }
+ return((lbot)->val->length = np[-1].val);
+ }
+lispval
+Lgetdel()
+ {
+ chkarg(1);
+ if(TYPE(lbot->val) != ARRAY)
+ error("ARG TO GETDELTA MUST BE AN ARRAY",FALSE);
+ return(lbot->val->delta);
+ }
+
+lispval
+Lputdel()
+ {
+ chkarg(2);
+ if(TYPE((np-2)->val) != ARRAY)
+ error("ARG TO PUTDELTA MUST BE AN ARRAY",FALSE);
+chek: while(TYPE(np[-1].val) != INT)
+ np[-1].val = error("ARRAY LENGTH MUST BE AN INTEGER",TRUE);
+ if(np[-1].val->i <= 0)
+ {
+ np[-1].val = error("ARRAY DELTA MUST BE POSITIVE",TRUE);
+ goto chek;
+ }
+ return((lbot)->val->delta = np[-1].val);
+ }
+
+lispval
+Lgetaux()
+ {
+ chkarg(1);
+ if(TYPE(lbot->val)!=ARRAY)
+ error("ARG TO GETAUX MUST BE ARRAY",FALSE);
+ return(lbot->val->aux);
+ }
+
+lispval
+Lputaux()
+ {
+ chkarg(2);
+
+ if(TYPE((lbot)->val)!=ARRAY)
+ error("1st ARG TO PUTAUX MUST BBE ARRAY",FALSE);
+ return((lbot)->val->aux = np[-1].val);
+ }
+
+lispval
+Lgeta()
+ {
+ chkarg(1);
+ if(TYPE(lbot->val) != ARRAY)
+ error("ARG TO GETACCESS MUST BE AN ARRAY",FALSE);
+ return(lbot->val->accfun);
+ }
+
+lispval
+Lputa()
+ {
+ chkarg(2);
+ if(TYPE((lbot)->val) != ARRAY)
+ error("ARG TO PUTACCESS MUST BE ARRAY",FALSE);
+ return((lbot)->val->accfun = np[-1].val);
+ }
+
+lispval
+Lmarray()
+{
+ register struct argent *mylbot = lbot;
+ register lispval handy;
+ snpand(2);
+ chkarg(5);
+ (handy = newarray()); /* get a new array cell */
+ handy->data=(char *)mylbot->val;/* insert data address */
+ handy->accfun = mylbot[1].val; /* insert access function */
+ handy->aux = mylbot[2].val; /* insert aux data */
+ handy->length = mylbot[3].val; /* insert length */
+ handy->delta = mylbot[4].val; /* push delta arg */
+ return(handy);
+ }
+
+lispval
+Lgetentry()
+ {
+ chkarg(1);
+ if( TYPE(lbot->val) != BCD )
+ error("ARG TO GETENTRY MUST BE FUNCTION",FALSE);
+ return((lispval)(lbot->val->entry));
+ }
+
+lispval
+Lgetlang()
+ {
+ chkarg(1);
+ while(TYPE(lbot->val)!=BCD)
+ lbot->val = error("ARG TO GETLANG MUST BE FUNCTION DESCRIPTOR",TRUE);
+ return(lbot->val->language);
+ }
+
+lispval
+Lputlang()
+ {
+ chkarg(2);
+ while(TYPE((lbot)->val)!=BCD)
+ lbot->val = error("FIRST ARG TO PUTLANG MUST BE FUNCTION DESCRIPTOR",TRUE);
+ (lbot)->val->language = np[-1].val;
+ return(np[-1].val);
+ }
+
+lispval
+Lgetparams()
+ {
+ chkarg(1);
+ if(TYPE(np[-1].val)!=BCD)
+ error("ARG TO GETPARAMS MUST BE A FUNCTION DESCRIPTOR",FALSE);
+ return(np[-1].val->params);
+ }
+
+lispval
+Lputparams()
+ {
+ chkarg(2);
+ if(TYPE((lbot)->val)!=BCD)
+ error("1st ARG TO PUTPARAMS MUST BE FUNCTION DESCRIPTOR",FALSE);
+ return((lbot)->val->params = np[-1].val);
+ }
+
+lispval
+Lgetdisc()
+ {
+ chkarg(1);
+ if(TYPE(np[-1].val) != BCD)
+ error("ARGUMENT OF GETDISC MUST BE FUNCTION",FALSE);
+ return(np[-1].val->discipline);
+ }
+
+lispval
+Lputdisc()
+ {
+ chkarg(2);
+ if(TYPE(np[-2].val) != BCD)
+ error("ARGUMENT OF PUTDISC MUST BE FUNCTION",FALSE);
+ return((np-2)->val->discipline = np[-1].val);
+ }
+
+lispval
+Lgetloc()
+ {
+ chkarg(1);
+ if(TYPE(lbot->val)!=BCD)
+ error("ARGUMENT TO GETLOC MUST BE FUNCTION",FALSE);
+ return(lbot->val->loctab);
+ }
+
+lispval
+Lputloc()
+ {
+ chkarg(2);
+ if(TYPE((lbot+1)->val)!=BCD);
+ error("FIRST ARGUMENT TO PUTLOC MUST BE FUNCTION",FALSE);
+ (lbot)->val->loctab = (lbot+1)->val;
+ return((lbot+1)->val);
+ }
+
+lispval
+Lmfunction()
+ {
+ register lispval handy;
+ chkarg(5);
+ handy = (newfunct()); /* get a new function cell */
+ handy->entry = (lispval (*)())((np-5)->val); /* insert entry point */
+ handy->discipline = ((np-4)->val); /* insert discipline */
+#ifdef ROWAN
+ handy->language = (np-3)->val; /* insert language */
+ handy->params = ((np-2)->val); /* insert parameters */
+ handy->loctab = ((np-1)->val); /* insert local table */
+#endif
+ return(handy);
+ }
+
+/** Lreplace ************************************************************/
+/* */
+/* Destructively modifies almost any kind of data. */
+
+lispval
+Lreplace()
+ {
+ register lispval a1, a2;
+ register int t;
+ chkarg(2);
+
+ if((t = TYPE(a1 = (lbot)->val)) != TYPE(a2 = np[-1].val))
+ error("REPLACE ARGS MUST BE SAME TYPE",FALSE);
+
+ switch( t )
+ {
+ case ATOM: error("REPLACE CANNOT STORE ATOMS",FALSE);
+
+ case VALUE: a1->l = a2->l;
+ return( a1 );
+
+ case INT: a1->i = a2->i;
+ return( a1 );
+
+ case STRNG: error("STORE CANNOT STORE STRINGS",FALSE);
+
+ case ARRAY: a1->data = a2->data;
+ a1->accfun = a2->accfun;
+ a1->length = a2->length;
+ a1->delta = a2->delta;
+ return( a1 );
+
+ case DOUB: a1->r = a2->r;
+ return( a1 );
+
+ case SDOT:
+ case DTPR: a1->car = a2->car;
+ a1->cdr = a2->cdr;
+ return( a1 );
+ case BCD: a1->entry = a2->entry;
+ a1->discipline = a2->discipline;
+ return( a1 );
+ }
+ /* NOT REACHED */
+ }
+
+/* Lvaluep */
+
+lispval
+Lvaluep()
+ {
+ chkarg(1);
+ if( TYPE(lbot->val) == VALUE ) return(tatom); else return(nil);
+ }
+
+CNTTYP() { return; /* HI! COUNT ONE TYPE CALL! */ }
+
+lispval
+Lod()
+ {
+ int i;
+ chkarg(2);
+
+ while( TYPE(np[-1].val) != INT )
+ np[-1].val = error("2nd ARG TO OD MUST BE INTEGER",TRUE);
+
+ for( i = 0; i < np->val->i; ++i )
+ printf(copval(odform,CNIL)->pname,(int *)(np[-2].val)[i]);
+
+ dmpport(poport);
+ return(nil);
+ }
+lispval
+Lfake()
+ {
+ chkarg(1);
+
+ if( TYPE(lbot->val) != INT )
+ error("ARG TO FAKE MUST BE INTEGER",TRUE);
+
+ return((lispval)(lbot->val->i));
+ }
+
+lispval
+Lwhat()
+ {
+ chkarg(1);
+ return(inewint((int)(lbot->val)));
+ }
+
+lispval
+Lpname()
+ {
+ chkarg(1);
+ if(TYPE(lbot->val) != ATOM)
+ error("ARG TO PNAME MUST BE AN ATOM",FALSE);
+ return((lispval)(lbot->val->pname));
+ }
+
+lispval
+Larrayref()
+ {
+ chkarg(2);
+ if(TYPE((lbot)->val) != ARRAY)
+ error("FIRST ARG TO ARRAYREF MUST BE ARRAY",FALSE);
+ vtemp = (lbot + 1)->val;
+chek: while(TYPE(vtemp) != INT)
+ vtemp = error("SECOND ARG TO ARRAYREF MUST BE INTEGER",TRUE);
+ if( vtemp->i < 0 )
+ {
+ vtemp = error("NEGATIVE ARRAY OFFSET",TRUE);
+ goto chek;
+ }
+ if( vtemp->i >= (np-2)->val->length->i )
+ {
+ vtemp = error("ARRAY OFFSET TOO LARGE",TRUE);
+ goto chek;
+ }
+ vtemp = (lispval)((np-2)->val->data + ((np-2)->val->delta->i)*(vtemp->i));
+ /* compute address of desired item */
+ return(vtemp);
+
+ }
+
+lispval
+Lptr()
+ {
+ chkarg(1);
+ return(inewval(lbot->val));
+ }
+
+lispval
+Llctrace()
+ {
+ chkarg(1);
+ lctrace = (int)(lbot->val->clb);
+ return((lispval)lctrace);
+ }
+
+lispval
+Lslevel()
+ {
+ return(inewint(np-orgnp-2));
+ }
+
+lispval
+Lsimpld()
+ {
+ register lispval pt;
+ register char *cpt = strbuf;
+
+ chkarg(1);
+
+ for(atmlen=1, pt=np->val; NOTNIL(pt); ++atmlen, pt = pt->cdr);
+
+ if( atmlen > STRBLEN )
+ {
+ error("LCODE WAS TOO LONG",TRUE);
+ return((lispval)inewstr(""));
+ }
+
+ for(pt=np->val; NOTNIL(pt); pt = pt->cdr) *(cpt++) = pt->car->i;
+ *cpt = 0;
+
+ return((lispval)newstr());
+ }
+
+
+/* Lopval *************************************************************/
+/* */
+/* Routine which allows system registers and options to be examined */
+/* and modified. Calls copval, the routine which is called by c code */
+/* to do the same thing from inside the system. */
+
+lispval
+Lopval()
+ {
+ lispval quant;
+ snpand(0);
+
+ if( lbot == np )
+ return(error("BAD CALL TO OPVAL",TRUE));
+ quant = lbot->val; /* get name of sys variable */
+ while( TYPE(quant) != ATOM )
+ quant = error("FIRST ARG TO OPVAL MUST BE AN ATOM",TRUE);
+
+ if(np > lbot+1) vtemp = (lbot+1)->val ;
+ else vtemp = CNIL;
+ return(copval(quant,vtemp));
+}
+