![[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] / 43BSD / ucb / lisp / franz|
Return to eval2.c CVS log | Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / franz |
1.1 root 1: #ifndef lint
2: static char *rcsid =
3: "$Header: eval2.c,v 1.8 85/03/24 11:03: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: xbcopy(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: xbcopy(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: xbcopy(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: lispval
239: ftlspn_(func,arglist)
240: lispval func;
241: register long *arglist;
242: {
243: int count;
244: lispval save;
245: pbuf pb;
246: Savestack(1);
247:
248: if(errp->class==F_TO_FORT)
249: np = errp->svnp;
250: errp = Pushframe(F_TO_LISP,nil,nil);
251: lbot = np;
252: np++->val = func;
253: count = *arglist++;
254: for(; count > 0; count--)
255: np++->val = (lispval) (*arglist++);
256: save = Lfuncal();
257: errp = Popframe();
258: Restorestack();
259: return(save);
260: }
261:
262:
263:
264: /* Ifclosure :: evaluate a fclosure (new version)
265: * the argument clos is a vector whose property is the atom fclosure
266: * the form of the vector is
267: * 0: function to run
268: * then for each symbol there is on vector entry containing a
269: * pointer to a sequence of two list cells of this form:
270: * (name value . count)
271: * name is the symbol name to close over
272: * value is the saved value of the closure
273: * (if the closure is 'active', the current value will be in the
274: * symbol itself)
275: * count is a fixnum box (which can be destructively modified safely)
276: * it is normally 0. Each time the variable is put on the stack, it is
277: * incremented. It is decremented each time the the closure is left.
278: * If the closure is invoked recusively without a rebinding of the
279: * closure variable X, then the count will not be incremented.
280: *
281: * when entering a fclosure, for each variable there are three
282: * possibities:
283: * (a) this is the first instance of this closed variable
284: * (b) this is the second or greater recursive instance of
285: * this closure variable, however it hasn't been normally lambda
286: * bound since the last closure invocation
287: * (c) like (b) but it has been lambda bound before the most recent
288: * closure.
289: *
290: * case (a) can be determined by seeing if the count is 0.
291: * if the count is >0 then we must scan from the top of the stack down
292: * until we find either the closure or a lambda binding of the variable
293: * this determines whether it is case (b) or (c).
294: *
295: * There are three actions to perform in this routine:
296: * 1. determine the closure type (a,b or c) and do any binding necessary
297: * 2. call the closure function
298: * 3. unbind any necessary closure variables.
299: *
300: * Now, the details of those actions:
301: * 1. for case (b), do nothing as we are still working with the correct
302: * value
303: * for case (a), pushdown the symbol and give it the value from
304: * the closure, inc the closure count
305: * push a closure marker on the bindstack too.
306: * for case (c), must locate the correct value to set by searching
307: * for the last lambda binding before the previous closure.
308: * pushdown the symbol and that value, inc the closure count
309: * push a closure marker on the bindstack too.
310: * a closure marker has atom == int:closure-marker and value pointing
311: * to the closure list. This will be noticed when unbinding.
312: *
313: * 3. unbinding is just like popnames except if a closure marker is
314: * seen, then this must be done:
315: * if the count is 1, just store the symbol's value in the closure
316: * and decrement the count.
317: * if the count is >1, then search up the stack for the last
318: * lambda before the next occurance of this closure variable
319: * and set its value to the current value of the closure.
320: * decrement the closure count.
321: *
322: * clos is the fclosure, funcallp is TRUE if this is called from funcall,
323: * otherwise it is called from apply
324: */
325:
326: #define Case_A 0
327: #define Case_B 1
328: #define Case_C 2
329:
330: lispval
331: Ifclosure(clos,funcallp)
332: register lispval clos;
333: {
334: struct nament *oldbnp = bnp, *lbnp, *locatevar();
335: register int i;
336: register lispval vect;
337: int numvars, vlength, tcase, foundc;
338: lispval handy, atm_dtpr, value_dtpr, Ifuncal(), Lapply();
339: Savestack(3);
340:
341: /* bind variables to their values given in the fclosure */
342: vlength = VecTotSize(clos->vl.vectorl[VSizeOff]);
343: /* vector length must be positive (it has to have a function at least) */
344: if (vlength < 1)
345: errorh1(Vermisc,"funcall: fclosure has wrong size ",nil,FALSE,0, clos);
346:
347: numvars = (vlength - 1); /* number of varibles */
348:
349: for (i = 1 ; i < vlength ; i += 1)
350: {
351: atm_dtpr = clos->v.vector[i]; /* car is symbol name */
352: value_dtpr = atm_dtpr->d.cdr; /* car: value, cdr: fixnum count */
353:
354: if(value_dtpr->d.cdr->i == 0)
355: tcase = Case_A; /* first call */
356: else {
357: lbnp = locatevar(atm_dtpr,&foundc,bnp-1);
358: if (!foundc)
359: {
360: /* didn't find the expected closure, count must be
361: wrong, correct it and assume case (a)
362: */
363: tcase = Case_A;
364: value_dtpr->d.cdr->i = 0;
365: }
366: else if(lbnp) tcase = Case_C ; /* found intermediate lambda bnd*/
367: else tcase = Case_B; /* no intermediate lambda bind */
368: }
369:
370: /* now bind the value if necessary */
371: switch(tcase) {
372: case Case_A: PUSHDOWN(atm_dtpr->d.car,value_dtpr->d.car);
373: PUSHVAL(clos_marker,atm_dtpr);
374: value_dtpr->d.cdr->i += 1;
375: break;
376:
377: case Case_B: break; /* nothing to do */
378:
379: case Case_C: /* push first bound value after last close */
380: PUSHDOWN(atm_dtpr->d.car,lbnp->val);
381: PUSHVAL(clos_marker,atm_dtpr);
382: value_dtpr->d.cdr->i += 1;
383: break;
384: }
385: }
386:
387: if(funcallp)
388: handy = Ifuncal(clos->v.vector[0]);
389: else {
390: handy = lbot[-2].val; /* get args to apply. This is hacky and may
391: fail if apply is changed */
392: lbot = np;
393: protect(clos->v.vector[0]);
394: protect(handy);
395: handy = Lapply();
396: }
397:
398: xpopnames(oldbnp); /* pop names with consideration for closure markers */
399:
400: if(!funcallp) Restorestack();
401: return(handy);
402: }
403:
404: /* xpopnames :: pop values from bindstack, but look out for
405: * closure markers. This is used (instead of the faster popnames)
406: * when we know there will be closure markers or when we can't
407: * be sure that there won't be closure markers (eg. in non-local go's)
408: */
409: xpopnames(llimit)
410: register struct nament *llimit;
411: {
412: register struct nament *rnp, *lbnp;
413: lispval atm_dtpr, value_dtpr;
414: int foundc;
415:
416: for(rnp = bnp; --rnp >= llimit;)
417: {
418: if(rnp->atm == clos_marker)
419: {
420: atm_dtpr = rnp->val;
421: value_dtpr = atm_dtpr->d.cdr;
422: if(value_dtpr->d.cdr->i <= 1)
423: {
424: /* this is the only occurance of this closure variable
425: * just restore current value to this closure.
426: */
427: value_dtpr->d.car = atm_dtpr->d.car->a.clb;
428: }
429: else {
430: /* locate the last lambda before the next occurance of
431: * this closure and store the current symbol's value
432: * there
433: */
434: lbnp = locatevar(atm_dtpr,&foundc,rnp-2);
435: if(!foundc)
436: {
437: /* strange, there wasn't a closure to be found.
438: * well, we will fix things up so the count is
439: * right.
440: */
441: value_dtpr->d.car = atm_dtpr->d.car->a.clb;
442: value_dtpr->d.cdr->i = 1;
443: }
444: else if (lbnp) {
445: /* note how the closures value isn't necessarily
446: * stored in the closure, it may be stored on
447: * the bindstack
448: */
449: lbnp->val = atm_dtpr->d.car->a.clb;
450: }
451: /* the case where lbnp is 0 should never happen, but
452: if it does, we can just do nothing safely
453: */
454: }
455: value_dtpr->d.cdr->i -= 1;
456: } else rnp->atm->a.clb = rnp->val; /* the normal case */
457: }
458: bnp = llimit;
459: }
460:
461:
462: struct nament *
463: locatevar(clos,foundc,rnp)
464: struct nament *rnp;
465: lispval clos;
466: int *foundc;
467: {
468: register struct nament *retbnp;
469: lispval symb;
470:
471: retbnp = (struct nament *) 0;
472: *foundc = 0;
473:
474: symb = clos->d.car;
475:
476: for( ; rnp >= orgbnp ; rnp--)
477: {
478: if((rnp->atm == clos_marker) && (rnp->val == clos))
479: {
480: *foundc = 1; /* found the closure */
481: return(retbnp);
482: }
483: if(rnp->atm == symb) retbnp = rnp;
484: }
485: return(retbnp);
486: }
487:
488: lispval
489: LIfss()
490: {
491: register lispval atm_dtpr, value_dtpr;
492: struct nament *oldbnp = bnp, *lbnp;
493: int tcase, foundc = 0;
494: lispval newval;
495: int argc = 1;
496: Savestack(2);
497:
498: switch(np-lbot) {
499: case 2:
500: newval = np[-1].val;
501: argc++;
502: case 1:
503: atm_dtpr = lbot->val;
504: value_dtpr = atm_dtpr->d.cdr;
505: break;
506: default:
507: argerr("int:fclosure-symbol-stuff");
508: }
509: /* this code is copied from Ifclosure */
510:
511: if(value_dtpr->d.cdr->i==0)
512: tcase = Case_A; /* closure is not active */
513: else {
514: lbnp = locatevar(atm_dtpr,&foundc,bnp-1);
515: if (!foundc)
516: {
517: /* didn't find closure, count must be wrong,
518: correct it and assume case (a).*/
519: tcase = Case_A;
520: value_dtpr->d.cdr->i = 0;
521: }
522: else if(lbnp) tcase = Case_C; /* found intermediate lambda*/
523: else tcase = Case_B;
524: }
525:
526: switch(tcase) {
527: case Case_B:
528: if(argc==2) return(atm_dtpr->d.car->a.clb = newval);
529: return(atm_dtpr->d.car->a.clb);
530:
531: case Case_A:
532: if(argc==2) return(value_dtpr->d.car = newval);
533: return(value_dtpr->d.car);
534:
535: case Case_C:
536: if(argc==2) return(lbnp->val = newval);
537: return(lbnp->val);
538: }
539: /*NOTREACHED*/
540: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.