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