#ifndef lint
static char *rcsid =
   "$Header: eval2.c,v 1.8 85/03/24 11:03:02 sklower Exp $";
#endif

/*					-[Sat May  7 23:38:37 1983 by jkf]-
 * 	eval2.c				$Locker:  $
 * more of the evaluator
 *
 * (c) copyright 1982, Regents of the University of California
 */


#include "global.h"
#include "frame.h"

/* Iarray - handle array call.
 *  fun - array object
 *  args - arguments to the array call , most likely subscripts.
 *  evalp - flag, if TRUE then the arguments should be evaluated when they
 *	are stacked.
 */
lispval
Iarray(fun,args,evalp)
register lispval fun,args;
{
	Savestack(2);
	
	lbot = np;
	protect(fun->ar.accfun);
	for ( ; args != nil ; args = args->d.cdr)  /* stack subscripts */
	  if(evalp) protect(eval(args->d.car));
	  else protect(args->d.car);
	protect(fun);
	vtemp = Lfuncal();
	Restorestack();
	return(vtemp);
}

    
dumpmydata(thing)
int thing;
{
	register int *ip = &thing;
	register int *lim = ip + nargs();

	printf("Dumpdata got %d args:\n",nargs());
	while(ip < lim) printf("%x\n",*ip++);
	return(0);
}
/* Ifcall :: call foreign function/subroutine
 *   Ifcall is handed a binary object which is the function to call.
 * This function has already been determined to be a foreign function
 * by noticing that its discipline field is a string.  
 * The arguments to pass have already been evaluated and stacked.  We
 * create on the stack a 'callg' type argument list to give to the 
 * function.  What is passed to the foreign function depends on the
 * type of argument.  Certain args are passes directly, others must be
 * copied since the foreign function my want to change them.
 * When the foreign function returns, we may have to box the result,
 * depending on the type of foreign function.
 */
lispval
Ifcall(a)
lispval a;
{
	char *alloca();
	long callg_();
	register int *arglist;
	register int index;
	register struct argent *mynp;
	register lispval ltemp;
	pbuf pb;
	int nargs = np - lbot, kind, mysize, *ap;
	Keepxs();

	/* put a frame on the stack which will save np and lbot in a
	   easy to find place in a standard way */
	errp = Pushframe(F_TO_FORT,nil,nil);
	mynp = lbot;
	kind = (((char *)a->bcd.discipline)[0]);

	/* dispatch according to whether call by reference or value semantics */
	switch(kind) {
	case 'f': case 'i': case 's': case 'r':
		arglist = (int *) alloca((nargs + 1) * sizeof(int));
		*arglist = nargs;
		for(index = 1; index <=  nargs; index++) {
			switch(TYPE(ltemp=mynp->val)) {
				/* fixnums and flonums must be reboxed */
			case INT:
				stack(0);
				arglist[index] = (int) sp();
				*(int *) arglist[index] = ltemp->i;
				break;
			case DOUB:
				stack(0);
				stack(0);
				arglist[index] = (int) sp();
				*(double *) arglist[index] = ltemp->r;
				break;

				/* these cause only part of the structure to be sent */

			case ARRAY:
				arglist[index] = (int) ltemp->ar.data;
				break;


			case BCD:
				arglist[index] = (int) ltemp->bcd.start;
				break;

				/* anything else should be sent directly */

			default:
				arglist[index] = (int) ltemp;
				break;
			}
			mynp++;
		}
		break;
	case 'v':
		while(TYPE(mynp->val)!=VECTORI)
			mynp->val = error(
"First arg to c-function-returning-vector must be of type vector-immediate",
					  TRUE);
		nargs--;
		mynp++;
		lbot++;
	case 'c': case 'd':
		/* make one pass over args 
		calculating size of arglist */
		while(mynp < np) switch(TYPE(ltemp=mynp++->val)) {
		case DOUB:
			nargs += ((sizeof(double)/sizeof(int))-1);
			break;
		case VECTORI:
			if(ltemp->v.vector[-1]==Vpbv) {
			    nargs += -1+VecTotSize(ltemp->vl.vectorl[-2]);
			}
		}
		arglist = (int *) alloca((nargs+1)*sizeof(int));
		*arglist = nargs;
		ap = arglist + 1;
		/* make another pass over the args
		   actually copying the arguments */
		for(mynp = lbot; mynp < np; mynp++)
			switch(TYPE(ltemp=mynp->val)) {
		case INT:
			*ap++ = ltemp->i;
			break;
		case DOUB:
			*(double *)ap = ltemp->r;
			ap += (sizeof (double)) / (sizeof (long));
			break;
		case VECTORI:
			if(ltemp->v.vector[-1]==Vpbv) {
				mysize = ltemp->vl.vectorl[-2];
				mysize = sizeof(long) * VecTotSize(mysize);
				xbcopy(ap,ltemp,mysize);
				ap = (long *) (mysize + (int) ap);
				break;
			}
		default:
			*ap++ = (long) ltemp;
		}
	}
	switch(kind) {
		case 'i': /* integer-function */
		case 'c': /* C-function */
			ltemp = inewint(callg_(a->bcd.start,arglist));
			break;

		case 'r': /* real-function*/
		case 'd': /* C function declared returning double */
			{
			double result =
			   (* ((double (*)()) callg_))(a->bcd.start,arglist);
			ltemp = newdoub();
			ltemp->r = result; 
			}
			break;

		case 'f':  /* function */
			ltemp = (lispval) callg_(a->bcd.start,arglist);
			break;

		case 'v': /* C function returning a structure */
			ap = (long *) callg_(a->bcd.start,arglist);
			ltemp = (--lbot)->val;
			mysize = ltemp->vl.vectorl[-2];
			mysize = sizeof(long) * VecTotSize(mysize);
			xbcopy(ltemp,ap,mysize);
			break;

		default:
		case 's': /* subroutine */
			callg_(a->bcd.start,arglist);
			ltemp = tatom;
	}
	errp = Popframe();
	Freexs();
	return(ltemp);
}

xbcopy(to,from,size)
register char *to, *from;
register size;
{
	while(--size >= 0) *to++ = *from++;
}

lispval
ftolsp_(arg1)
lispval arg1;
{
	int count; 
	register lispval *ap = &arg1;
	lispval save;
	pbuf pb;
	Savestack(1);

	if((count = nargs())==0) return;;

	if(errp->class==F_TO_FORT)
		np = errp->svnp;
	errp = Pushframe(F_TO_LISP,nil,nil);
	lbot = np;
	for(; count > 0; count--)
		np++->val = *ap++;
	save = Lfuncal();
	errp = Popframe();
	Restorestack();
	return(save);
}

lispval
ftlspn_(func,arglist)
lispval func;
register long *arglist;
{
	int count; 
	lispval save;
	pbuf pb;
	Savestack(1);

	if(errp->class==F_TO_FORT)
		np = errp->svnp;
	errp = Pushframe(F_TO_LISP,nil,nil);
	lbot = np;
	np++->val = func;
	count = *arglist++;
	for(; count > 0; count--)
		np++->val = (lispval) (*arglist++);
	save = Lfuncal();
	errp = Popframe();
	Restorestack();
	return(save);
}


    
/* Ifclosure :: evaluate a fclosure  (new version)
 * the argument clos is a vector whose property is the atom fclosure
 * the form of the vector is
 *   0: function to run
 * then for each symbol there is on vector entry containing a
 * pointer to a sequence of two list cells of this form:
 *	(name value . count)
 * name is the symbol name to close over
 * value is the saved value of the closure
 *	(if the closure is 'active', the current value will be in the
 *	 symbol itself)
 * count is a fixnum box (which can be destructively modified safely)
 *  it is normally 0.  Each time the variable is put on the stack, it is
 *  incremented.  It is decremented each time the the closure is left.
 *  If the closure is invoked recusively without a rebinding of the
 *  closure variable X, then the count will not be incremented.
 *
 * when entering a fclosure, for each variable there are three
 * possibities:
 *  (a) this is the first instance of this closed variable
 *  (b) this is the second or greater recursive instance of
 *      this closure variable, however it hasn't been normally lambda
 *	bound since the last closure invocation
 *  (c) like (b) but it has been lambda bound before the most recent
 *	closure.
 *
 * case (a) can be determined by seeing if the count is 0.
 * if the count is >0 then we must scan from the top of the stack down
 * until we find either the closure or a lambda binding of the variable
 * this determines whether it is case (b) or (c).
 *
 * There are three actions to perform in this routine:
 * 1.  determine the closure type (a,b or c) and do any binding necessary
 * 2.  call the closure function
 * 3.  unbind any necessary closure variables.
 *
 * Now, the details of those actions:
 * 1. for case (b), do nothing as we are still working with the correct
 *    value
 *    for case (a), pushdown the symbol and give it the value from
 *	the closure, inc the closure count
 *      push a closure marker on the bindstack too.
 *    for case (c), must locate the correct value to set by searching
 *      for the last lambda binding before the previous closure.
 *      pushdown the symbol and that value, inc the closure count
 *      push a closure marker on the bindstack too.
 *    a closure marker has atom == int:closure-marker and value pointing
 *      to the closure list.  This will be noticed when unbinding.
 *
 *  3. unbinding is just like popnames except if a closure marker is
 *     seen, then this must be done:
 *	if the count is 1, just store the symbol's value in the closure
 *	 and decrement the count.
 *      if the count is >1, then search up the stack for the last
 *	 lambda before the next occurance of this closure variable
 *	 and set its value to the current value of the closure.
 *	 decrement the closure count.
 *
 * clos is the fclosure, funcallp is TRUE if this is called from funcall,
 * otherwise it is called from apply
 */

#define Case_A 0
#define Case_B 1
#define Case_C 2

lispval
Ifclosure(clos,funcallp)
register lispval clos;
{
    struct nament *oldbnp = bnp, *lbnp, *locatevar();
    register int i;
    register lispval vect;
    int numvars, vlength, tcase, foundc;
    lispval handy, atm_dtpr, value_dtpr, Ifuncal(), Lapply();
    Savestack(3);

    /* bind variables to their values given in the fclosure */
    vlength = VecTotSize(clos->vl.vectorl[VSizeOff]);
    /* vector length must be positive (it has to have a function at least) */
    if (vlength < 1)
	errorh1(Vermisc,"funcall: fclosure has wrong size ",nil,FALSE,0, clos);

    numvars = (vlength - 1);	/* number of varibles */
    
    for (i = 1 ; i < vlength ; i += 1)
    {
	atm_dtpr = clos->v.vector[i];	/* car is symbol name */
	value_dtpr = atm_dtpr->d.cdr;   /* car: value, cdr:  fixnum count */

	if(value_dtpr->d.cdr->i == 0)
		tcase = Case_A;		/* first call */
	else {
	    lbnp = locatevar(atm_dtpr,&foundc,bnp-1);
	    if (!foundc)
	    {
		/* didn't find the expected closure, count must be
		   wrong, correct it and assume case (a)
		 */
		tcase = Case_A;
		value_dtpr->d.cdr->i = 0;
	    }
	    else if(lbnp) tcase = Case_C ; /* found intermediate lambda bnd*/
	    else tcase = Case_B;	   /* no intermediate lambda bind */
	}

	/* now bind the value if necessary */
	switch(tcase) {
	    case Case_A: PUSHDOWN(atm_dtpr->d.car,value_dtpr->d.car);
	    		 PUSHVAL(clos_marker,atm_dtpr);
			 value_dtpr->d.cdr->i += 1;
			 break;
			 
	    case Case_B: break;		/* nothing to do */

	    case Case_C: /* push first bound value after last close */
	    	         PUSHDOWN(atm_dtpr->d.car,lbnp->val);
			 PUSHVAL(clos_marker,atm_dtpr);
			 value_dtpr->d.cdr->i += 1;
			 break;
	}
    }

    if(funcallp)
       handy = Ifuncal(clos->v.vector[0]);
    else {
       handy = lbot[-2].val;	/* get args to apply.  This is hacky and may
       				   fail if apply is changed */
       lbot = np;
       protect(clos->v.vector[0]);
       protect(handy);
       handy = Lapply();
    }

    xpopnames(oldbnp);	/* pop names with consideration for closure markers */
    
    if(!funcallp) Restorestack();
    return(handy);
}

/* xpopnames :: pop values from bindstack, but look out for
 *  closure markers.  This is  used (instead of the faster popnames)
 * when we know there will be closure markers or when we can't
 * be sure that there won't be closure markers (eg. in non-local go's)
 */
xpopnames(llimit)
register struct nament *llimit;
{
    register struct nament *rnp, *lbnp;
    lispval atm_dtpr, value_dtpr;
    int foundc;

    for(rnp = bnp; --rnp >= llimit;)
    {
        if(rnp->atm == clos_marker)
	{
	    atm_dtpr = rnp->val;
	    value_dtpr = atm_dtpr->d.cdr;
	    if(value_dtpr->d.cdr->i <= 1)
	    {
		/* this is the only occurance of this closure variable
		 * just restore current value to this closure.
		 */
		value_dtpr->d.car = atm_dtpr->d.car->a.clb;
	    }
	    else {
		/* locate the last lambda before the next occurance of
		 * this closure and store the current symbol's value
		 * there
		 */
		lbnp = locatevar(atm_dtpr,&foundc,rnp-2);
		if(!foundc)
		{
		    /* strange, there wasn't a closure to be found.
		     * well, we will fix things up so the count is
		     * right.
		     */
		    value_dtpr->d.car = atm_dtpr->d.car->a.clb;
		    value_dtpr->d.cdr->i = 1;
		}
		else if (lbnp) {
		    /* note how the closures value isn't necessarily
		     * stored in the closure, it may be stored on
		     * the bindstack
		     */
		    lbnp->val = atm_dtpr->d.car->a.clb;
		}
		/* the case where lbnp is 0 should never happen, but
		   if it does, we can just do nothing safely
		 */
	    }
	    value_dtpr->d.cdr->i -= 1;
	} else rnp->atm->a.clb = rnp->val;  /* the normal case */
    }
    bnp = llimit;
}


struct nament *
locatevar(clos,foundc,rnp)
struct nament *rnp;
lispval clos;
int *foundc;
{
    register struct nament  *retbnp;
    lispval symb;

    retbnp = (struct nament *) 0;
    *foundc = 0;
    
    symb = clos->d.car;
    
    for(  ; rnp >= orgbnp ; rnp--)
    {
	if((rnp->atm == clos_marker) && (rnp->val == clos))
	{
	    *foundc = 1;	/* found the closure */
	    return(retbnp);
	}
	if(rnp->atm == symb) retbnp = rnp;
    }
    return(retbnp);	
}

lispval
LIfss()
{
	register lispval atm_dtpr, value_dtpr;
	struct nament *oldbnp = bnp, *lbnp;
	int tcase, foundc = 0;
	lispval newval;
	int argc = 1;
	Savestack(2);

	switch(np-lbot) {
	case 2:
		newval = np[-1].val;
		argc++;
	case 1:
		atm_dtpr = lbot->val;
		value_dtpr = atm_dtpr->d.cdr;
		break;
	default:
		argerr("int:fclosure-symbol-stuff");
	}
	/* this code is copied from Ifclosure */

	if(value_dtpr->d.cdr->i==0)
		tcase = Case_A;	/* closure is not active */
	else {
		lbnp = locatevar(atm_dtpr,&foundc,bnp-1);
		if (!foundc)
		{
			/* didn't find closure, count must be wrong,
			   correct it and assume case (a).*/
			tcase = Case_A;
			value_dtpr->d.cdr->i = 0;
		}
		else if(lbnp) tcase = Case_C; /* found intermediate lambda*/
		else tcase = Case_B;
	}

	switch(tcase) {
	case Case_B:
		if(argc==2) return(atm_dtpr->d.car->a.clb = newval);
		return(atm_dtpr->d.car->a.clb);

	case Case_A:
		if(argc==2) return(value_dtpr->d.car = newval);
		return(value_dtpr->d.car);

	case Case_C:
		if(argc==2) return(lbnp->val = newval);
		return(lbnp->val);
	}
	/*NOTREACHED*/
}