1 /* xljump - execution context routines */
2 /* Copyright (c) 1985, by David Michael Betz
3 All Rights Reserved
4 Permission is granted for unrestricted non-commercial use */
5
6 #include "xlisp.h"
7
8 /* external variables */
9 extern XLCONTEXT *xlcontext,*xltarget;
10 extern LVAL xlvalue,xlenv,xlfenv,xldenv;
11 extern int xlmask;
12
13 LOCAL void findandjump(int mask, const char *error);
14
15
16 /* xlbegin - beginning of an execution context */
xlbegin(XLCONTEXT * cptr,int flags,LVAL expr)17 void xlbegin(XLCONTEXT *cptr, int flags, LVAL expr)
18 {
19 cptr->c_flags = flags;
20 cptr->c_expr = expr;
21 cptr->c_xlstack = xlstack;
22 cptr->c_xlenv = xlenv;
23 cptr->c_xlfenv = xlfenv;
24 cptr->c_xldenv = xldenv;
25 cptr->c_xlcontext = xlcontext;
26 cptr->c_xlargv = xlargv;
27 cptr->c_xlargc = xlargc;
28 cptr->c_xlfp = xlfp;
29 cptr->c_xlsp = xlsp;
30 xlcontext = cptr;
31 }
32
33 /* xlend - end of an execution context */
xlend(XLCONTEXT * cptr)34 void xlend(XLCONTEXT *cptr)
35 {
36 xlcontext = cptr->c_xlcontext;
37 }
38
39 /* xlgo - go to a label */
xlgo(LVAL label)40 void xlgo(LVAL label)
41 {
42 XLCONTEXT *cptr;
43 LVAL *argv;
44 int argc;
45
46 /* find a tagbody context */
47 for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
48 if (cptr->c_flags & CF_GO) {
49 argc = cptr->c_xlargc;
50 argv = cptr->c_xlargv;
51 while (--argc >= 0)
52 if (*argv++ == label) {
53 cptr->c_xlargc = argc;
54 cptr->c_xlargv = argv;
55 xljump(cptr,CF_GO,NIL);
56 }
57 }
58 xlfail("no target for GO");
59 }
60
61 /* xlreturn - return from a block */
xlreturn(LVAL name,LVAL val)62 void xlreturn(LVAL name, LVAL val)
63 {
64 XLCONTEXT *cptr;
65
66 /* find a block context */
67 for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
68 if (cptr->c_flags & CF_RETURN && cptr->c_expr == name)
69 xljump(cptr,CF_RETURN,val);
70 xlfail("no target for RETURN");
71 }
72
73 /* xlthrow - throw to a catch */
xlthrow(LVAL tag,LVAL val)74 void xlthrow(LVAL tag, LVAL val)
75 {
76 XLCONTEXT *cptr;
77
78 /* find a catch context */
79 for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
80 if ((cptr->c_flags & CF_THROW) && cptr->c_expr == tag)
81 xljump(cptr,CF_THROW,val);
82 xlfail("no target for THROW");
83 }
84
85 /* xlsignal - signal an error */
xlsignal(const char * emsg,LVAL arg)86 void xlsignal(const char *emsg, LVAL arg)
87 {
88 XLCONTEXT *cptr;
89
90 /* find an error catcher */
91 for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
92 if (cptr->c_flags & CF_ERROR) {
93 if (cptr->c_expr && emsg)
94 xlerrprint("error",NULL,emsg,arg);
95 xljump(cptr,CF_ERROR,NIL);
96 }
97 }
98
99 /* xltoplevel - go back to the top level */
xltoplevel(void)100 void xltoplevel(void)
101 {
102 close_loadingfiles();
103 local_toplevel();
104 stdputstr("[ back to top level ]\n");
105 findandjump(CF_TOPLEVEL,"no top level");
106 }
107
108 /* xlbrklevel - go back to the previous break level */
xlbrklevel(void)109 void xlbrklevel(void)
110 {
111 findandjump(CF_BRKLEVEL,"no previous break level");
112 }
113
114 /* xlcleanup - clean-up after an error */
xlcleanup(void)115 void xlcleanup(void)
116 {
117 stdputstr("[ back to previous break level ]\n");
118 findandjump(CF_CLEANUP,"not in a break loop");
119 }
120
121 /* xlcontinue - continue from an error */
xlcontinue(void)122 void xlcontinue(void)
123 {
124 findandjump(CF_CONTINUE,"not in a break loop");
125 }
126
127 /* xljump - jump to a saved execution context */
xljump(XLCONTEXT * target,int mask,LVAL val)128 void xljump(XLCONTEXT *target, int mask, LVAL val)
129 {
130 /* unwind the execution stack */
131 for (; xlcontext != target; xlcontext = xlcontext->c_xlcontext)
132
133 /* check for an UNWIND-PROTECT */
134 if ((xlcontext->c_flags & CF_UNWIND)) {
135 xltarget = target;
136 xlmask = mask;
137 break;
138 }
139
140 /* restore the state */
141 xlstack = xlcontext->c_xlstack;
142 xlenv = xlcontext->c_xlenv;
143 xlfenv = xlcontext->c_xlfenv;
144 xlunbind(xlcontext->c_xldenv);
145 xlargv = xlcontext->c_xlargv;
146 xlargc = xlcontext->c_xlargc;
147 xlfp = xlcontext->c_xlfp;
148 xlsp = xlcontext->c_xlsp;
149 xlvalue = val;
150
151 /* call the handler */
152 _longjmp(xlcontext->c_jmpbuf,mask);
153 }
154
155 /* findandjump - find a target context frame and jump to it */
findandjump(int mask,const char * error)156 LOCAL void findandjump(int mask, const char *error)
157 {
158 XLCONTEXT *cptr;
159
160 /* find a block context */
161 for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
162 if (cptr->c_flags & mask)
163 xljump(cptr,mask,NIL);
164 xlabort(error);
165 }
166
167