![[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] / 40BSD / cmd / lisp|
Return to evalf.c CVS log | Up to [CSRG BSD Unix] / 40BSD / cmd / lisp |
1.1 root 1: static char *sccsid = "@(#)evalf.c 34.1 10/3/80";
2:
3: #include "global.h"
4: #include "frame.h"
5: /* evalframe off of the c stack.
6: We will set fp to point where the register fp points.
7: Then fp+2 = saved ap
8: fp+4 = saved pc
9: fp+3 = saved fp
10: ap+1 = first arg
11: */
12:
13: /* These will keep track of the current saved values of np and lbot
14: as we decend the evalstack. These must be read by decoding the registers saved
15: by each function call. */
16: struct argent *fakenp;
17: struct argent *fakelbot;
18:
19: lispval
20: Levalf ()
21: {
22: register struct frame *myfp;
23: struct frame *nextevf();
24: register lispval handy, result;
25: int **fp; /* this must be the first local */
26: int evaltype;
27: snpand(3);
28: if(lbot==np) {
29: protect (nil);
30: };
31: chkarg(1,"evalf");
32: fakenp = NULL;
33: fakelbot = NULL;
34: if (lbot->val == nil) { /* Arg of nil means start at the top */
35: myfp = nextevf ((struct frame *) (&fp +1), &evaltype);
36: /* myfp now points to evalframe of call to evalframe */
37: myfp = myfp->fp; /* and now to the one past evalframe */
38: } else {
39: if( TYPE(lbot->val) != INT )
40: /* Interesting artifact: A pdl pointer will be an INT, but if
41: read in, the Franz reader produces a bignum, thus giving some
42: protection from being hacked. */
43: error("ARG TO EVALFRAME MUST BE INTEGER",TRUE);
44: myfp = (struct frame *) (lbot->val->i);
45: if (myfp < (struct frame *) (&fp +1)){
46: /* if purported fp is less than current fp, a fraud
47: (since stack grows down, and current fp must be bottom) */
48: error("ARG TO EVALFRAME NOT EVALFRAME POINTER", TRUE);
49: }
50: };
51: myfp = nextevf(myfp, &evaltype); /* get pointer to frame above */
52: if(myfp > myfp->fp) return(nil); /* end of frames */
53: /* return ( <eval or apply> <fp> <exp being evaled> <bnp>) */
54: protect(result = newdot());
55: /* See maclisp manual for difference between eval frames and apply
56: frames, or else see the code below. */
57: result->d.car = matom (evaltype ? "eval" : "apply");
58: result->d.cdr = (handy = newdot());
59: handy->d.car = inewint(myfp->fp); /* The frame pointer as a lisp int */
60: handy->d.cdr = newdot();
61: handy = handy->d.cdr;
62: if (evaltype)
63: handy->d.car = myfp->ap[1]; /* eval type - simply the arg to eval */
64: else { /* apply type ; must build argument list. The form will look like
65: (<function> (<evaled arg1> <evaled arg2> ....))
66: i.e. the function name followed by a list of evaluated args */
67: lispval form, handy1, arglist;
68: struct argent *pntr;
69: /* name of function will either be arg to Lfuncal or on argstack */
70: (form = newdot())->d.car =
71: (int)myfp->ap[0] & 1? myfp->ap[1] : (fakelbot-1)->val;
72: /* Assume that Lfuncal increments lbot after getting
73: function to call. */
74: (form->d.cdr = newdot())->d.cdr = nil;
75: for (arglist = nil, pntr = fakenp;
76: pntr > fakelbot;) {
77: (handy1 = newdot())->d.cdr = arglist;
78: (arglist = handy1)->d.car = (--pntr)->val;
79: };
80: form->d.cdr->d.car = arglist;
81: handy->d.car = form;
82: };
83: handy->d.cdr = newdot();
84: handy = handy->d.cdr;
85: /* Next is index into bindstack lisp pseudo-array, for maximum
86: usefulness */
87: handy->d.car = inewint( ((struct nament *) *( ((long *)myfp->fp) -1))
88: -orgbnp); /* first part gets oldbnp, if first local */
89: handy->d.cdr = newdot();
90: handy = handy->d.cdr;
91:
92: handy->d.car = inewint(fakenp-orgnp); /* index of np in namestack*/
93: handy->d.cdr = newdot();
94: handy = handy->d.cdr;
95: handy->d.car = inewint(fakelbot-orgnp); /* index of lbot in namestack*/
96: return(result);
97: }
98:
99: #define LBOTNPMASK 03<<22 /* Octal 3 */
100: /* We assume that r6 and r7 are saved as pairs, and that no earlier
101: registers are saved. If the Franz snpand hack is changed, this may
102: have to change too. */
103: struct frame *nextevf (curfp, ftypep)
104: struct frame *curfp;
105: int *ftypep;
106: {
107: register struct frame *myfp;
108: lispval _qfuncl(),tynames(); /* locations in qfuncl */
109: lispval fchack(); /*pseudo function after Lfuncal */
110: for (myfp = curfp; myfp < myfp->fp; myfp = myfp->fp) {
111: /* Look up stack until find a frame with the right saved pc */
112: if (myfp->mask & LBOTNPMASK) {
113: fakenp = (struct argent *)(myfp->r6);
114: fakelbot = (struct argent *)(myfp->r7);
115: };
116: if (myfp->pc > eval && myfp->pc < popnames) { /* interpreted code */
117: *ftypep = TRUE;
118: break;
119: } else
120: /* if (myfp->pc > _qfuncl && myfp->pc < tynames) { /* compiled code *//*
121: *ftypep = FALSE;
122: break;
123: } else */
124: if (myfp->pc > Lfuncal && myfp->pc < fchack) { /* call to funcall */
125: *ftypep = FALSE;
126: break;
127: };
128: };
129: return(myfp);
130: }
131:
132: #include "catchfram.h"
133: lispval
134: Lfretn ()
135: {
136: int **fp; /* this must be the first local */
137: struct frame *myfp;
138: struct nament *mybnp;
139: extern long errp;
140: extern long exitlnk;
141: typedef struct catchfr *cp;
142: typedef struct savblock *savp;
143: cp curp;
144: savp cursavp;
145: chkarg(2,"freturn");
146: if( TYPE(lbot->val) != INT )
147: error("freturn: 1st arg not pdl pointer",FALSE);
148: myfp = (struct frame *) (lbot->val->i);
149: if (myfp < (struct frame *) (&fp +1)){
150: /* if purported fp is less than current fp, a fraud
151: (since stack grows down, and current fp must be bottom) */
152: error("freturn: 1st arg not current pdl pointer", FALSE);
153: };
154: /* Unwind name stack. The oldbnp will be the first local variable of
155: the function we are returning from, so it will be immediately below this
156: stack frame (i.e. it was pushed right after the call). */
157: mybnp = (struct nament *) *(((long *)myfp) - 1);
158: if (mybnp < orgbnp || mybnp > bnp)
159: error("freturn: problem with pdl pointer", FALSE);
160: popnames (mybnp);
161: /* Reset pointer to next catchframe in stack appropriately. */
162: for (curp = (cp) errp ; curp != (cp) nil ; curp = curp->link){
163: /* Debugging...
164: printf ("Considering catchframe at %d\n", curp); fflush(stdout); */
165: if ((long *) myfp < (long *) curp) {
166: /* printf ("Won\n"); fflush(stdout); */
167: break;
168: };
169: };
170: errp = (long)curp;
171: /* printf ("errp is now %d\n", errp);fflush(stdout); */
172: /* Reset saveblock for setexit/reset appropriately. */
173: for (cursavp = (savp)exitlnk; cursavp != (savp) NULL;
174: cursavp = cursavp->savlnk) {
175: /* printf("Considering saveblock at %d\n", cursavp);
176: fflush (stdout); */
177: if ((savp) myfp > cursavp &&
178: ((savp)myfp < cursavp->savlnk || cursavp->savlnk == 0)) {
179: /* printf("Won\n"); fflush(stdout); */
180: resexit(cursavp);
181: break;
182: };
183: };
184: fsmash(myfp, (np-1)->val); /* Smash the fp register..(If myfp not valid fp,
185: real trouble follows) Will really return
186: from other guy (ha ha) */
187: }
188:
189: fsmash(framep, retval)
190: struct frame *framep;
191: lispval retval;
192: {
193: asm(" movl 4(ap), fp");
194: asm(" movl 8(ap), r0");
195: asm(" ret");
196: }
197:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.