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