![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to eval.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 41BSD / cmd / lisp|
Return to eval.c CVS log | Up to [CSRG BSD Unix] / 41BSD / cmd / lisp |
1.1 root 1: static char *sccsid = "@(#)eval.c 34.2 10/21/80";
2:
3: #include "global.h"
4: #include <signal.h>
5: /************************************************************************/
6: /* */
7: /* file: eval.i */
8: /* contents: evaluator and namestack maintenance routines */
9: /* */
10: /************************************************************************/
11:
12:
13: /* eval *****************************************************************/
14: /* returns the value of the pointer passed as the argument. */
15:
16:
17: lispval
18: eval(actarg)
19: lispval actarg;
20: {
21: #define argptr handy
22: register lispval a = actarg;
23: register lispval handy;
24: register struct nament *namptr;
25: register struct argent *workp;
26: register struct argent *lbot;
27: register struct argent *np;
28: /* struct argent *poplbot; Why this here? - M. Marcus */
29: struct nament *oldbnp = bnp;
30: lispval Ifcall(), Iarray();
31:
32: /*debugging
33: if (rsetsw && rsetatom->a.clb != nil) {
34: printf("Eval:");
35: printr(a,stdout);
36: printf("\nrsetsw: %d evalhsw: %d\n", rsetsw, evalhsw);
37: printf("*rset: ");
38: printr(rsetatom->a.clb,stdout);
39: printf(" evalhook: ");
40: printr(evalhatom->a.clb,stdout);
41: printf(" evalhook call flag^G: ");
42: printr(evalhcall->a.clb, stdout);
43: fflush(stdout);
44: }; */
45:
46: /* check if an interrupt is pending and handle if so */
47: if(sigintcnt > 0) sigcall(SIGINT);
48:
49: if (rsetsw && rsetatom->a.clb != nil){ /* if (*rset t) has been done */
50: if (evalhsw != nil && evalhatom->a.clb != nil)
51: /*if (sstatus evalhook t)
52: and evalhook non-nil */
53: if (evalhcall->a.clb == tatom)
54: /*if this is a call to evalhook, don't call evalhook
55: function, but clobber evalhcall atom, so recursive
56: calls to eval cause evalhook function to fire. */
57: evalhcall->a.clb = nil;
58: else {
59: /* setup equivalent of (funcall evalhook <arg to eval>) */
60: (np++)->val = a; /* push form on namestack */
61: lbot=np; /* set up args to funcall */
62: (np++)->val = evalhatom->a.clb; /* push evalhook's clb */
63: (np++)->val = a; /* eval's arg becomes
64: 2nd arg to funcall */
65: PUSHDOWN(evalhatom, nil); /* lambda-bind evalhook to nil*/
66: handy = Lfuncal(); /* now call funcall */
67: POP;
68: return(handy);
69: };
70: };
71:
72: switch (TYPE(a))
73: {
74: case ATOM:
75: if (rsetsw && rsetatom->a.clb != nil && bptr_atom->a.clb != nil) {
76:
77: struct nament *bpntr, *eval1bptr;
78: /* Both rsetsw and rsetatom for efficiency*/
79: /* bptr_atom set by second arg to eval1 */
80: eval1bptr = (struct nament *) bptr_atom->a.clb->d.cdr;
81: /* eval1bptr is bnp when eval1 was called;
82: if an atom was bound after this,
83: then its clb is valid */
84: for (bpntr = eval1bptr; bpntr < bnp; bpntr++)
85: if (bpntr->atm==a) {
86: handy = a->a.clb;
87: goto gotatom;
88: }; /* Value saved in first binding of a,
89: if any, after pointer to eval1,
90: is the valid value, else use its clb */
91: for (bpntr = (struct nament *)bptr_atom->a.clb->d.car;
92: bpntr < eval1bptr; bpntr++)
93: if (bpntr->atm==a) {
94: handy=bpntr->val;
95: goto gotatom; /* Simply no way around goto here */
96: };
97: };
98: handy = a->a.clb;
99: gotatom:
100: if(handy==CNIL) {
101: handy = errorh(Vermisc,"Unbound Variable:",nil,TRUE,0,a);
102: }
103: return(handy);
104:
105: case VALUE:
106: return(a->l);
107:
108: case DTPR:
109: (np++)->val = a; /* push form on namestack */
110: lbot = np; /* define beginning of argstack */
111: /* oldbnp = bnp; redundant - Mitch Marcus */
112: a = a->d.car; /* function name or lambda-expr */
113: for(EVER)
114: {
115: switch(TYPE(a))
116: {
117: case ATOM:
118: /* get function binding */
119: if(a->a.fnbnd==nil && a->a.clb!=nil) {
120: a=a->a.clb;
121: if(TYPE(a)==ATOM)
122: a=a->a.fnbnd;
123: } else
124: a = a->a.fnbnd;
125: break;
126: case VALUE:
127: a = a->l; /* get value */
128: break;
129: }
130:
131: vtemp = (CNIL-1); /* sentinel value for error test */
132:
133: funcal: switch (TYPE(a))
134: {
135: case BCD: /* function */
136: argptr = actarg->d.cdr;
137:
138: /* decide whether lambda, nlambda or
139: macro and push args onto argstack
140: accordingly. */
141:
142: if(a->bcd.discipline==nlambda) {
143: (np++)->val = argptr;
144: TNP;
145: } else if(a->bcd.discipline==macro) {
146: (np++)->val = actarg;
147: TNP;
148: } else for(;argptr!=nil; argptr = argptr->d.cdr) {
149: (np++)->val = eval(argptr->d.car);
150: TNP;
151: }
152: /* go for it */
153:
154: if(TYPE(a->bcd.discipline)==STRNG)
155: vtemp = Ifcall(a);
156: else
157: vtemp = (*(lispval (*)())(a->bcd.entry))();
158: break;
159:
160: case ARRAY:
161: vtemp = Iarray(a,actarg->d.cdr,TRUE);
162: break;
163:
164: case DTPR: /* push args on argstack according to
165: type */
166: argptr = a->d.car;
167: if (argptr==lambda) {
168: for(argptr = actarg->d.cdr;
169: argptr!=nil; argptr=argptr->d.cdr) {
170:
171: (np++)->val = eval(argptr->d.car);
172: TNP;
173: }
174: } else if (argptr==nlambda) {
175: (np++)->val = actarg->d.cdr;
176: TNP;
177: } else if (argptr==macro) {
178: (np++)->val = actarg;
179: TNP;
180: } else if (argptr==lexpr) {
181: for(argptr = actarg->d.cdr;
182: argptr!=nil; argptr=argptr->d.cdr) {
183:
184: (np++)->val = eval(argptr->d.car);
185: TNP;
186: }
187: handy = newdot();
188: handy->d.car = (lispval)lbot;
189: handy->d.cdr = (lispval)np;
190: PUSHDOWN(lexpr_atom,handy);
191: lbot = np;
192: (np++)->val = inewint(((lispval *)handy->d.cdr) - (lispval *)handy->d.car);
193:
194: } else break; /* something is wrong - this isn't a proper function */
195:
196: argptr = (a->d.cdr)->d.car;
197: namptr = bnp;
198: workp = lbot;
199: if(bnp + (np - lbot)> bnplim)
200: binderr();
201: for(;argptr != (lispval)nil;
202: workp++,argptr = argptr->d.cdr) /* rebind formal names (shallow) */
203: {
204: if(argptr->d.car==nil)
205: continue;
206: /*if(((namptr)->atm = argptr->d.car)==nil)
207: error("Attempt to lambda bind nil",FALSE);*/
208: namptr->atm = argptr->d.car;
209: if (workp < np) {
210: namptr->val = namptr->atm->a.clb;
211: namptr->atm->a.clb = workp->val;
212: } else
213: bnp = namptr,
214: error("Too few actual parameters",FALSE);
215: namptr++;
216: }
217: bnp = namptr;
218: if (workp < np)
219: error("Too many actual parameters",FALSE);
220:
221: /* execute body, implied prog allowed */
222:
223: for (handy = a->d.cdr->d.cdr;
224: handy != nil;
225: handy = handy->d.cdr) {
226: vtemp = eval(handy->d.car);
227: }
228: }
229: if (vtemp != (CNIL-1)) {
230: /* if we get here with a believable value, */
231: /* we must have executed a function. */
232: popnames(oldbnp);
233:
234: /* in case some clown trashed t */
235:
236: tatom->a.clb = (lispval) tatom;
237: if(a->d.car==macro)
238: return(eval(vtemp));
239: /* It is of the most wonderful
240: coincidence that the offset
241: for car is the same as for
242: discipline so we get bcd macros
243: for free here ! */
244: else return(vtemp);
245: }
246: popnames(oldbnp);
247: a = (lispval) errorh(Verundef,"eval: Undefined function ",nil,TRUE,0,actarg->d.car);
248: }
249:
250: }
251: return(a); /* other data types are considered constants */
252: }
253:
254:
255:
256:
257: /* popnames *************************************************************/
258: /* removes from the name stack all entries above the first argument. */
259: /* routine should usually be used to clean up the name stack as it */
260: /* knows about the special cases. np is returned pointing to the */
261: /* same place as the argument passed. */
262: lispval
263: popnames(llimit)
264: register struct nament *llimit;
265: {
266: register struct nament *rnp;
267:
268: for(rnp = bnp; --rnp >= llimit;)
269: rnp->atm->a.clb = rnp->val;
270: bnp = llimit;
271: }
272:
273:
274: /************************************************************************/
275: /* */
276: /* file: apply.c */
277: /* Caveat -- Work in Progress -- not guaranteed! not tested! */
278: /* */
279: /* apply ***************************************************************/
280: lispval
281: Lapply()
282: {
283: register lispval a;
284: register lispval handy;
285: register struct argent *workp;
286: register struct nament *namptr;
287: register struct argent *lbot;
288: register struct argent *np;
289: lispval vtemp;
290: struct nament *oldbnp = bnp;
291: struct argent *oldlbot = lbot; /* Bottom of my frame! */
292:
293: a = lbot->val;
294: argptr = lbot[1].val;
295: if(np-lbot!=2)
296: errorh(Vermisc,"Apply: Wrong number of args.",nil,FALSE,
297: 999,a,argptr);
298: if(TYPE(argptr)!=DTPR && argptr!=nil)
299: argptr = errorh(Vermisc,"Apply: non-list of args",nil,TRUE,
300: 998,argptr);
301: (np++)->val = a; /* push form on namestack */
302: TNP;
303: lbot = np; /* bottom of current frame */
304: for(EVER)
305: {
306: if (TYPE(a) == ATOM) a = a->a.fnbnd;
307: /* get function definition (unless
308: calling form is itself a lambda-
309: expression) */
310: vtemp = CNIL; /* sentinel value for error test */
311: switch (TYPE(a)) {
312:
313: case BCD:
314: /* push arguments - value of a */
315: if(a->bcd.discipline==nlambda || a->bcd.discipline==macro) {
316: (np++)->val=argptr;
317: TNP;
318: } else for (; argptr!=nil; argptr = argptr->d.cdr) {
319: (np++)->val=argptr->d.car;
320: TNP;
321: }
322:
323: if(TYPE(a->bcd.discipline) == STRNG)
324: vtemp = Ifcall(a); /* foreign function */
325: else
326: vtemp = (*(lispval (*)())(a->bcd.entry))(); /* go for it */
327: break;
328:
329: case ARRAY:
330: vtemp = Iarray(a,argptr,FALSE);
331: break;
332:
333:
334: case DTPR:
335: if (a->d.car==nlambda || a->d.car==macro) {
336: (np++)->val = argptr;
337: TNP;
338: } else if (a->d.car==lambda)
339: for (; argptr!=nil; argptr = argptr->d.cdr) {
340: (np++)->val = argptr->d.car;
341: TNP;
342: }
343: else if(a->d.car==lexpr) {
344: for (; argptr!=nil; argptr = argptr->d.cdr) {
345:
346: (np++)->val = argptr->d.car;
347: TNP;
348: }
349: handy = newdot();
350: handy->d.car = (lispval)lbot;
351: handy->d.cdr = (lispval)np;
352: PUSHDOWN(lexpr_atom,handy);
353: lbot = np;
354: (np++)->val = inewint(((lispval *)handy->d.cdr) - (lispval *)handy->d.car);
355:
356: } else break; /* something is wrong - this isn't a proper function */
357: rebind(a->d.cdr->d.car,lbot);
358: np = lbot;
359: for (handy = a->d.cdr->d.cdr;
360: handy != nil;
361: handy = handy->d.cdr) {
362: vtemp = eval(handy->d.car); /* go for it */
363: }
364: }
365: if (vtemp != CNIL)
366: /* if we get here with a believable value, */
367: /* we must have executed a function. */
368: {
369: popnames(oldbnp);
370:
371: /* in case some clown trashed t */
372:
373: tatom->a.clb = (lispval) tatom;
374: return(vtemp);
375: }
376: popnames(oldbnp);
377: a = (lispval) errorh(Verundef,"apply: Undefined Function ",
378: nil,TRUE,0,oldlbot->val);
379: }
380: /*NOT REACHED*/
381: }
382:
383:
384: /*
385: * Rebind -- rebind formal names
386: */
387: rebind(argptr,workp)
388: register lispval argptr; /* argptr points to list of atoms */
389: register struct argent * workp; /* workp points to position on stack
390: where evaluated args begin */
391: {
392: register lispval vtemp;
393: register struct nament *namptr = bnp;
394: register struct argent *lbot;
395: register struct argent *np;
396:
397: for(;argptr != (lispval)nil;
398: workp++,argptr = argptr->d.cdr) /* rebind formal names (shallow) */
399: {
400: if(argptr->d.car==nil)
401: continue;
402: namptr->atm = argptr->d.car;
403: if (workp < np) {
404: namptr->val = namptr->atm->a.clb;
405: namptr->atm->a.clb = workp->val;
406: } else
407: bnp = namptr,
408: error("Too few actual parameters",FALSE);
409: namptr++;
410: if(namptr > bnplim)
411: binderr();
412: }
413: bnp = namptr;
414: if (workp < np)
415: error("Too many actual parameters",FALSE);
416: }
417:
418: /* the argument to Lfuncal is optional, if it is given then it is
419: * the name of the function to call and lbot points to the first arg.
420: * if it is not given, then lbot points to the function to call
421: */
422: lispval
423: Lfuncal(fcn)
424: lispval fcn;
425: {
426: register lispval a;
427: register lispval handy;
428: register struct argent *oldlbot;
429: register struct nament **namptr;
430: register struct argent *lbot;
431: register struct argent *np;
432: struct nament *oldbnp = bnp; /* MUST be first local for evalframe */
433: lispval fcncalled;
434: lispval Ifcall(),Llist(),Iarray();
435: lispval vtemp;
436: int typ;
437: extern lispval end[];
438:
439: /*debugging stufff
440: printf("In funcal: ");
441: printr(lbot->val,stdout);
442: fflush(stdout);
443: printf("\n"); */
444:
445: /* atrocity to avoid call to nargs() */
446: /*define nargs() (* (char *) (&fcn -1))*/
447:
448: oldlbot = lbot; /* bottom of my namestack frame */
449: if((&fcn)[-1]==(lispval)1) /* function I am evaling. */
450: a = fcncalled = fcn;
451: else {
452: a = fcncalled = lbot->val;
453: lbot++;
454: }
455:
456: /* check if exception pending */
457: if(sigintcnt > 0 ) sigcall(SIGINT);
458:
459: for(EVER)
460: {
461: top:
462: typ = TYPE(a);
463: if (typ == ATOM) a = a->a.fnbnd, typ = TYPE(a);
464:
465: /* get function defn (unless calling form */
466: /* is itself a lambda-expr) */
467: vtemp = CNIL-1; /* sentinel value for error test */
468: switch (typ) {
469: case ARRAY:
470: protect(a); /* stack array descriptor on top */
471: a = a->ar.accfun; /* now funcall access function */
472: goto top;
473: case BCD:
474: if(a->bcd.discipline==nlambda)
475: { if(np==lbot) protect(nil); /* default is nil */
476: while(np-lbot!=1 || (lbot->val != nil &&
477: TYPE(lbot->val)!=DTPR)) {
478:
479: lbot->val = errorh(Vermisc,"Bad funcall arg(s) to fexpr.",
480: nil,TRUE,0,lbot->val);
481:
482: np = lbot+1;
483: }
484: }
485: /* go for it */
486:
487: if(TYPE(a->bcd.discipline)==STRNG)
488: vtemp = Ifcall(a);
489: else
490: vtemp = (*(lispval (*)())(a->bcd.entry))();
491: if(a->bcd.discipline==macro)
492: vtemp = eval(vtemp);
493: break;
494:
495:
496: case DTPR:
497: if (a->d.car == lambda) {
498: ;/* VOID */
499: } else if (a->d.car == nlambda || a->d.car==macro) {
500: if( np==lbot ) protect(nil); /* default */
501: while(np-lbot!=1 || (lbot->val != nil &&
502: TYPE(lbot->val)!=DTPR)) {
503: lbot->val = error("Bad funcall arg(s) to fexpr.",TRUE);
504: np = lbot+1;
505: }
506: } else if (a->d.car == lexpr) {
507: handy = newdot();
508: handy->d.car = (lispval) lbot;
509: handy->d.cdr = (lispval) np;
510: PUSHDOWN(lexpr_atom,handy);
511: lbot = np;
512: (np++)->val = inewint(((lispval *)handy->d.cdr) - (lispval *)handy->d.car);
513: } else break; /* something is wrong - this isn't a proper function */
514: rebind(a->d.cdr->d.car,lbot);
515: np = lbot;
516: for (handy = a->d.cdr->d.cdr;
517: handy != nil;
518: handy = handy->d.cdr) {
519: vtemp = eval(handy->d.car); /* go for it */
520: }
521: if(a->d.car==macro)
522: vtemp = eval(vtemp);
523: }
524: if (vtemp != CNIL-1)
525: /* if we get here with a believable value, */
526: /* we must have executed a function. */
527: {
528: popnames(oldbnp);
529:
530: /* in case some clown trashed t */
531:
532: tatom->a.clb = (lispval) tatom;
533: /*debugging
534: if(a>(lispval) end){printf(" leaving:");
535: printr(a,stdout);
536: fflush(stdout);} */
537: return(vtemp);
538: }
539: popnames(oldbnp);
540: a = fcncalled = (lispval) errorh(Verundef,"funcall: Bad function",
541: nil,TRUE,0,fcncalled);
542: }
543: /*NOT REACHED*/
544: }
545:
546: /* The following must be the next "function" after Lfuncal, for the
547: sake of Levalf. */
548: fchack () {}
549:
550: #undef protect
551:
552: /* protect **************************************************************/
553: /* pushes the first argument onto namestack, thereby protecting from gc */
554: lispval
555: protect(a)
556: lispval a;
557: {
558: /* (np++)->val = a;
559: if (np >= nplim)
560: namerr();
561: */
562: asm(" movl 4(ap),(r6)+");
563: asm(" cmpl r6,_nplim");
564: asm(" jlss out1");
565: asm(" calls $0,_namerr");
566: asm("out1: ret");
567: }
568:
569:
570: /* unprot ****************************************************************/
571: /* returns the top thing on the name stack. Underflow had better not */
572: /* occur. */
573: lispval
574: unprot()
575: {
576: asm(" movl -(r6),r0");
577: }
578:
579: lispval
580: linterp()
581: {
582: error("BYTE INTERPRETER CALLED ERRONEOUSLY",FALSE);
583: }
584:
585: /* Undeff - called from qfuncl when it detects a call to a undefined
586: function from compiled code, we print out a message and
587: dont allow continuation
588: */
589: lispval
590: Undeff(atmn)
591: lispval atmn;
592: {
593: return(errorh(Verundef,"Undefined function called from compiled code ",
594: nil,TRUE,0,atmn));
595: }
596: bindfix(firstarg)
597: lispval firstarg;
598: {
599: register lispval *argp = &firstarg;
600: register struct nament *mybnp = bnp;
601: while(*argp != nil) {
602: mybnp->atm = *argp++;
603: mybnp->val = mybnp->atm->a.clb;
604: mybnp->atm->a.clb = *argp++;
605: bnp = mybnp++;
606: }
607: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.