![[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] / 42BSD / ucb / lisp / franz|
Return to frame.c CVS log | Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / franz |
1.1 root 1: #ifndef lint
2: static char *rcsid =
3: "$Header: frame.c,v 1.2 83/05/07 23:46:38 jkf Exp $";
4: #endif
5:
6: /* -[Sat May 7 22:27:57 1983 by jkf]-
7: * frame.c $Locker: sklower $
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: Iretfromfr(fram)
185: register struct frame *fram;
186: {
187: xpopnames(fram->svbnp);
188: qretfromfr(); /* modified in sed script to point to real function */
189: /* NOT REACHED */
190: }
191:
192: /* matchtags :: return TRUE if there is any atom in common between the
193: * two tags. Either tag may be an atom or an list of atoms.
194: */
195: matchtags(tag1,tag2)
196: lispval tag1, tag2;
197: {
198: int repeat1 = FALSE;
199: int repeat2 = FALSE;
200: lispval temp1 = tag1;
201: lispval temp2 = tag2;
202: lispval t1,t2;
203:
204: if(TYPE(tag1) == ATOM)
205: {
206: t1 = tag1;
207: }
208: else {
209: t1 = tag1->d.car;
210: repeat1 = TRUE;
211: }
212:
213: if(TYPE(tag2) == ATOM)
214: {
215: t2 = tag2;
216: }
217: else {
218: t2 = tag2->d.car;
219: repeat2 = TRUE;
220: }
221:
222: loop:
223: if(t1 == t2) return(TRUE);
224: if(repeat2)
225: {
226: if((temp2 = temp2->d.cdr) != nil)
227: {
228: t2 = temp2->d.car;
229: goto loop;
230: }
231: }
232:
233: if(repeat1)
234: {
235: if((temp1 = temp1->d.cdr) != nil)
236: {
237: t1 = temp1->d.car;
238: if(repeat2)
239: {
240: temp2 = tag2;
241: t2 = temp2->d.car;
242: goto loop;
243: }
244: else t2 = tag2;
245: goto loop;
246: }
247: }
248: return(FALSE);
249: }
250:
251: /*
252: * framedump :: debugging routine to print the contents of the error
253: * frame
254: *
255: */
256: lispval
257: Lframedump()
258: {
259: struct frame *curp;
260:
261: printf("Frame dump\n");
262: for(curp = errp ; curp != (struct frame *)0 ; curp=curp->olderrp)
263: {
264: printf("at %x is ",curp);
265:
266: switch(curp->class) {
267: case F_PROG: printf(" prog\n");
268: break;
269:
270: case F_CATCH:printf(" catching ");
271: printr(curp->larg1,stdout);
272: putchar('\n');
273: break;
274:
275: case F_RESET:printf(" reset \n");
276: break;
277:
278: case F_EVAL: printf(" eval: ");
279: printr(curp->larg1,stdout);
280: putchar('\n');
281: break;
282:
283: case F_FUNCALL: printf(" funcall: ");
284: printr(curp->larg1,stdout);
285: putchar('\n');
286: break;
287:
288: case F_TO_FORT: printf(" calling fortran:\n");
289: break;
290:
291: case F_TO_LISP: printf(" fortran calling lisp:\n");
292: break;
293:
294:
295: default:
296: printf(" unknown: %d \n",curp->class);
297: }
298: fflush(stdout);
299: }
300: printf("End of stack\n");
301: return(nil);
302: }
303:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.