BSD 4 release

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

static char *sccsid = "@(#)lam8.c       34.5 11/7/80";

#include "global.h"
#include <sys/types.h>
#include <pagsiz.h>
#include "naout.h"

/* various functions from the c math library */
double sin(),cos(),asin(),acos(),atan2(),sqrt(), log(), exp();
extern int current;

lispval Imath(func)
double (*func)();
{
       register lispval handy;
       register double res;
       chkarg(1,"Math functions");

       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,"arctan");

       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,"makunbound");
       work = lbot->val;
       if(work==nil || (TYPE(work)!=ATOM))
               return(work);
       work->a.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);
}
typedef struct doub {
       unsigned short f1:7,expt:8,sign:1;
       unsigned short f2,f3p1:14,f3p2:2,f4;
} *dp;

typedef struct quad2 {
       unsigned long g4:16,g3p1:14;
} *qp2;

typedef struct quad1 {
       unsigned long g3p2:2,g2:16,g1:7,hide:1;
} *qp1;

static long workbuf[2];
static int  exponent;
static Idebig()
{
       register lispval work;
       register dp rdp;
       register qp1 rqp1;
       register qp2 rqp2;
       register struct argent *lbot,np;
       workbuf[1]  = workbuf[0] = 0;

       work = lbot->val;               /* Unfold mantissa */
       rqp2 = (qp2) workbuf + 1;
       rqp1 = (qp1) workbuf;
       rdp = (dp) work;
       rqp2->g4 = rdp->f4;
       rqp2->g3p1 = rdp->f3p1;
       rqp1->g3p2 = rdp->f3p2;
       rqp1->g2 = rdp->f2;
       rqp1->g1 = rdp->f1;
       rqp1->hide = 1;
       if(rdp->sign) {
               workbuf[0] = (- workbuf[0]);
               if(workbuf[1] = (- workbuf[1]) & 0xC0000000)
                       workbuf[0]--;
       }
       /* calcuate exponent and adjustment */
       exponent = -129 - 55 + (int) rdp->expt;
}
lispval
Lfdecom()
{
       register lispval result, handy;
       register dum1,dum2;
       register struct argent *lbot,*np;

       chkarg(1,"Decompose-float");
       while(TYPE(lbot->val)!=DOUB)
               lbot->val = error("Decompose-float: Non-real argument",TRUE);
       Idebig();
       np++->val = result = handy = newdot();
       handy->d.car = inewint(exponent);
       handy = handy->d.cdr = newdot();
       handy = handy->d.car = newsdot();
       handy->s.I = workbuf[1];
       handy = handy->s.CDR = newsdot();
       handy->s.I = workbuf[0];
}

lispval
Lfseek()
{
       register lispval result, handy;
       register dum1,dum2;
       register struct argent *lbot,*np;

       FILE *f;
       long disk_addr, offset, whence;
       lispval retp;

       chkarg(3,"fseek");                      /* Make sure there are three arguments*/

       f = lbot->val->p;               /* Get first argument into f */
       if (TYPE(lbot->val)!=PORT)      /* Check type of first */
               error("fseek: First argument must be a port.",FALSE);

       offset = lbot[1].val->i;        /* Get second argument */
       if (TYPE(lbot[1].val)!=INT)
               error("fseek: Second argument must be an integer.",FALSE);

       whence = lbot[2].val->i;        /* Get last arg */
       if (TYPE(lbot[2].val)!=INT)
               error("fseek: Third argument must be an integer.",FALSE);

       if (fseek(f, offset, whence) == -1)
               error("fseek: Illegal parameters.",FALSE);

       retp = inewint(ftell(f));

       return((lispval) retp);
}

/* function hashtabstat  : return list of number of members in  each bucket */
lispval Lhashst()
{
       register lispval handy,cur;
       register struct atom *pnt;
       int i,cnt;
       extern int hashtop;
       snpand(3);

       handy = newdot();
       protect(handy);
       cur = handy;
       for(i = 0; i < hashtop; i++)
       {
           pnt = hasht[i];
           for(cnt = 0; pnt != (struct atom *) CNIL ; pnt=pnt->hshlnk , cnt++);
           cur->d.cdr = newdot();
           cur = cur->d.cdr;
           cur->d.car = inewint(cnt);
       }
       cur->d.cdr = nil;
       return(handy->d.cdr);
}


/* Lctcherr
 this routine should only be called by the unwind protect simulation
 lisp code
 It is called after an unwind-protect frame has been entered and
 evalated and we want to get on with the error or throw
 We only handle the case where there are 0 to 2 extra arguments to the
 error call.
*/
lispval
Lctcherr()
{
       register lispval handy;
       lispval type,messg,valret,contuab,uniqid,datum1,datum2;
       snpand(1);

       if(lbot-np==0) protect(nil);
       if((handy = lbot->val) == nil) return(nil);

       if(handy->d.car == tatom)
       {       /* continuaing a throw */
               Idothrow(handy->d.cdr->d.car, handy->d.cdr->d.cdr->d.car);
               error("ctcherr: throw label gone!",FALSE);
       }

       /* decode the arg list */
       handy = handy->d.cdr;
       type = handy->d.car;
       handy = handy->d.cdr;
       messg = handy->d.car;
       handy = handy->d.cdr;
       valret = handy->d.car;
       handy = handy->d.cdr;
       contuab = handy->d.car;
       handy = handy->d.cdr;
       uniqid = handy->d.car;
       handy = handy->d.cdr;

       /* if not extra args */
       if(handy == nil)
       {
         errorh(type,messg->a.pname,valret,contuab->i,uniqid->i);
       }
       datum1 = handy->d.car;
       handy = handy->d.cdr;

       /* if one extra arg */
       if(handy == nil)
       {
         errorh(type,messg->a.pname,valret,contuab->i,uniqid->i,datum1);
       }

       /* if two or more extra args, just use first 2 */
       datum2 = handy->d.car;
       errorh(type,messg->a.pname,valret,contuab->i,uniqid->i,datum1,datum2);
}

/*
*      (*makhunk '<fixnum>)
*                        <fixnum>
* Create a hunk of size 2       . <fixnum> must be between 0 and 6.
*
*/

lispval
LMakhunk()
{
       register int hsize, hcntr;
       register lispval result;

       chkarg(1,"Makehunk");
       if (TYPE(lbot->val)==INT)
       {
               hsize = lbot->val->i;           /* size of hunk (0-6) */
               if ((hsize >= 0) && (hsize <= 6))
               {
                       result = newhunk(hsize);
                       hsize = 2 << hsize;     /* size of hunk (2-128) */
                       for (hcntr = 0; hcntr < hsize; hcntr++)
                               result->h.hunk[hcntr] = hunkfree;
               }
               else
                       error("*makhunk: Illegal hunk size", FALSE);
       return(result);
       }
       else
               error("*makhunk: First arg must be an fixnum",FALSE);
}

/*
*      (cxr '<fixnum> '<hunk>)
* Returns the <fixnum>'th element of <hunk>
*
*/
lispval
Lcxr()
{
       register lispval temp;

       chkarg(2,"cxr");
       if (TYPE(lbot->val)!=INT)
               error("cxr: First arg must be a fixnum", FALSE);
       else
       {
               if (! HUNKP(lbot[1].val))
                       error("cxr: Second arg must be a hunk", FALSE);
               else
                       if ( (lbot->val->i >= 0) &&
                            (lbot->val->i < (2 << HUNKSIZE(lbot[1].val))) )
                       {
                               temp = lbot[1].val->h.hunk[lbot->val->i];
                               if (temp != hunkfree)
                                       return(temp);
                               else
                                       error("cxr: Arg outside of hunk range",
                                             FALSE);
                       }
                       else
                               error("cxr: Arg outside of hunk range", FALSE);
       }
}

/*
*      (rplacx '<fixnum> '<hunk> '<expr>)
* Replaces the <fixnum>'th element of <hunk> with <expr>.
*
*/
lispval
Lrplacx()
{
       lispval *handy;
       chkarg(3,"rplacx");
       if (TYPE(lbot->val)!=INT)
               error("rplacx: First arg must be a fixnum", FALSE);
       else
       {
               if (! HUNKP(lbot[1].val))
                       error("rplacx: Second arg must be a hunk", FALSE);
               else
               {
                       if ( (lbot->val->i >= 0) &&
                            (lbot->val->i < (2 << HUNKSIZE(lbot[1].val))) )
                       {
                          if (*(handy = &(lbot[1].val->h.hunk[lbot->val->i]))
                                       != hunkfree)
                                   *handy  = lbot[2].val;
                               else
                                       error("rplacx: Arg outside hunk range", FALSE);
                       }
                       else
                               error("rplacx: Arg outside hunk range", FALSE);
               }
       }
       return(lbot[1].val);
}

/*
*      (*rplacx '<fixnum> '<hunk> '<expr>)
* Replaces the <fixnum>'th element of <hunk> with <expr>. This is the
* same as (rplacx ...) except with this function you can replace EMPTY's.
*
*/
lispval
Lstarrpx()
{
       chkarg(3,"*rplacx");
       if (TYPE(lbot->val)!=INT)
               error("*rplacx: First arg must be a fixnum", FALSE);
       else
       {
               if (! HUNKP(lbot[1].val))
                       error("*rplacx: Second arg must be a hunk", FALSE);
               else
               {
                       if ( (lbot->val->i >= 0) &&
                            (lbot->val->i < (2 << HUNKSIZE(lbot[1].val))) )
                               lbot[1].val->h.hunk[lbot->val->i] = lbot[2].val;
                       else
                               error("*rplacx: Arg outside hunk range", FALSE);
               }
       }
       return(lbot[1].val);
}

/*
*      (hunksize '<hunk>)
* Returns the size of <hunk>
*
*/
lispval
Lhunksize()
{
       register int size,i;

       chkarg(1,"hunksize");
       if (HUNKP(lbot->val))
       {
               size = 2 << HUNKSIZE(lbot->val);
               for (i = size-1; i >= 0; i--)
               {
                       if (lbot->val->h.hunk[i] != hunkfree)
                       {
                               size = i + 1;
                               break;
                       }
               }
               return( inewint(size) );
       }
       else
               error("hunksize: First argument must me a hunk", FALSE);
}

/*
*      (fileopen  filename mode)
* open a file for read, write, or append the arguments can be either
* strings or atoms.
*/
lispval
Lfileopen()
{
       FILE *port;
       register lispval name;
       register lispval mode;
       register char *namech;
       register char *modech;
       register struct argent *lbot, *np;
       int typ;

       chkarg(2,"fileopen");
       name = lbot->val;
       mode = lbot[1].val;

       namech = (char *) verify(name,"fileopen:args must be atoms or strings");
       modech = (char *) verify(mode,"fileopen:args must be atoms or strings");

       while (modech[0] != 'r' && modech[0] != 'w' && modech[0] != 'a')
       {
               mode = errorh(Vermisc,"Modes are only r, w, a.",nil,TRUE,31,(char *) 0);
               modech = (char *) verify(mode,"fileopen:args must be atoms or strings");
       }

       while ((port = fopen(namech, modech)) == NULL)
       {
           name = errorh(Vermisc,"Unable to open file.",nil,TRUE,31,name);
           namech = (char *) verify(name,"fileopen:args must be atoms or strings");
       }
                   /* xports is a FILE *, cc complains about adding pointers */

       return( (lispval) (xports + (port - _iob)));
}

/*
*      (*mod '<number> '<modulus>)
* This function returns <number> mod <modulus> (for balanced modulus).
* It is used in vaxima as a speed enhancement.
*/
lispval
LstarMod()
{
       register int mod_div_2, number, modulus;

       chkarg(2,"*mod");
       if ((TYPE(lbot->val) == INT) && (TYPE(lbot[1].val) == INT))
       {
               modulus = lbot[1].val->i;
               number = lbot->val->i % modulus;
               mod_div_2 = modulus / 2;
               if (number < 0)
               {
                       if (number < (-mod_div_2))
                               number += modulus;
               }
               else
               {
                       if (number > mod_div_2)
                               number -= modulus;
               }
               return( inewint(number) );
       }
       else
               error("*mod: Arguments must be fixnums", FALSE);
}
lispval
Llsh()
{
       register struct argent *mylbot = lbot;
       int val,shift;

       chkarg(2,"lsh");
       if((TYPE(mylbot->val) != INT) || (TYPE(mylbot[1].val) != INT))
               errorh(Vermisc,
                      "Non ints to lsh",
                      nil,FALSE,0,mylbot->val,mylbot[1].val);
       val = mylbot[0].val->i;
       shift = mylbot[1].val->i;
       if(shift < -32 || shift > 32)
         return(inewint(0));
       val = val << shift;     /* do the shift */
       if((val < 0) && (shift < 0))
       {       /* special case: the vax doesn't have a logical shift
                  instruction, so we must zero out the ones which
                  will propogate from the sign position
               */
               return(inewint ( val & ~(0x80000000 << (shift+1))));
       }
       else return( inewint(val));
}

lispval
Lrot()
{
       register rot,val;               /* these must be the first registers */
       register struct argent *mylbot = lbot;

       chkarg(2,"rot");
       if((TYPE(mylbot->val) != INT) || (TYPE(mylbot[1].val) != INT))
               errorh(Vermisc,
                      "Non ints to rot",
                      nil,FALSE,0,mylbot->val,mylbot[1].val);
       val = mylbot[0].val->i;
       rot = mylbot[1].val->i;
       rot = rot % 32 ;        /* bring it down below one byte in size */
       asm(" rotl r11,r10,r10 ");  /* rotate val by rot and put back in val */
       return( inewint(val));
}

/*----------------- vms routines to simulate dumplisp -------------------- */
#ifdef VMS

extern char firstalloc[];
extern int lsbrkpnt;
extern char zfreespace[];
extern int end;

#define roundup(a,b) (((a-1)|(b-1))+1)
lispval
Lsavelsp()
{
       char *filnm;
       int fp,i,num,start;

       chkarg(1,"savelisp");

       filnm = (char *) verify(lbot->val, "savelisp: non atom arg");
       if((fp=creat(filnm,0666)) < 0)
               errorh(Vermisc,"savelisp: can't open file",nil,FALSE,0,
                                         lbot->val);
       start = roundup((int)firstalloc,PAGSIZ);
       num = roundup(((int)lsbrkpnt)-NBPG-start,PAGSIZ);
       if((num = write(fp,start,num)) <= 0)
               error("savelisp: write failed ",FALSE);
       printf(" %x bytes written from %x to %x \n",num,start,start+num-1);
       close(fp);
       return(tatom);
}

lispval
Lrestlsp()
{
       char *filnm;
       int fp,i,num,start;
       extern int xcycle;

       chkarg(1,"restorelisp");

       filnm = (char *) verify(lbot->val,"restorelisp: non atom arg");
       if((fp=open(filnm,0)) < 0)
               errorh(Vermisc,"restorelisp: can't open file",nil,FALSE,0,
                                            lbot->val);

       start = roundup((int)firstalloc,PAGSIZ);
       if((num = vread(fp,start,((int)&end)-start)) <= 0)
               error("restorelisp: read failed " ,FALSE);
       printf(" %x bytes read into %x to %x\n",num,start,start+num-1);
       xcycle = 0;     /* indicate no saved pages to xsbrk */
       close(fp);
       bnp = orgbnp;
       lbot = np = orgnp;
       contval = 0;
       reset(BRRETB);                  /* reset */
}
#endif

/*----------------------------------------------------------- */


/* getaddress --
*
* (getaddress '|_entry1| 'fncname1 '|_entry2| 'fncname2 ...)
*
* binds value of symbol |_entry1| to function defition of atom fncname1, etc.
*
* returns fnc-binding of fncname1.
*
*/

lispval
Lgetaddress(){
       register struct argent *mlbot = lbot;
       register lispval work;
       register int numberofargs, i;
       register struct argent *lbot, *np;
       char *gstab();
       char ostabf[128];
       struct nlist NTABLE[100];
       lispval dispget();

       snpand(2);

       if(np-lbot == 2) protect(nil);  /* allow 2 args */
       numberofargs = (np - lbot)/3;
       if(numberofargs * 3 != np-lbot)
          error("getaddress: arguments must come in triples ",FALSE);

       for ( i=0; i<numberofargs; i++,mlbot += 3) {
               NTABLE[i].n_value = 0;
               mlbot[0].val = verify(mlbot[0].val,"Incorrect entry specification for binding");
               NTABLE[i].n_un.n_name = (char *) mlbot[0].val;
               while(TYPE(mlbot[1].val) != ATOM)
                       mlbot[1].val = errorh(Vermisc,
                                       "Bad associated atom name for binding",
                                         nil,TRUE,0,mlbot[1].val);
               mlbot[2].val = dispget(mlbot[2].val,"getaddress: Incorrect discipline specification ",Vsubrou->a.pname);
       }
       NTABLE[(numberofargs)].n_un.n_name = "";
       strcpyn(ostabf,gstab(),128);
       if ( nlist(ostabf,NTABLE) == -1 ) {
           errorh(Vermisc,"Getaddress: Bad file",nil,FALSE,0,inewstr(ostabf));
       } else 
           for (i=0,mlbot=lbot+1; i<numberofargs; i++,mlbot+=3) {
               if ( NTABLE[i].n_value == 0 )
                   fprintf(stderr,"Undefined symbol: %s\n",
                             NTABLE[i].n_un.n_name);
               else {
                   work= newfunct();
                   work->bcd.entry = (lispval (*) ())NTABLE[i].n_value;
                   work->bcd.discipline = mlbot[1].val;
                   mlbot->val->a.fnbnd = work;
               }
           };
       return(lbot[1].val->a.fnbnd);
};

/* very temporary function to test the validity of the bind stack */

bndchk()
{  
       register struct nament *npt;
       register lispval in2;

       in2 = inewint(200);
       for(npt=orgbnp; npt < bnp; npt++)
       {  if((int) npt->atm < (int) in2) asm(" halt ");
       }
}

/*
*      formatted printer for lisp data
*    use: (cprintf formatstring datum [port])
*/
lispval
Lcprintf()
{
   FILE *p;
   char *fstrng;
   lispval v;
   if(np-lbot == 2) protect(nil);      /* write to standard output port */
   chkarg(3,"cprintf");

   fstrng = (char *)verify(lbot->val,"cprintf: first arg not string or symbol");

   p = okport(lbot[2].val,okport(Vpoport->a.clb,poport));

   switch(TYPE(v=lbot[1].val)) {

       case INT:  fprintf(p,fstrng,v->i);
                  break;

       case DOUB: fprintf(p,fstrng,v->r);
                  break;

       case ATOM: fprintf(p,fstrng,v->a.pname);
                  break;

       case STRNG:fprintf(p,fstrng,v);
                  break;

       default:   error("cprintf: Illegal second argument",FALSE);
  };

  return(lbot[1].val);
}

lispval
Lprobef()
{
       char *name;
       chkarg(1,"probef");

       name = (char *)verify(lbot->val,"probef: not symbol or string arg ");

       if(access(name,0) == 0) return(tatom);
       else return(nil);
}

lispval
Lsubstring()
{       register char *name;
       register lispval index,length;
       int restofstring = FALSE;
       int len,ind,reallen;
       extern char strbuf[];

       switch (np-lbot) 
       {
         case 2: restofstring = TRUE;
                 break;

         case 3: break;

         default: chkarg(3,"substring");
       }

       name = (char *)verify(lbot[0].val,"substring: not symbol or string arg ");

       while (TYPE(index = lbot[1].val) != INT)
       {  lbot[1].val = errorh(Vermisc,"substring: non integer index ",nil,
                                                   TRUE,0,index);
       }

       len = strlen(name);
       ind = index->i;

       if(ind < 0) ind = len+1 + ind;

       if(ind < 1 || ind > len) return(nil);   /*index out of bounds*/
       if(restofstring) return((lispval)inewstr(name+ind-1));

       while (TYPE(length = lbot[2].val) != INT)
       { lbot[2].val = errorh(Vermisc,"substring: not integer length ",nil,
                                                  TRUE,0,length);
       }

       if((reallen = length->i ) < 0 || (reallen + ind) > len)
         return((lispval)inewstr(name+ind-1));

       strncpy(strbuf,name+ind-1,reallen);
       strbuf[reallen] = '\0';
       return((lispval)newstr());
}

lispval
Lsubstringn()
{
       register char *name;
       register int len,ind,reallen;
       lispval index,length;
       int restofstring = FALSE;
       snpand(4);

       if((np-lbot) == 2) restofstring = TRUE;
       else { chkarg(3,"substringn");}

       name = (char *) verify(lbot[0].val,"substringn: non symbol or string arg ");

       while (TYPE(index = lbot[1].val) != INT)
       {  lbot[1].val = errorh(Vermisc,"substringn: non integer index ",nil,
                                                   TRUE,0,index);
       }

       if(!restofstring)
       {
           while (TYPE(length = lbot[2].val) != INT)
           { lbot[2].val = errorh(Vermisc,"substringn: not integer length ",
                                                       nil, TRUE,0,length);
           }
           reallen = length->i;
       }
       else reallen = -1;

       len = strlen(name);
       ind = index->i;
       if(ind < 0) ind = len + 1 + ind;
       if( ind < 1 || ind > len) return(nil);

       if(reallen == 0) 
           return((lispval)inewint(*(name + ind - 1)));
       else {
           char *pnt = name + ind - 1;
           char *last = name + len -1;
           lispval cur,start;

           protect(cur = start = newdot());
           cur->d.car = inewint(*pnt);
           while(++pnt <= last && --reallen != 0)
           {
              cur->d.cdr = newdot();
              cur = cur->d.cdr;
              cur->d.car = inewint(*pnt);
           }
           return(start);
       }

}