static char rcsid[] = "$Header:lam8.c 12.0$";
#ifndef lint
static char *rcsid =
   "$Header:lam8.c 12.0$";
   "$ACIS:lam8.c 12.0$";
#endif

/*					-[Fri Aug 12 07:54:00 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
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);
			/* 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( (lispval) (xports + (port - _iob)));
}

/*
 *	(*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], *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);
	}

}

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 = pnewdoub();
		    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
 */
lispval
LIvref()
{
    register lispval vect;
    register int index;
    int class;
    
    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]);
    }
    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;
    }
    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);
}
