BSD 4 release

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

static char *sccsid = "@(#)lamr.c       34.3 10/31/80";

# include "global.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,"alloc");
       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,"sizeof");
       return(inewint(csizeof(lbot->val)));
       }

lispval
Lsegment()
       {
       chkarg(2,"segment");
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,FALSE));
       }

/*  Lforget  *************************************************************/
/*                                                                      */
/*  This function removes an atom from the hash table.                  */

lispval
Lforget()
       {
       char c,*name;
       struct atom *buckpt;
       int hash;
       chkarg(1,"forget");
       if(TYPE(lbot->val) != ATOM)
               error("remob: non-atom argument",FALSE);
       name = lbot->val->a.pname;
       hash = hashfcn(name);

       /*  We have found the hash bucket for the atom, now we remove it  */

       if( hasht[hash] == (struct atom *)lbot->val )
               {
               hasht[hash] = lbot->val->a.hshlnk;
               lbot->val->a.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->a.hshlnk;
                       lbot->val->a.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,"getlength");
       if(TYPE(lbot->val) != ARRAY)
               error("ARG TO GETLENGTH MUST BE AN ARRAY",TRUE);
       return(lbot->val->ar.length);
       }

lispval
Lputl()
       {
       chkarg(2,"putlength");
       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->ar.length = np[-1].val);
       }
lispval
Lgetdel()
       {
       chkarg(1,"getdelta");
       if(TYPE(lbot->val) != ARRAY)
               error("ARG TO GETDELTA MUST BE AN ARRAY",FALSE);
       return(lbot->val->ar.delta);
       }

lispval
Lputdel()
       {
       chkarg(2,"putdelta");
       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->ar.delta = np[-1].val);
       }

lispval
Lgetaux()
       {
       chkarg(1,"getaux");
       if(TYPE(lbot->val)!=ARRAY)
               error("Arg to getaux must be an array", FALSE);
       return(lbot->val->ar.aux);
       }

lispval
Lputaux()
       {
       chkarg(2,"putaux");

       if(TYPE((lbot)->val)!=ARRAY)
               error("1st Arg to putaux must be array", FALSE);
       return((lbot)->val->ar.aux = np[-1].val);
       }

lispval
Lgetdata()
       {
       chkarg(1,"getdata");
       if(TYPE(lbot->val)!=ARRAY)
               error("Arg to getdata must be an array", FALSE);
       return((lispval)lbot->val->ar.data);
       }

lispval
Lputdata()
       {
       chkarg(2,"putdata");

       if(TYPE((lbot)->val)!=ARRAY)
               error("1st Arg to putaux must be array", FALSE);
       return((lbot)->val->ar.data = (char *)np[-1].val);
       }

lispval
Lgeta()
       {
       chkarg(1,"getaccess");
       if(TYPE(lbot->val) != ARRAY)
               error("ARG TO GETACCESS MUST BE AN ARRAY",FALSE);
       return(lbot->val->ar.accfun);
       }

lispval
Lputa()
       {
       chkarg(2,"putaccess");
       if(TYPE((lbot)->val) != ARRAY)
               error("ARG TO PUTACCESS MUST BE ARRAY",FALSE);
       return((lbot)->val->ar.accfun = np[-1].val);
       }

lispval
Lmarray()
{
       register struct argent *mylbot = lbot;
       register lispval handy;
       snpand(2);
       chkarg(5,"marray");
       (handy = newarray());           /*  get a new array cell  */
       handy->ar.data=(char *)mylbot->val;/*  insert data address  */
       handy->ar.accfun = mylbot[1].val;       /*  insert access function  */
       handy->ar.aux = mylbot[2].val;  /*  insert aux data  */
       handy->ar.length = mylbot[3].val;       /*  insert length  */
       handy->ar.delta = mylbot[4].val;        /*  push delta arg  */
       return(handy);
       }

lispval
Lgetentry()
       {
       chkarg(1,"getentry");
       if( TYPE(lbot->val) != BCD )
               error("ARG TO GETENTRY MUST BE FUNCTION",FALSE);
       return((lispval)(lbot->val->bcd.entry));
       }

lispval
Lgetlang()
       {
       chkarg(1,"getlang");
       while(TYPE(lbot->val)!=BCD)
               lbot->val = error("ARG TO GETLANG MUST BE FUNCTION DESCRIPTOR",TRUE);
       return(lbot->val->bcd.language);
       }

lispval
Lputlang()
       {
       chkarg(2,"putlang");
       while(TYPE((lbot)->val)!=BCD)
               lbot->val = error("FIRST ARG TO PUTLANG MUST BE FUNCTION DESCRIPTOR",TRUE);
       (lbot)->val->bcd.language = np[-1].val;
       return(np[-1].val);
       }

lispval
Lgetparams()
       {
       chkarg(1,"getparams");
       if(TYPE(np[-1].val)!=BCD)
               error("ARG TO GETPARAMS MUST BE A FUNCTION DESCRIPTOR",FALSE);
       return(np[-1].val->bcd.params);
       }

lispval
Lputparams()
       {
       chkarg(2,"putparams");
       if(TYPE((lbot)->val)!=BCD)
               error("1st ARG TO PUTPARAMS MUST BE FUNCTION DESCRIPTOR",FALSE);
       return((lbot)->val->bcd.params = np[-1].val);
       }

lispval
Lgetdisc()
       {
       chkarg(1,"getdisc");
       if(TYPE(np[-1].val) != BCD)
               error("ARGUMENT OF GETDISC MUST BE FUNCTION",FALSE);
       return(np[-1].val->bcd.discipline);
       }

lispval
Lputdisc()
       {
       chkarg(2,"putdisc");
       if(TYPE(np[-2].val) != BCD)
               error("ARGUMENT OF PUTDISC MUST BE FUNCTION",FALSE);
       return((np-2)->val->bcd.discipline  = np[-1].val);
       }

lispval
Lgetloc()
       {
       chkarg(1,"getloc");
       if(TYPE(lbot->val)!=BCD)
               error("ARGUMENT TO GETLOC MUST BE FUNCTION",FALSE);
       return(lbot->val->bcd.loctab);
       }

lispval
Lputloc()
       {
       chkarg(2,"putloc");
       if(TYPE((lbot+1)->val)!=BCD);
               error("FIRST ARGUMENT TO PUTLOC MUST BE FUNCTION",FALSE);
       (lbot)->val->bcd.loctab = (lbot+1)->val;
       return((lbot+1)->val);
       }

lispval
Lmfunction()
       {
       register lispval handy;
       chkarg(2,"mfunction");
       handy = (newfunct());   /*  get a new function cell  */
       handy->bcd.entry = (lispval (*)())((np-5)->val);        /* insert entry point */
       handy->bcd.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,"replace");

       if((t = TYPE(a1 = (lbot)->val)) != TYPE(a2 = np[-1].val))
               error("REPLACE ARGS MUST BE SAME TYPE",FALSE);

       switch( t )
               {

       case VALUE:     a1->l = a2->l;
                       return( a1 );

       case INT:       a1->i = a2->i;
                       return( a1 );


       case ARRAY:     a1->ar.data = a2->ar.data;
                       a1->ar.accfun = a2->ar.accfun;
                       a1->ar.length = a2->ar.length;
                       a1->ar.delta = a2->ar.delta;
                       return( a1 );

       case DOUB:      a1->r = a2->r;
                       return( a1 );

       case SDOT:
       case DTPR:      a1->d.car = a2->d.car;
                       a1->d.cdr = a2->d.cdr;
                       return( a1 );
       case BCD:       a1->bcd.entry = a2->bcd.entry;
                       a1->bcd.discipline = a2->bcd.discipline;
                       return( a1 );
       default:
                       errorh(Vermisc,"Replace: cannot handle the type of this arg",
                                                nil,FALSE,0,a1);
               }
       /* NOT REACHED */
       }

/* Lvaluep */

lispval
Lvaluep()
       {
       chkarg(1,"valuep");
       if( TYPE(lbot->val) == VALUE ) return(tatom); else return(nil);
       }

CNTTYP() { return; /* HI! COUNT ONE TYPE CALL! */ }

lispval
Lod()
       {
       int i;
       chkarg(2,"od");

       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)->a.pname,((int *)(np[-2].val))[i]);

       dmpport(poport);
       return(nil);
       }
lispval
Lfake()
       {
       chkarg(1,"fake");

       if( TYPE(lbot->val) != INT )
               error("ARG TO FAKE MUST BE INTEGER",TRUE);

       return((lispval)(lbot->val->i));
       }

       /* this used to be Lwhat, but was changed to Lmaknum for maclisp
          compatiblity
       */
lispval
Lmaknum()
       {
       chkarg(1,"maknum");
       return(inewint((int)(lbot->val)));
       }

lispval
Lpname()
       {
       chkarg(1,"pname");
       if(TYPE(lbot->val) != ATOM)
               error("ARG TO PNAME MUST BE AN ATOM",FALSE);
       return((lispval)(lbot->val->a.pname));
       }

lispval
Larrayref()
       {
       chkarg(2,"arrayref");
       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->ar.length->i )
               {
               vtemp = error("ARRAY OFFSET TOO LARGE",TRUE);
               goto chek;
               }
       vtemp = (lispval)((np-2)->val->ar.data + ((np-2)->val->ar.delta->i)*(vtemp->i));
               /*  compute address of desired item  */
       return(vtemp);
                       
       }

lispval
Lptr()
       {
       chkarg(1,"ptr");
       return(inewval(lbot->val));
       }

lispval
Llctrace()
       {
       chkarg(1,"lctrace");
       lctrace = (int)(lbot->val->a.clb);
       return((lispval)lctrace);
       }

lispval
Lslevel()
       {
       return(inewint(np-orgnp-2));
       }

lispval
Lsimpld()
       {
       register lispval pt;
       register char *cpt = strbuf;

       chkarg(1,"simpld");

       for(atmlen=1, pt=np->val; NOTNIL(pt); ++atmlen, pt = pt->d.cdr);

       if( atmlen > STRBLEN )
               {
               error("LCODE WAS TOO LONG",TRUE);
               return((lispval)inewstr(""));
               }

       for(pt=np->val; NOTNIL(pt); pt = pt->d.cdr) *(cpt++) = pt->d.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));
}