1 /* xldebug - xlisp debugging support */
2 /* Copyright (c) 1985, by David Michael Betz
3 All Rights Reserved
4 Permission is granted for unrestricted non-commercial use */
5
6 /* CHANGE LOG
7 * --------------------------------------------------------------------
8 * 28Apr03 dm eliminate some compiler warnings
9 */
10
11
12 #include "stdlib.h"
13 #include "xlisp.h"
14
15
16 /* forward declarations */
17 FORWARD LVAL stacktop(void);
18 FORWARD LOCAL void breakloop(const char *hdr, const char *cmsg,
19 const char *emsg, LVAL arg, int cflag);
20
21 /* xlabort - xlisp serious error handler */
xlabort(const char * emsg)22 void xlabort(const char *emsg)
23 {
24 xlsignal(emsg,s_unbound);
25 xlerrprint("error",(const char *) NULL,emsg,s_unbound);
26 xlbrklevel();
27 }
28
29 /* xlbreak - enter a break loop */
xlbreak(const char * emsg,LVAL arg)30 void xlbreak(const char *emsg, LVAL arg)
31 {
32 breakloop("break","return from BREAK",emsg,arg,TRUE);
33 }
34
35 /* xlfail - xlisp error handler */
xlfail(const char * emsg)36 void xlfail(const char *emsg)
37 {
38 xlerror(emsg,s_unbound);
39 }
40
41 /* close_loadingfiles - close files we were loading from */
close_loadingfiles()42 void close_loadingfiles()
43 {
44 /* close open files that are being loaded so that user can
45 overwrite bug fixes immediately. (Windows locks files
46 until they are closed.)
47 */
48 while (consp(getvalue(s_loadingfiles)) &&
49 consp(cdr(getvalue(s_loadingfiles))) &&
50 streamp(car(cdr(getvalue(s_loadingfiles)))) &&
51 getfile(car(cdr(getvalue(s_loadingfiles))))) {
52 osclose(getfile(car(cdr(getvalue(s_loadingfiles)))));
53 /* make the file NULL so GC will not close it again */
54 setfile(car(cdr(getvalue(s_loadingfiles))), NULL);
55 setvalue(s_loadingfiles, cdr(cdr(getvalue(s_loadingfiles))));
56 }
57 }
58
59 /* xlerror - handle a fatal error */
xlerror(const char * emsg,LVAL arg)60 void xlerror(const char *emsg, LVAL arg)
61 {
62 close_loadingfiles();
63 if (getvalue(s_breakenable) != NIL)
64 breakloop("error",NULL,emsg,arg,FALSE);
65 else {
66 xlsignal(emsg,arg);
67 xlerrprint("error",NULL,emsg,arg);
68 xlbrklevel();
69 }
70 }
71
72 /* xlcerror - handle a recoverable error */
xlcerror(const char * cmsg,const char * emsg,LVAL arg)73 void xlcerror(const char *cmsg, const char *emsg, LVAL arg)
74 {
75 if (getvalue(s_breakenable) != NIL)
76 breakloop("error",cmsg,emsg,arg,TRUE);
77 else {
78 xlsignal(emsg,arg);
79 xlerrprint("error",NULL,emsg,arg);
80 xlbrklevel();
81 }
82 }
83
84 /* xlerrprint - print an error message */
xlerrprint(const char * hdr,const char * cmsg,const char * emsg,LVAL arg)85 void xlerrprint(const char *hdr, const char *cmsg, const char *emsg, LVAL arg)
86 {
87 /* print the error message */
88 snprintf(buf, STRMAX, "%s: %s", hdr, emsg);
89 errputstr(buf);
90
91 /* print the argument */
92 if (arg != s_unbound) {
93 errputstr(" - ");
94 errprint(arg);
95 }
96
97 /* no argument, just end the line */
98 else
99 errputstr("\n");
100
101 /* print the continuation message */
102 if (cmsg) {
103 snprintf(buf, STRMAX, "if continued: %s\n", cmsg);
104 errputstr(buf);
105 }
106 }
107
108 /* breakloop - the debug read-eval-print loop */
breakloop(const char * hdr,const char * cmsg,const char * emsg,LVAL arg,int cflag)109 LOCAL void breakloop(const char *hdr, const char *cmsg,
110 const char *emsg, LVAL arg, int cflag)
111 {
112 LVAL expr,val;
113 XLCONTEXT cntxt;
114 int type;
115
116 /* print the error message */
117 xlerrprint(hdr,cmsg,emsg,arg);
118
119 /* flush the input buffer */
120 xlflush();
121
122 /* do the back trace */
123 if (getvalue(s_tracenable)) {
124 val = getvalue(s_tlimit);
125 xlbaktrace(fixp(val) ? (int)getfixnum(val) : -1);
126 }
127
128 /* protect some pointers */
129 xlsave1(expr);
130
131 /* increment the debug level */
132 ++xldebug;
133
134 /* debug command processing loop */
135 xlbegin(&cntxt,CF_BRKLEVEL|CF_CLEANUP|CF_CONTINUE,s_true);
136 for (type = 0; type == 0; ) {
137
138 /* setup the continue trap */
139 if ((type = _setjmp(cntxt.c_jmpbuf)))
140 switch (type) {
141 case CF_CLEANUP:
142 continue;
143 case CF_BRKLEVEL:
144 type = 0;
145 break;
146 case CF_CONTINUE:
147 if (cflag) {
148 dbgputstr("[ continue from break loop ]\n");
149 continue;
150 }
151 else xlabort("this error can't be continued");
152 }
153
154 #ifndef READ_LINE
155 /* print a prompt */
156 sprintf(buf,"%d> ",xldebug);
157 dbgputstr(buf);
158 #endif
159
160 /* read an expression and check for eof */
161 if (!xlread(getvalue(s_debugio),&expr,FALSE)) {
162 type = CF_CLEANUP;
163
164 #ifdef READ_LINE
165 dbgputstr("\n");
166 #endif
167
168 break;
169 }
170
171 /* save the input expression */
172 xlrdsave(expr);
173
174 /* evaluate the expression */
175 expr = xleval(expr);
176
177 /* save the result */
178 xlevsave(expr);
179
180 /* print it */
181 dbgprint(expr);
182 }
183 xlend(&cntxt);
184
185 /* decrement the debug level */
186 --xldebug;
187
188 /* restore the stack */
189 xlpop();
190
191 /* check for aborting to the previous level */
192 if (type == CF_CLEANUP)
193 xlbrklevel();
194 }
195
196 /* baktrace - do a back trace */
xlbaktrace(int n)197 void xlbaktrace(int n)
198 {
199 LVAL *fp,*p;
200 int argc;
201 for (fp = xlfp; (n < 0 || n--) && *fp; fp = fp - (int)getfixnum(*fp)) {
202 p = fp + 1;
203 errputstr("Function: ");
204 errprint(*p++);
205 if ((argc = (int)getfixnum(*p++)))
206 errputstr("Arguments:\n");
207 while (--argc >= 0) {
208 errputstr(" ");
209 errprint(*p++);
210 }
211 }
212 }
213
214 /* xldinit - debug initialization routine */
xldinit(void)215 void xldinit(void)
216 {
217 xlsample = 0;
218 xldebug = 0;
219 }
220
221