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