![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to evalf.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 evalf.c CVS log | Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / franz |
1.1 root 1: #ifndef lint
2: static char *sccsid = "%W% %G%";
3: #endif
4:
5: #include "global.h"
6: #include "frame.h"
7:
8: lispval
9: Levalf ()
10: {
11: register struct frame *myfp;
12: register lispval handy, result;
13: struct frame *searchforpdl();
14: int evaltype;
15: Savestack(3);
16:
17: if(lbot==np) handy = nil;
18: else if((np-lbot) == 1) handy = lbot->val;
19: else argerr("evalf");
20:
21: if (handy == nil) /* Arg of nil means start at the top */
22: {
23: myfp = searchforpdl(errp);
24: /*
25: * myfp may be nil, if *rset t wasn't done. In that case we
26: * just return nil
27: */
28: if(myfp == (struct frame *) 0) return(nil);
29: /*
30: * myfp may point to the call to evalframe, in which case we
31: * want to go to the next frame down. myfp will not point
32: * to the call to evalframe if for example the translink tables
33: * are turned on and the call came from compiled code
34: */
35: if( ((myfp->class == F_EVAL)
36: && TYPE(myfp->larg1) == DTPR
37: && myfp->larg1->d.car == Vevalframe)
38: || ((myfp->class == F_FUNCALL)
39: && (myfp->larg1 = Vevalframe)))
40:
41: myfp = searchforpdl(myfp->olderrp); /* advance to next frame */
42: }
43: else
44: {
45: if( TYPE(handy) != INT )
46: error("Arg to evalframe must be integer",TRUE);
47: /*
48: * Interesting artifact: A pdl pointer will be an INT, but if
49: * read in, the Franz reader produces a bignum, thus giving some
50: * protection from being hacked.
51: */
52:
53: myfp = (struct frame *)(handy->i);
54: verifypdlp(myfp); /* make sure we are given valid pointer */
55: myfp = searchforpdl(myfp);
56: if (myfp == (struct frame *) 0 ) return(nil); /* end of frames */
57: myfp = searchforpdl(myfp->olderrp); /* advance to next one */
58: };
59:
60:
61: if (myfp == (struct frame *) 0 ) return(nil); /* end of frames */
62:
63: if(myfp->class == F_EVAL) evaltype = TRUE; else evaltype = FALSE;
64:
65: /* return ( <eval or apply> <fp> <exp being evaled> <bnp>) */
66: protect(result = newdot());
67: /*
68: * See maclisp manual for difference between eval frames and apply
69: * frames, or else see the code below.
70: */
71: result->d.car = matom (evaltype ? "eval" : "apply");
72: result->d.cdr = (handy = newdot());
73: handy->d.car = inewint(myfp); /* The frame pointer as a lisp int */
74: handy->d.cdr = newdot();
75: handy = handy->d.cdr;
76: if (evaltype)
77: handy->d.car = myfp->larg1; /* eval type - simply the arg to eval */
78: else
79: { /*
80: * apply type ; must build argument list. The form will look like
81: *
82: * (<function> (<evaled arg1> <evaled arg2> ....))
83: * i.e. the function name followed by a list of evaluated args
84: */
85: lispval form, arglist;
86: struct argent *pntr;
87: (form = newdot())->d.car = myfp->larg1;
88: handy->d.car = form; /* link in to save from gc */
89: (form->d.cdr = newdot())->d.cdr = nil;
90: for (arglist = nil, pntr = myfp->svlbot; pntr < myfp->svnp; pntr++)
91: {
92: if(arglist == nil)
93: {
94: protect(arglist = newdot());
95: form->d.cdr->d.car = arglist; /* save from gc */
96: }
97: else arglist = (arglist->d.cdr = newdot());
98: arglist->d.car = pntr->val;
99: };
100: };
101: handy->d.cdr = newdot();
102: handy = handy->d.cdr;
103: /* Next is index into bindstack lisp pseudo-array, for maximum
104: usefulness */
105: handy->d.car = inewint( myfp->svbnp - orgbnp);
106: handy->d.cdr = newdot();
107: handy = handy->d.cdr;
108:
109: handy->d.car = inewint(myfp->svnp - orgnp); /* index of np in namestack*/
110: handy->d.cdr = newdot();
111: handy = handy->d.cdr;
112: handy->d.car = inewint(myfp->svlbot - orgnp);/* index of lbot in namestack*/
113: Restorestack();
114: return(result);
115: }
116:
117: struct frame *searchforpdl (myfp)
118: struct frame *myfp;
119: {
120: /*
121: * for safety sake, we verify that this is a real pdl pointer by
122: * tracing back all pdl pointers from the start
123: * then after we find it, we just advance to next F_EVAL or F_FUNCALL
124: */
125: verifypdlp(myfp);
126: for( ; myfp != (struct frame *)0 ; myfp= myfp->olderrp)
127: {
128: if((myfp->class == F_EVAL) || (myfp->class == F_FUNCALL))
129: return(myfp);
130: }
131: return((struct frame *)0);
132: }
133:
134: /*
135: * verifypdlp :: verify pdl pointer as existing, do not return unless
136: * it is valid
137: */
138: verifypdlp(curfp)
139: register struct frame *curfp;
140: {
141: register struct frame *myfp;
142:
143: for (myfp = errp; myfp != (struct frame *)0 ; myfp = myfp->olderrp)
144: if(myfp == curfp) return;
145: errorh1(Vermisc,"Invalid pdl pointer given: ",nil,FALSE,0,inewint(curfp));
146: }
147:
148: lispval
149: Lfretn ()
150: {
151: struct frame *myfp;
152: chkarg(2,"freturn");
153:
154: if( TYPE(lbot->val) != INT )
155: error("freturn: 1st arg not pdl pointer",FALSE);
156:
157: myfp = (struct frame *) (lbot->val->i);
158: verifypdlp(myfp); /* make sure pdlp is valid */
159:
160: retval = C_FRETURN; /* signal coming from freturn */
161: lispretval = (lbot+1)->val; /* value to return */
162: Iretfromfr(myfp);
163: /* NOT REACHED */
164: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.