+#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*/
+}
projects / unix-history / commitdiff