![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to frame.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSDTahoe / ucb / lisp / franz|
Return to frame.c CVS log | Up to [CSRG BSD Unix] / 43BSDTahoe / ucb / lisp / franz |
1.1 root 1: #ifndef lint
2: static char *rcsid =
3: "$Header: frame.c,v 1.3 87/12/14 16:51:52 sklower Exp $";
4: #endif
5:
6: /*
7: * frame.c $Locker: $
8: * non local goto handlers
9: *
10: * (c) copyright 1982, Regents of the University of California
11: */
12:
13:
14: #include "global.h"
15: #include "frame.h"
16:
17: /*
18: * This is a collection of routines for manipulating evaluation frames.
19: * Such frames are generated to mark the state of execution at a certain
20: * spot. They are created upon entry to prog, do, catch, errset and
21: * other misc. functions (such as eval when in *rset mode).
22: *
23: * As described in h/frame.h, each frame is identified by a class, which
24: * says who created the frame. The global variable errp points to the
25: * first (newest) frame on the stack.
26: * The standard way to create a frame is to say
27: *
28: * errp = Pushframe(class,arg1,arg2); /* create and link in new
29: * frame of give class * /
30: *
31: * poping the frame must be done explicity if the routine was not exited by
32: * a non-local goto. This is done by
33: * errp = Popframe();
34: *
35: * When a frame is created, it marks the current state on the runtime stack.
36: * Execution will continues after the Pushframe call with the value of the
37: * global variable 'retval' set to 0. Some time later control may be thrown
38: * up the stack and it will seem that Pushframe returned again. This time
39: * retval will contain a non-zero value indicating what caused the non-local
40: * jump. retval will have one of the values from C_???? in h/frame.h .
41: * It will not have just of the C_???? values, it will only have a value
42: * which makes sense. For example, coming out of a Pushframe(F_CATCH,tag,nil);
43: * retval will either be 0 (initially) or C_THROW, [and in addition it will
44: * already have been determined that the tag of the catch matches the tag
45: * being thrown, [[ this does not apply to GO's and PROG tags]] ].
46: *
47: * In doing throws, goto's, returns, or errors up the stack we are always
48: * conscious of the possiblity of unwind-protect sitting between where
49: * control starts and where it wants to get. Thus it may be necessary
50: * to save the state of the non-local jump, give control to the unwind-protect
51: * and have it continue the non-local jump.
52: */
53:
54: /*
55: * Inonlocalgo(class, arg1, arg2) :: do a general non-local goto.
56: * class - one of the C_???? in h/frame.h
57: * arg1 - tag in C_THROW, C_GO; value in C_RETURN
58: * arg2 - value in C_THROW;
59: * this handles GO's, THROW's, RETURN's but not errors, which have more
60: * state to throw and a lot of different things to do if there is no one
61: * to catch the error.
62: *
63: * This routine never returns.
64: */
65:
66: Inonlocalgo(class, arg1, arg2)
67: lispval arg1,arg2;
68: {
69: struct frame *uwpframe, *Inlthrow();
70: lispval handy;
71:
72: /*
73: * scan for something to match 'class', return if nothing found, or
74: * if we must first handle an unwind protect.
75: */
76: while( uwpframe = Inlthrow(class,arg1,arg2) )
77: {
78: /* build error frame description to be use to continue this throw */
79: protect(lispretval = handy = newdot());
80: handy->d.car = Veruwpt;
81: handy = handy->d.cdr = newdot();
82: handy->d.car = inewint(class); /* remember type */
83: handy = handy->d.cdr = newdot();
84: handy->d.car = arg1;
85: handy = handy->d.cdr = newdot();
86: handy->d.car = arg2;
87: retval = C_THROW;
88: Iretfromfr(uwpframe);
89: /* NOT REACHED */
90: }
91:
92: /*
93: * nothing to go to, signal the appropriate error
94: */
95:
96: switch(class)
97: {
98: case C_GO: errorh1(Vermisc, "No prog to go to with this tag ",
99: nil,FALSE,0,arg1);
100: /* NOT REACHED */
101:
102: case C_RET: errorh(Vermisc, "No prog to return from", nil, FALSE, 0);
103: /* NOT REACHED */
104:
105: case C_THROW: errorh1(Vermisc, "No catch for this tag ", nil, FALSE , 0,
106: arg1);
107: /* NOT REACHED */
108: default: error("Internal Inonlocalgoto error" ,FALSE);
109: /* NOT REACHED */
110: }
111: }
112:
113: /*
114: * Inlthrow(class,arg1,arg2) :: look up the stack for a form to handle
115: * a value of 'class' being thrown. If found, do the throw. If an
116: * unwind-protect must be done, then return a pointer to that frame
117: * first. If there is nothing to catch this throw, we return 0.
118: */
119:
120: struct frame *
121: Inlthrow(class, arg1, arg2)
122: lispval arg1, arg2;
123: {
124: struct frame *uwpframe = (struct frame *)0;
125: struct frame *curp;
126: int pass = 1;
127:
128: restart:
129: for(curp = errp; curp != (struct frame *) 0; curp = curp->olderrp)
130: {
131: switch(curp->class)
132: {
133: case F_PROG: if(class == C_RET || class == C_GO)
134: {
135: if(pass == 2) return(uwpframe);
136: else
137: {
138: lispretval = arg1;
139: retval = class;
140: Iretfromfr(curp);
141: /* NOT REACHED */
142: }
143: }
144: break;
145:
146: case F_CATCH: if((pass == 1) && (curp->larg1 == Veruwpt))
147: {
148: uwpframe = curp;
149: pass = 2;
150: goto restart;
151: }
152: else if(class == C_THROW
153: && matchtags(arg1,curp->larg1))
154: {
155: if(pass == 2) return(uwpframe);
156: else
157: {
158: lispretval = arg2; /* value thrown */
159: retval = class;
160: Iretfromfr(curp);
161: /* NOT REACHED */
162: }
163: }
164: break;
165:
166: case F_RESET: if(class == C_RESET)
167: {
168: if(pass == 2) return(uwpframe);
169: else
170: {
171: retval = class;
172: Iretfromfr(curp);
173: /* NOT REACHED */
174: }
175: }
176: break;
177:
178: }
179: }
180: return((struct frame *)0); /* nobody wants it */
181: }
182:
183:
184: #ifndef tahoe
185: Iretfromfr(fram)
186: register struct frame *fram;
187: {
188: xpopnames(fram->svbnp);
189: qretfromfr(); /* modified in sed script to point to real function */
190: /* NOT REACHED */
191: }
192: #endif
193:
194: /* matchtags :: return TRUE if there is any atom in common between the
195: * two tags. Either tag may be an atom or an list of atoms.
196: */
197: matchtags(tag1,tag2)
198: lispval tag1, tag2;
199: {
200: int repeat1 = FALSE;
201: int repeat2 = FALSE;
202: lispval temp1 = tag1;
203: lispval temp2 = tag2;
204: lispval t1,t2;
205:
206: if(TYPE(tag1) == ATOM)
207: {
208: t1 = tag1;
209: }
210: else {
211: t1 = tag1->d.car;
212: repeat1 = TRUE;
213: }
214:
215: if(TYPE(tag2) == ATOM)
216: {
217: t2 = tag2;
218: }
219: else {
220: t2 = tag2->d.car;
221: repeat2 = TRUE;
222: }
223:
224: loop:
225: if(t1 == t2) return(TRUE);
226: if(repeat2)
227: {
228: if((temp2 = temp2->d.cdr) != nil)
229: {
230: t2 = temp2->d.car;
231: goto loop;
232: }
233: }
234:
235: if(repeat1)
236: {
237: if((temp1 = temp1->d.cdr) != nil)
238: {
239: t1 = temp1->d.car;
240: if(repeat2)
241: {
242: temp2 = tag2;
243: t2 = temp2->d.car;
244: goto loop;
245: }
246: else t2 = tag2;
247: goto loop;
248: }
249: }
250: return(FALSE);
251: }
252:
253: /*
254: * framedump :: debugging routine to print the contents of the error
255: * frame
256: *
257: */
258: lispval
259: Lframedump()
260: {
261: struct frame *curp;
262:
263: printf("Frame dump\n");
264: for(curp = errp ; curp != (struct frame *)0 ; curp=curp->olderrp)
265: {
266: printf("at %x is ",curp);
267:
268: switch(curp->class) {
269: case F_PROG: printf(" prog\n");
270: break;
271:
272: case F_CATCH:printf(" catching ");
273: printr(curp->larg1,stdout);
274: putchar('\n');
275: break;
276:
277: case F_RESET:printf(" reset \n");
278: break;
279:
280: case F_EVAL: printf(" eval: ");
281: printr(curp->larg1,stdout);
282: putchar('\n');
283: break;
284:
285: case F_FUNCALL: printf(" funcall: ");
286: printr(curp->larg1,stdout);
287: putchar('\n');
288: break;
289:
290: case F_TO_FORT: printf(" calling fortran:\n");
291: break;
292:
293: case F_TO_LISP: printf(" fortran calling lisp:\n");
294: break;
295:
296:
297: default:
298: printf(" unknown: %d \n",curp->class);
299: }
300: fflush(stdout);
301: }
302: printf("End of stack\n");
303: return(nil);
304: }
305:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.