#ifndef lint static char *rcsid = "$Header: lam8.c,v 1.16 85/03/24 11:04:31 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 #include #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 ') * * Create a hunk of size 2 . 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 ' ') * Returns the 'th element of * */ 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 ' ' ') * Replaces the 'th element of with . * */ 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 ' ' ') * Replaces the 'th element of with . 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 ') * Returns the size of * */ 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 ' ') * This function returns the inverse of * mod 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 ' ') * This function returns mod (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" {}) * * 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], *sprintf(); /* 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); }