4.4BSD/usr/src/old/lisp/franz/lam8.c
#ifndef lint
static char *rcsid =
"$Header: lam8.c,v 1.17 87/12/14 18:48:09 sklower Exp $";
#endif
/* -[Thu Sep 29 22:24:10 1983 by jkf]-
* lam8.c $Locker: $
* lambda functions
*
* (c) copyright 1982, Regents of the University of California
*/
#include "global.h"
#include <sys/types.h>
#include <sys/stat.h>
#include "frame.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)) errorh1(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
Lfseek()
{
FILE *f;
long 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, (int)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;
Savestack(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;
Restorestack();
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;
chkarg(1,"I-throw-err");
handy = lbot->val;
if(TYPE(handy->d.car) == INT)
{ /* continuing a non error (throw,reset, etc) */
Inonlocalgo((int)handy->d.car->i,
handy->d.cdr->d.car,
handy->d.cdr->d.cdr->d.car);
/* NOT REACHED */
}
if(handy->d.car != nil)
{
errorh1(Vermisc,"I-do-throw: first element not fixnum or nil",
nil,FALSE,0,handy);
}
/* 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,(int)contuab->i,(int)uniqid->i);
}
datum1 = handy->d.car;
handy = handy->d.cdr;
/* if one extra arg */
if(handy == nil)
{
errorh1(type,messg->a.pname,valret,(int)contuab->i,(int)uniqid->i,datum1);
}
/* if two or more extra args, just use first 2 */
datum2 = handy->d.car;
errorh2(type,messg->a.pname,valret,(int)contuab->i,(int)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);
/* NOTREACHED */
}
/*
* (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);
}
/* NOTREACHED */
}
/*
* (rplacx '<fixnum> '<hunk> '<expr>)
* Replaces the <fixnum>'th element of <hunk> with <expr>.
*
*/
lispval
Lrplcx()
{
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);
/* NOTREACHED */
}
/*
* (hunk-to-list 'hunk) returns a list of the hunk elements
*/
lispval
Lhtol()
{
register lispval handy,retval,last;
register int i;
int size;
Savestack(4);
chkarg(1,"hunk-to-list");
handy = lbot->val;
if(!(HUNKP(handy)))
errorh1(Vermisc,"hunk-to-list: non hunk argument: ", nil,0,FALSE,
handy);
size = 2 << HUNKSIZE(handy);
retval = nil;
for(i=0 ; i < size ; i++)
{
if(handy->h.hunk[i] != hunkfree)
{
if(retval==nil)
{
protect(retval=newdot());
last = retval;
}
else {
last = (last->d.cdr = newdot());
}
last->d.car = handy->h.hunk[i];
}
else break;
}
Restorestack();
return(retval);
}
/*
* (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;
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);
modech = (char *) verify(mode,"fileopen:args must be atoms or strings");
}
while ((port = fopen(namech, modech)) == NULL)
{
name = errorh1(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 */
ioname[PN(port)] = (lispval) inewstr(namech); /* remember name */
return(P(port));
}
/*
* (*invmod '<number> '<modulus>)
* This function returns the inverse of <number>
* mod <modulus> in balanced representation
* It is used in vaxima as a speed enhancement.
*/
static lispval
Ibalmod(invmodp)
{
register long mod_div_2, number, modulus;
chkarg(2,"*mod");
if ((TYPE(lbot->val) == INT) && (TYPE(lbot[1].val) == INT))
{
modulus = lbot[1].val->i;
if(invmodp) number = invmod(lbot->val->i , modulus);
else 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);
/* NOTREACHED */
}
invmod (n,modulus)
long n , modulus;
{
long a1,a2,a3,y1,y2,y3,q;
a1 = modulus;
a2 = n;
y1 = 0;
y2= 1;
goto step3;
step2:
q = a1 /a2; /*truncated quotient */
a3= mmuladd(modulus-a2,q,a1,modulus);
y3= mmuladd(modulus-y2,q,y1,modulus);
a1 = a2;
a2= a3;
y1=y2;
y2=y3;
step3:
if (a2==0) error("invmod: inverse of zero divisor",TRUE);
else if (a2 != 1) goto step2;
else return (y2);
/* NOTREACHED */
}
lispval
Lstarinvmod()
{
return(Ibalmod(TRUE));
}
/*
* (*mod '<number> '<modulus>)
* This function returns <number> mod <modulus> (for balanced modulus).
* It is used in vaxima as a speed enhancement.
*/
lispval
LstarMod()
{
return(Ibalmod(FALSE));
}
lispval
Llsh()
{
register struct argent *mylbot = lbot;
int val,shift;
chkarg(2,"lsh");
if((TYPE(mylbot->val) != INT) || (TYPE(mylbot[1].val) != INT))
errorh2(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));
if (shift < 0)
val = val >> -shift;
else
val = val << 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));
}
/* 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) abort();
}
}
/*
* 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);
}
/*
* C style sprintf: (sprintf "format" {<arg-list>})
*
* This function stacks the arguments onto the C stack in reverse
* order and then calls sprintf with one argument...This is what the
* C compiler does, so it works just fine. The return value is the
* string that is the result of the sprintf.
*/
lispval
Lsprintf()
{
register struct argent *argp;
register int j;
char sbuf[600]; /* better way? */
Keepxs();
if (np-lbot == 0) {
argerr("sprintf");
}
if (TYPE(lbot->val)==STRNG || TYPE(lbot->val)==INT) {
for (argp = np-1; argp >= lbot; argp--) {
switch(TYPE(argp->val)) {
case ATOM:
stack((long)argp->val->a.pname);
break;
case DOUB:
#ifndef SPISFP
stack(argp->val->r);
#else
{double rr = argp->val->r;
stack(((long *)&rr)[1]);
stack(((long *)&rr)[0]);}
#endif
break;
case INT:
stack(argp->val->i);
break;
case STRNG:
stack((long)argp->val);
break;
default:
error("sprintf: Bad data type to sprintf",
FALSE);
}
}
sprintf(sbuf);
for (j = 0; j < np-lbot; j++)
unstack();
} else
error("sprintf: First arg must be an atom or string", FALSE);
Freexs();
return ((lispval) inewstr(sbuf));
}
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;
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 = errorh1(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 = errorh1(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(0));
}
/*
* This is substringn
*/
lispval
Lsstrn()
{
register char *name;
register int len,ind,reallen;
lispval index,length;
int restofstring = FALSE;
Savestack(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 = errorh1(Vermisc,"substringn: non integer index ",nil,
TRUE,0,index);
}
if(!restofstring)
{
while (TYPE(length = lbot[2].val) != INT)
{ lbot[2].val = errorh1(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);
}
Restorestack();
return(start);
}
}
/*
* (character-index 'string 'char)
* return the index of char in the string.
* return nil if not present
* char can be a fixnum (representing a character)
* a symbol or string (in which case the first char is used)
*
*/
#if os_unix_ts
#define index strchr
#endif
lispval
Lcharindex()
{
register char *string;
register char ch;
char *str2;
chkarg(2,"character-index");
string = (char *)verify(lbot[0].val,"character-index: non symbol or string arg ");
if(TYPE(lbot[1].val) == INT)
ch = (char) lbot[1].val->i;
else {
str2 = (char *) verify(lbot[1].val,"character-index: bad first argument ");
ch = *str2; /* grab the first character */
}
if((str2 = (char *) index(string,ch)) == 0) return(nil); /* not there */
/* return 1-based index of character */
return(inewint(str2-string+1));
}
lispval Ipurcopy();
lispval
Lpurcopy()
{
chkarg(1,"purcopy");
return(Ipurcopy(lbot[0].val));
}
lispval
Ipurcopy(handy)
lispval handy;
{
extern int *beginsweep;
register lispval retv, curv, lv;
int i,size;
switch(TYPE(handy)) {
case DTPR:
retv = curv = pnewdot();
lv = handy;
while(TRUE)
{
curv->d.car = Ipurcopy(lv->d.car);
if(TYPE(lv = lv->d.cdr) == DTPR)
{
curv->d.cdr = pnewdot();
curv = curv->d.cdr;
}
else {
curv->d.cdr = Ipurcopy(lv);
break;
}
}
return(retv);
case SDOT:
retv = curv = pnewsdot();
lv = handy;
while(TRUE)
{
curv->s.I = lv->s.I;
if(lv->s.CDR == (lispval) 0) break;
lv = lv->s.CDR;
curv->s.CDR = pnewdot();
curv = curv->s.CDR;
}
curv->s.CDR = 0;
return(retv);
case INT:
if((int *)handy < beginsweep) return(handy);
retv = pnewint();
retv->i = handy->i;
return(retv);
case DOUB:
retv = pnewdb();
retv->r = handy->r;
return(retv);
case HUNK2:
i = 0;
goto hunkit;
case HUNK4:
i = 1;
goto hunkit;
case HUNK8:
i = 2;
goto hunkit;
case HUNK16:
i = 3;
goto hunkit;
case HUNK32:
i = 4;
goto hunkit;
case HUNK64:
i = 5;
goto hunkit;
case HUNK128:
i = 6;
hunkit:
retv = pnewhunk(i);
size = 2 << i ; /* number of elements to copy over */
for( i = 0; i < size ; i++)
{
retv->h.hunk[i] = Ipurcopy(handy->h.hunk[i]);
}
return(retv);
case STRNG:
#ifdef GCSTRINGS
{ extern char purepage[];
if(purepage[((int)handy)>>9]==0)
return((lispval)pinewstr((char *)handy));}
#endif
case ATOM:
case BCD:
case PORT:
return(handy); /* We don't want to purcopy these, yet
* it won't hurt if we don't mark them
* since they either aren't swept or
* will be marked in a special way
*/
case ARRAY:
error("purcopy: can't purcopy array structures",FALSE);
default:
error(" bad type to purcopy ",FALSE);
/* NOTREACHED */
}
}
/*
* Lpurep returns t if the given arg is in pure space
*/
lispval
Lpurep()
{
lispval Ipurep();
chkarg(1,"purep");
return(Ipurep(lbot->val));
}
/* vector functions */
lispval newvec(), nveci(), Inewvector();
/* vector creation and initialization functions */
lispval
Lnvec()
{
return(Inewvector(3));
}
lispval
Lnvecb()
{
return(Inewvector(0));
}
lispval
Lnvecw()
{
return(Inewvector(1));
}
lispval
Lnvecl()
{
return(Inewvector(2));
}
/*
* (new-vector 'x_size ['g_fill] ['g_prop])
* class = 0: byte \
* = 1: word > immediate
* = 2: long /
* = 3: long
*/
lispval
Inewvector(class)
{
register int i;
register lispval handy;
register lispval *handy2;
char *chandy;
short *whandy;
long *lhandy;
lispval sizearg, fillarg, proparg;
int size, vsize;
fillarg = proparg = nil;
switch(np-lbot) {
case 3: proparg = lbot[2].val;
case 2: fillarg = lbot[1].val;
case 1: sizearg = lbot[0].val;
break;
default: argerr("new-vector");
}
while((TYPE(sizearg) != INT) || sizearg->i < 0)
sizearg = errorh1(Vermisc,"new-vector: bad size for vector ",nil,
TRUE,0,sizearg);
size = sizearg->i;
switch(class)
{
case 0: vsize = size * sizeof(char);
break;
case 1: vsize = size * sizeof(short);
break;
default: vsize = size * sizeof(long);
break;
}
if(class != 3) handy = nveci(vsize);
else handy = newvec(vsize);
switch(class)
{
case 0: chandy = (char *)handy;
for(i = 0 ; i < size ; i++) *chandy++ = (char) (fillarg->i);
break;
case 1: whandy = (short *)handy;
for(i = 0 ; i < size ; i++) *whandy++ = (short) (fillarg->i);
break;
case 2: lhandy = (long *)handy;
for(i = 0 ; i < size ; i++) *lhandy++ = (fillarg->i);
break;
case 3: handy2 = (lispval *)handy;
for(i = 0 ; i < size ; i++) *handy2++ = fillarg;
break;
}
handy->v.vector[-1] = proparg;
return(handy);
}
lispval
Lvectorp()
{
chkarg(1,"vectorp");
if(TYPE(lbot->val) == VECTOR) return(tatom);
else return(nil);
}
lispval
Lpvp()
{
chkarg(1,"vectorip");
if(TYPE(lbot->val) == VECTORI) return(tatom);
else return(nil);
}
/*
* int:vref vector[i] index class
* class = 0: byte immed, 1: word immed, 2: long immed, 3: long
*
* also do C style dereferencing of pointers. This is a temporary
* hack until we decide if we can live without it:
* class = 4: char, 5: short, 6: long, 7: float, 8: double
*/
lispval
LIvref()
{
register lispval vect;
register int index;
int class;
double value;
chkarg(3,"int:vref");
vect = lbot[0].val;
index = lbot[1].val->i;
class = lbot[2].val->i;
switch(class)
{
case 0: return(inewint(vect->vb.vectorb[index]));
case 1: return(inewint(vect->vw.vectorw[index]));
case 2: return(inewint(vect->vl.vectorl[index]));
case 3: return(vect->v.vector[index]);
case 4: return(inewint(*(char *)(vect->i+index)));
case 5: return(inewint(*(short *)(vect->i+index)));
case 6: return(inewint(*(long *)(vect->i+index)));
case 7: value = *(float *) (vect->i+index);
vect = newdoub();
vect->r = value;
return(vect);
case 8: value = *(double *) (vect->i+index);
vect = newdoub();
vect->r = value;
return(vect);
}
error("int:vref: impossible class detected",FALSE);
/* NOTREACHED */
}
/*
* int:vset vector[i] index value class
* class = 0: byte immed, 1: word immed, 2: long immed, 3: long
*/
lispval
LIvset()
{
register lispval vect,value;
register int index;
int class;
chkarg(4,"int:vset");
vect = lbot[0].val;
index = lbot[1].val->i;
value = lbot[2].val;
class = lbot[3].val->i;
switch(class)
{
case 0: vect->vb.vectorb[index] = (char)value->i;
break;
case 1: vect->vw.vectorw[index] = (short)value->i;
break;
case 2: vect->vl.vectorl[index] = value->i;
break;
case 3: vect->v.vector[index] = value;
break;
case 4: *(char *) (vect->i+index) = value->i;
break;
case 5: *(short *) (vect->i+index) = value->i;
break;
case 6: *(long *) (vect->i+index) = value->i;
break;
case 7: *(float *) (vect->i+index) = value->r;
break;
case 8: *(double *) (vect->i+index) = value->r;
break;
default:
error("int:vref: impossible class detected",FALSE);
}
return(value);
}
/*
* LIvsize == (int:vsize 'vector 'x_shift)
* return the vsize field of the vector shifted right by x_shift
*/
lispval
LIvsize()
{
int typ;
chkarg(2,"int:vsize");
return(inewint((lbot[0].val->vl.vectorl[VSizeOff]) >> lbot[1].val->i));
}
lispval
Lvprop()
{
int typ;
chkarg(1,"vprop");
if(((typ = TYPE(lbot->val)) != VECTOR) && (typ != VECTORI))
errorh1(Vermisc,"vprop: non vector argument: ", nil, FALSE,0,
lbot->val);
return(lbot[0].val->v.vector[VPropOff]);
}
lispval
Lvsp()
{
int typ;
lispval vector, property;
chkarg(2,"vsetprop");
vector = lbot->val;
property = lbot[1].val;
typ = TYPE(vector);
if(typ != VECTOR && typ !=VECTORI)
errorh1(Vermisc,"vsetprop: non vector argument: ",
nil,FALSE,0,vector);
vector->v.vector[VPropOff] = property;
return(property);
}
/* vecequal
* check if the two vector arguments are 'equal'
* this is called by equal which has already checked that
* the arguments are vector
*/
vecequal(v,w)
lispval v,w;
{
int i;
lispval vv, ww, ret;
int vsize = (int) v->v.vector[VSizeOff];
int wsize = (int) w->v.vector[VSizeOff];
struct argent *oldlbot = lbot;
lispval Lequal();
if(vsize != wsize) return(FALSE);
vsize /= sizeof(int); /* determine number of entries */
for(i = 0 ; i < vsize ; i++)
{
vv = v->v.vector[i];
ww = w->v.vector[i];
/* avoid calling equal if they are eq */
if(vv != ww)
{
lbot = np;
protect(vv);
protect(ww);
ret = Lequal();
np = lbot;
lbot = oldlbot;
if(ret == nil) return(FALSE);
}
}
return(TRUE);
}
/* veciequal
* check if the two vectori arguments are 'equal'
* this is called by equal which has already checked that
* the arguments are vector
* Note: this would run faster if we did as many 'longword'
* comparisons as possible and then did byte comparisons.
* or if we used pointers instead of indexing.
*/
veciequal(v,w)
lispval v,w;
{
char vv, ww;
int i;
int vsize = (int) v->v.vector[VSizeOff];
int wsize = (int) w->v.vector[VSizeOff];
if(vsize != wsize) return(FALSE);
for(i = 0 ; i < vsize ; i++)
{
if(v->vb.vectorb[i] != w->vb.vectorb[i]) return(FALSE);
}
return(TRUE);
}