![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to eval2.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / franz|
Return to eval2.c CVS log | Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / franz |
1.1 root 1: #ifndef lint
2: static char *rcsid =
3: "$Header: eval2.c,v 1.6 83/09/12 14:18:02 sklower Exp $";
4: #endif
5:
6: /* -[Sat May 7 23:38:37 1983 by jkf]-
7: * eval2.c $Locker: $
8: * more of the evaluator
9: *
10: * (c) copyright 1982, Regents of the University of California
11: */
12:
13:
14: #include "global.h"
15: #include "frame.h"
16:
17: /* Iarray - handle array call.
18: * fun - array object
19: * args - arguments to the array call , most likely subscripts.
20: * evalp - flag, if TRUE then the arguments should be evaluated when they
21: * are stacked.
22: */
23: lispval
24: Iarray(fun,args,evalp)
25: register lispval fun,args;
26: {
27: Savestack(2);
28:
29: lbot = np;
30: protect(fun->ar.accfun);
31: for ( ; args != nil ; args = args->d.cdr) /* stack subscripts */
32: if(evalp) protect(eval(args->d.car));
33: else protect(args->d.car);
34: protect(fun);
35: vtemp = Lfuncal();
36: Restorestack();
37: return(vtemp);
38: }
39:
40:
41: dumpmydata(thing)
42: int thing;
43: {
44: register int *ip = &thing;
45: register int *lim = ip + nargs();
46:
47: printf("Dumpdata got %d args:\n",nargs());
48: while(ip < lim) printf("%x\n",*ip++);
49: return(0);
50: }
51: /* Ifcall :: call foreign function/subroutine
52: * Ifcall is handed a binary object which is the function to call.
53: * This function has already been determined to be a foreign function
54: * by noticing that its discipline field is a string.
55: * The arguments to pass have already been evaluated and stacked. We
56: * create on the stack a 'callg' type argument list to give to the
57: * function. What is passed to the foreign function depends on the
58: * type of argument. Certain args are passes directly, others must be
59: * copied since the foreign function my want to change them.
60: * When the foreign function returns, we may have to box the result,
61: * depending on the type of foreign function.
62: */
63: lispval
64: Ifcall(a)
65: lispval a;
66: {
67: char *alloca();
68: long callg_();
69: register int *arglist;
70: register int index;
71: register struct argent *mynp;
72: register lispval ltemp;
73: pbuf pb;
74: int nargs = np - lbot, kind, mysize, *ap;
75: Keepxs();
76:
77: /* put a frame on the stack which will save np and lbot in a
78: easy to find place in a standard way */
79: errp = Pushframe(F_TO_FORT,nil,nil);
80: mynp = lbot;
81: kind = (((char *)a->bcd.discipline)[0]);
82:
83: /* dispatch according to whether call by reference or value semantics */
84: switch(kind) {
85: case 'f': case 'i': case 's': case 'r':
86: arglist = (int *) alloca((nargs + 1) * sizeof(int));
87: *arglist = nargs;
88: for(index = 1; index <= nargs; index++) {
89: switch(TYPE(ltemp=mynp->val)) {
90: /* fixnums and flonums must be reboxed */
91: case INT:
92: stack(0);
93: arglist[index] = (int) sp();
94: *(int *) arglist[index] = ltemp->i;
95: break;
96: case DOUB:
97: stack(0);
98: stack(0);
99: arglist[index] = (int) sp();
100: *(double *) arglist[index] = ltemp->r;
101: break;
102:
103: /* these cause only part of the structure to be sent */
104:
105: case ARRAY:
106: arglist[index] = (int) ltemp->ar.data;
107: break;
108:
109:
110: case BCD:
111: arglist[index] = (int) ltemp->bcd.start;
112: break;
113:
114: /* anything else should be sent directly */
115:
116: default:
117: arglist[index] = (int) ltemp;
118: break;
119: }
120: mynp++;
121: }
122: break;
123: case 'v':
124: while(TYPE(mynp->val)!=VECTORI)
125: mynp->val = error(
126: "First arg to c-function-returning-vector must be of type vector-immediate",
127: TRUE);
128: nargs--;
129: mynp++;
130: lbot++;
131: case 'c': case 'd':
132: /* make one pass over args
133: calculating size of arglist */
134: while(mynp < np) switch(TYPE(ltemp=mynp++->val)) {
135: case DOUB:
136: nargs += ((sizeof(double)/sizeof(int))-1);
137: break;
138: case VECTORI:
139: if(ltemp->v.vector[-1]==Vpbv) {
140: nargs += -1+VecTotSize(ltemp->vl.vectorl[-2]);
141: }
142: }
143: arglist = (int *) alloca((nargs+1)*sizeof(int));
144: *arglist = nargs;
145: ap = arglist + 1;
146: /* make another pass over the args
147: actually copying the arguments */
148: for(mynp = lbot; mynp < np; mynp++)
149: switch(TYPE(ltemp=mynp->val)) {
150: case INT:
151: *ap++ = ltemp->i;
152: break;
153: case DOUB:
154: *(double *)ap = ltemp->r;
155: ap += (sizeof (double)) / (sizeof (long));
156: break;
157: case VECTORI:
158: if(ltemp->v.vector[-1]==Vpbv) {
159: mysize = ltemp->vl.vectorl[-2];
160: mysize = sizeof(long) * VecTotSize(mysize);
161: bcopy(ap,ltemp,mysize);
162: ap = (long *) (mysize + (int) ap);
163: break;
164: }
165: default:
166: *ap++ = (long) ltemp;
167: }
168: }
169: switch(kind) {
170: case 'i': /* integer-function */
171: case 'c': /* C-function */
172: ltemp = inewint(callg_(a->bcd.start,arglist));
173: break;
174:
175: case 'r': /* real-function*/
176: case 'd': /* C function declared returning double */
177: {
178: double result =
179: (* ((double (*)()) callg_))(a->bcd.start,arglist);
180: ltemp = newdoub();
181: ltemp->r = result;
182: }
183: break;
184:
185: case 'f': /* function */
186: ltemp = (lispval) callg_(a->bcd.start,arglist);
187: break;
188:
189: case 'v': /* C function returning a structure */
190: ap = (long *) callg_(a->bcd.start,arglist);
191: ltemp = (--lbot)->val;
192: mysize = ltemp->vl.vectorl[-2];
193: mysize = sizeof(long) * VecTotSize(mysize);
194: bcopy(ltemp,ap,mysize);
195: break;
196:
197: default:
198: case 's': /* subroutine */
199: callg_(a->bcd.start,arglist);
200: ltemp = tatom;
201: }
202: errp = Popframe();
203: Freexs();
204: return(ltemp);
205: }
206:
207: bcopy(to,from,size)
208: register char *to, *from;
209: register size;
210: {
211: while(--size >= 0) *to++ = *from++;
212: }
213:
214: lispval
215: ftolsp_(arg1)
216: lispval arg1;
217: {
218: int count;
219: register lispval *ap = &arg1;
220: lispval save;
221: pbuf pb;
222: Savestack(1);
223:
224: if((count = nargs())==0) return;;
225:
226: if(errp->class==F_TO_FORT)
227: np = errp->svnp;
228: errp = Pushframe(F_TO_LISP,nil,nil);
229: lbot = np;
230: for(; count > 0; count--)
231: np++->val = *ap++;
232: save = Lfuncal();
233: errp = Popframe();
234: Restorestack();
235: return(save);
236: }
237:
238:
239:
240: /* Ifclosure :: evaluate a fclosure (new version)
241: * the argument clos is a vector whose property is the atom fclosure
242: * the form of the vector is
243: * 0: function to run
244: * then for each symbol there is on vector entry containing a
245: * pointer to a sequence of two list cells of this form:
246: * (name value . count)
247: * name is the symbol name to close over
248: * value is the saved value of the closure
249: * (if the closure is 'active', the current value will be in the
250: * symbol itself)
251: * count is a fixnum box (which can be destructively modified safely)
252: * it is normally 0. Each time the variable is put on the stack, it is
253: * incremented. It is decremented each time the the closure is left.
254: * If the closure is invoked recusively without a rebinding of the
255: * closure variable X, then the count will not be incremented.
256: *
257: * when entering a fclosure, for each variable there are three
258: * possibities:
259: * (a) this is the first instance of this closed variable
260: * (b) this is the second or greater recursive instance of
261: * this closure variable, however it hasn't been normally lambda
262: * bound since the last closure invocation
263: * (c) like (b) but it has been lambda bound before the most recent
264: * closure.
265: *
266: * case (a) can be determined by seeing if the count is 0.
267: * if the count is >0 then we must scan from the top of the stack down
268: * until we find either the closure or a lambda binding of the variable
269: * this determines whether it is case (b) or (c).
270: *
271: * There are three actions to perform in this routine:
272: * 1. determine the closure type (a,b or c) and do any binding necessary
273: * 2. call the closure function
274: * 3. unbind any necessary closure variables.
275: *
276: * Now, the details of those actions:
277: * 1. for case (b), do nothing as we are still working with the correct
278: * value
279: * for case (a), pushdown the symbol and give it the value from
280: * the closure, inc the closure count
281: * push a closure marker on the bindstack too.
282: * for case (c), must locate the correct value to set by searching
283: * for the last lambda binding before the previous closure.
284: * pushdown the symbol and that value, inc the closure count
285: * push a closure marker on the bindstack too.
286: * a closure marker has atom == int:closure-marker and value pointing
287: * to the closure list. This will be noticed when unbinding.
288: *
289: * 3. unbinding is just like popnames except if a closure marker is
290: * seen, then this must be done:
291: * if the count is 1, just store the symbol's value in the closure
292: * and decrement the count.
293: * if the count is >1, then search up the stack for the last
294: * lambda before the next occurance of this closure variable
295: * and set its value to the current value of the closure.
296: * decrement the closure count.
297: *
298: * clos is the fclosure, funcallp is TRUE if this is called from funcall,
299: * otherwise it is called from apply
300: */
301:
302: #define Case_A 0
303: #define Case_B 1
304: #define Case_C 2
305:
306: lispval
307: Ifclosure(clos,funcallp)
308: register lispval clos;
309: {
310: struct nament *oldbnp = bnp, *lbnp, *locatevar();
311: register int i;
312: register lispval vect;
313: int numvars, vlength, tcase, foundc;
314: lispval handy, atm_dtpr, value_dtpr, Ifuncal(), Lapply();
315: Savestack(3);
316:
317: /* bind variables to their values given in the fclosure */
318: vlength = VecTotSize(clos->vl.vectorl[VSizeOff]);
319: /* vector length must be positive (it has to have a function at least) */
320: if (vlength < 1)
321: errorh1(Vermisc,"funcall: fclosure has wrong size ",nil,FALSE,0, clos);
322:
323: numvars = (vlength - 1); /* number of varibles */
324:
325: for (i = 1 ; i < vlength ; i += 1)
326: {
327: atm_dtpr = clos->v.vector[i]; /* car is symbol name */
328: value_dtpr = atm_dtpr->d.cdr; /* car: value, cdr: fixnum count */
329:
330: if(value_dtpr->d.cdr->i == 0)
331: tcase = Case_A; /* first call */
332: else {
333: lbnp = locatevar(atm_dtpr,&foundc,bnp-1);
334: if (!foundc)
335: {
336: /* didn't find the expected closure, count must be
337: wrong, correct it and assume case (a)
338: */
339: tcase = Case_A;
340: value_dtpr->d.cdr->i = 0;
341: }
342: else if(lbnp) tcase = Case_C ; /* found intermediate lambda bnd*/
343: else tcase = Case_B; /* no intermediate lambda bind */
344: }
345:
346: /* now bind the value if necessary */
347: switch(tcase) {
348: case Case_A: PUSHDOWN(atm_dtpr->d.car,value_dtpr->d.car);
349: PUSHVAL(clos_marker,atm_dtpr);
350: value_dtpr->d.cdr->i += 1;
351: break;
352:
353: case Case_B: break; /* nothing to do */
354:
355: case Case_C: /* push first bound value after last close */
356: PUSHDOWN(atm_dtpr->d.car,lbnp->val);
357: PUSHVAL(clos_marker,atm_dtpr);
358: value_dtpr->d.cdr->i += 1;
359: break;
360: }
361: }
362:
363: if(funcallp)
364: handy = Ifuncal(clos->v.vector[0]);
365: else {
366: handy = lbot[-2].val; /* get args to apply. This is hacky and may
367: fail if apply is changed */
368: lbot = np;
369: protect(clos->v.vector[0]);
370: protect(handy);
371: handy = Lapply();
372: }
373:
374: xpopnames(oldbnp); /* pop names with consideration for closure markers */
375:
376: if(!funcallp) Restorestack();
377: return(handy);
378: }
379:
380: /* xpopnames :: pop values from bindstack, but look out for
381: * closure markers. This is used (instead of the faster popnames)
382: * when we know there will be closure markers or when we can't
383: * be sure that there won't be closure markers (eg. in non-local go's)
384: */
385: xpopnames(llimit)
386: register struct nament *llimit;
387: {
388: register struct nament *rnp, *lbnp;
389: lispval atm_dtpr, value_dtpr;
390: int foundc;
391:
392: for(rnp = bnp; --rnp >= llimit;)
393: {
394: if(rnp->atm == clos_marker)
395: {
396: atm_dtpr = rnp->val;
397: value_dtpr = atm_dtpr->d.cdr;
398: if(value_dtpr->d.cdr->i <= 1)
399: {
400: /* this is the only occurance of this closure variable
401: * just restore current value to this closure.
402: */
403: value_dtpr->d.car = atm_dtpr->d.car->a.clb;
404: }
405: else {
406: /* locate the last lambda before the next occurance of
407: * this closure and store the current symbol's value
408: * there
409: */
410: lbnp = locatevar(atm_dtpr,&foundc,rnp-2);
411: if(!foundc)
412: {
413: /* strange, there wasn't a closure to be found.
414: * well, we will fix things up so the count is
415: * right.
416: */
417: value_dtpr->d.car = atm_dtpr->d.car->a.clb;
418: value_dtpr->d.cdr->i = 1;
419: }
420: else if (lbnp) {
421: /* note how the closures value isn't necessarily
422: * stored in the closure, it may be stored on
423: * the bindstack
424: */
425: lbnp->val = atm_dtpr->d.car->a.clb;
426: }
427: /* the case where lbnp is 0 should never happen, but
428: if it does, we can just do nothing safely
429: */
430: }
431: value_dtpr->d.cdr->i -= 1;
432: } else rnp->atm->a.clb = rnp->val; /* the normal case */
433: }
434: bnp = llimit;
435: }
436:
437:
438: struct nament *
439: locatevar(clos,foundc,rnp)
440: struct nament *rnp;
441: lispval clos;
442: int *foundc;
443: {
444: register struct nament *retbnp;
445: lispval symb;
446:
447: retbnp = (struct nament *) 0;
448: *foundc = 0;
449:
450: symb = clos->d.car;
451:
452: for( ; rnp >= orgbnp ; rnp--)
453: {
454: if((rnp->atm == clos_marker) && (rnp->val == clos))
455: {
456: *foundc = 1; /* found the closure */
457: return(retbnp);
458: }
459: if(rnp->atm == symb) retbnp = rnp;
460: }
461: return(retbnp);
462: }
463:
464: lispval
465: LIfss()
466: {
467: register lispval atm_dtpr, value_dtpr;
468: struct nament *oldbnp = bnp, *lbnp;
469: int tcase, foundc = 0;
470: lispval newval;
471: int argc = 1;
472: Savestack(2);
473:
474: switch(np-lbot) {
475: case 2:
476: newval = np[-1].val;
477: argc++;
478: case 1:
479: atm_dtpr = lbot->val;
480: value_dtpr = atm_dtpr->d.cdr;
481: break;
482: default:
483: argerr("int:fclosure-symbol-stuff");
484: }
485: /* this code is copied from Ifclosure */
486:
487: if(value_dtpr->d.cdr->i==0)
488: tcase = Case_A; /* closure is not active */
489: else {
490: lbnp = locatevar(atm_dtpr,&foundc,bnp-1);
491: if (!foundc)
492: {
493: /* didn't find closure, count must be wrong,
494: correct it and assume case (a).*/
495: tcase = Case_A;
496: value_dtpr->d.cdr->i = 0;
497: }
498: else if(lbnp) tcase = Case_C; /* found intermediate lambda*/
499: else tcase = Case_B;
500: }
501:
502: switch(tcase) {
503: case Case_B:
504: if(argc==2) return(atm_dtpr->d.car->a.clb = newval);
505: return(atm_dtpr->d.car->a.clb);
506:
507: case Case_A:
508: if(argc==2) return(value_dtpr->d.car = newval);
509: return(value_dtpr->d.car);
510:
511: case Case_C:
512: if(argc==2) return(lbnp->val = newval);
513: return(lbnp->val);
514: }
515: /*NOTREACHED*/
516: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.