"$Header: eval2.c,v 1.8 85/03/24 11:03:02 sklower Exp $";
/* -[Sat May 7 23:38:37 1983 by jkf]-
* (c) copyright 1982, Regents of the University of California
/* Iarray - handle array call.
* args - arguments to the array call , most likely subscripts.
* evalp - flag, if TRUE then the arguments should be evaluated when they
register lispval fun
,args
;
for ( ; args
!= nil
; args
= args
->d
.cdr
) /* stack subscripts */
if(evalp
) protect(eval(args
->d
.car
));
else protect(args
->d
.car
);
register int *ip
= &thing
;
register int *lim
= ip
+ nargs();
printf("Dumpdata got %d args:\n",nargs());
while(ip
< lim
) printf("%x\n",*ip
++);
/* 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.
register struct argent
*mynp
;
int nargs
= np
- lbot
, kind
, mysize
, *ap
;
/* 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
);
kind
= (((char *)a
->bcd
.discipline
)[0]);
/* dispatch according to whether call by reference or value semantics */
case 'f': case 'i': case 's': case 'r':
arglist
= (int *) alloca((nargs
+ 1) * sizeof(int));
for(index
= 1; index
<= nargs
; index
++) {
switch(TYPE(ltemp
=mynp
->val
)) {
/* fixnums and flonums must be reboxed */
arglist
[index
] = (int) sp();
*(int *) arglist
[index
] = ltemp
->i
;
arglist
[index
] = (int) sp();
*(double *) arglist
[index
] = ltemp
->r
;
/* these cause only part of the structure to be sent */
arglist
[index
] = (int) ltemp
->ar
.data
;
arglist
[index
] = (int) ltemp
->bcd
.start
;
/* anything else should be sent directly */
arglist
[index
] = (int) ltemp
;
while(TYPE(mynp
->val
)!=VECTORI
)
"First arg to c-function-returning-vector must be of type vector-immediate",
/* make one pass over args
calculating size of arglist */
while(mynp
< np
) switch(TYPE(ltemp
=mynp
++->val
)) {
nargs
+= ((sizeof(double)/sizeof(int))-1);
if(ltemp
->v
.vector
[-1]==Vpbv
) {
nargs
+= -1+VecTotSize(ltemp
->vl
.vectorl
[-2]);
arglist
= (int *) alloca((nargs
+1)*sizeof(int));
/* make another pass over the args
actually copying the arguments */
for(mynp
= lbot
; mynp
< np
; mynp
++)
switch(TYPE(ltemp
=mynp
->val
)) {
*(double *)ap
= ltemp
->r
;
ap
+= (sizeof (double)) / (sizeof (long));
if(ltemp
->v
.vector
[-1]==Vpbv
) {
mysize
= ltemp
->vl
.vectorl
[-2];
mysize
= sizeof(long) * VecTotSize(mysize
);
ap
= (long *) (mysize
+ (int) ap
);
case 'i': /* integer-function */
case 'c': /* C-function */
ltemp
= inewint(callg_(a
->bcd
.start
,arglist
));
case 'r': /* real-function*/
case 'd': /* C function declared returning double */
(* ((double (*)()) callg_
))(a
->bcd
.start
,arglist
);
ltemp
= (lispval
) callg_(a
->bcd
.start
,arglist
);
case 'v': /* C function returning a structure */
ap
= (long *) callg_(a
->bcd
.start
,arglist
);
mysize
= ltemp
->vl
.vectorl
[-2];
mysize
= sizeof(long) * VecTotSize(mysize
);
case 's': /* subroutine */
callg_(a
->bcd
.start
,arglist
);
register char *to
, *from
;
while(--size
>= 0) *to
++ = *from
++;
register lispval
*ap
= &arg1
;
if((count
= nargs())==0) return;;
if(errp
->class==F_TO_FORT
)
errp
= Pushframe(F_TO_LISP
,nil
,nil
);
for(; count
> 0; count
--)
if(errp
->class==F_TO_FORT
)
errp
= Pushframe(F_TO_LISP
,nil
,nil
);
for(; count
> 0; count
--)
np
++->val
= (lispval
) (*arglist
++);
/* Ifclosure :: evaluate a fclosure (new version)
* the argument clos is a vector whose property is the atom fclosure
* the form of the vector is
* then for each symbol there is on vector entry containing a
* pointer to a sequence of two list cells of this form:
* 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
* 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
* (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
* 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
* 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
struct nament
*oldbnp
= bnp
, *lbnp
, *locatevar();
int numvars
, vlength
, tcase
, foundc
;
lispval handy
, atm_dtpr
, value_dtpr
, Ifuncal(), Lapply();
/* 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) */
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 */
lbnp
= locatevar(atm_dtpr
,&foundc
,bnp
-1);
/* didn't find the expected closure, count must be
wrong, correct it and assume 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 */
case Case_A
: PUSHDOWN(atm_dtpr
->d
.car
,value_dtpr
->d
.car
);
PUSHVAL(clos_marker
,atm_dtpr
);
value_dtpr
->d
.cdr
->i
+= 1;
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;
handy
= Ifuncal(clos
->v
.vector
[0]);
handy
= lbot
[-2].val
; /* get args to apply. This is hacky and may
fail if apply is changed */
protect(clos
->v
.vector
[0]);
xpopnames(oldbnp
); /* pop names with consideration for closure markers */
if(!funcallp
) Restorestack();
/* 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)
register struct nament
*llimit
;
register struct nament
*rnp
, *lbnp
;
lispval atm_dtpr
, value_dtpr
;
for(rnp
= bnp
; --rnp
>= llimit
;)
if(rnp
->atm
== clos_marker
)
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
;
/* locate the last lambda before the next occurance of
* this closure and store the current symbol's value
lbnp
= locatevar(atm_dtpr
,&foundc
,rnp
-2);
/* strange, there wasn't a closure to be found.
* well, we will fix things up so the count is
value_dtpr
->d
.car
= atm_dtpr
->d
.car
->a
.clb
;
value_dtpr
->d
.cdr
->i
= 1;
/* note how the closures value isn't necessarily
* stored in the closure, it may be stored on
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 */
locatevar(clos
,foundc
,rnp
)
register struct nament
*retbnp
;
retbnp
= (struct nament
*) 0;
for( ; rnp
>= orgbnp
; rnp
--)
if((rnp
->atm
== clos_marker
) && (rnp
->val
== clos
))
*foundc
= 1; /* found the closure */
if(rnp
->atm
== symb
) retbnp
= rnp
;
register lispval atm_dtpr
, value_dtpr
;
struct nament
*oldbnp
= bnp
, *lbnp
;
value_dtpr
= atm_dtpr
->d
.cdr
;
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 */
lbnp
= locatevar(atm_dtpr
,&foundc
,bnp
-1);
/* didn't find closure, count must be wrong,
correct it and assume case (a).*/
value_dtpr
->d
.cdr
->i
= 0;
else if(lbnp
) tcase
= Case_C
; /* found intermediate lambda*/
if(argc
==2) return(atm_dtpr
->d
.car
->a
.clb
= newval
);
return(atm_dtpr
->d
.car
->a
.clb
);
if(argc
==2) return(value_dtpr
->d
.car
= newval
);
return(value_dtpr
->d
.car
);
if(argc
==2) return(lbnp
->val
= newval
);