Commit | Line | Data |
---|---|---|
f0e9217a | 1 | /* Debugging extensions for Guile |
b7f3516f | 2 | * Copyright (C) 1995, 1996, 1997 Free Software Foundation |
ee340120 MD |
3 | * |
4 | * This program is free software; you can redistribute it and/or modify | |
5 | * it under the terms of the GNU General Public License as published by | |
6 | * the Free Software Foundation; either version 2, or (at your option) | |
7 | * any later version. | |
8 | * | |
9 | * This program is distributed in the hope that it will be useful, | |
10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of | |
11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
12 | * GNU General Public License for more details. | |
13 | * | |
14 | * You should have received a copy of the GNU General Public License | |
15 | * along with this software; see the file COPYING. If not, write to | |
82892bed JB |
16 | * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, |
17 | * Boston, MA 02111-1307 USA | |
ee340120 MD |
18 | * |
19 | * As a special exception, the Free Software Foundation gives permission | |
20 | * for additional uses of the text contained in its release of GUILE. | |
21 | * | |
22 | * The exception is that, if you link the GUILE library with other files | |
23 | * to produce an executable, this does not by itself cause the | |
24 | * resulting executable to be covered by the GNU General Public License. | |
25 | * Your use of that executable is in no way restricted on account of | |
26 | * linking the GUILE library code into it. | |
27 | * | |
28 | * This exception does not however invalidate any other reasons why | |
29 | * the executable file might be covered by the GNU General Public License. | |
30 | * | |
31 | * This exception applies only to the code released by the | |
32 | * Free Software Foundation under the name GUILE. If you copy | |
33 | * code from other Free Software Foundation releases into a copy of | |
34 | * GUILE, as the General Public License permits, the exception does | |
35 | * not apply to the code that you add in this way. To avoid misleading | |
36 | * anyone as to the status of such modified files, you must delete | |
37 | * this exception notice from them. | |
38 | * | |
39 | * If you write modifications of your own for GUILE, it is your choice | |
40 | * whether to permit this exception to apply to your modifications. | |
41 | * If you do not wish that, delete this exception notice. | |
42 | * | |
43 | * The author can be reached at djurfeldt@nada.kth.se | |
82892bed | 44 | * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN */ |
f0e9217a MD |
45 | |
46 | #include <stdio.h> | |
47 | #include "_scm.h" | |
20e6290e JB |
48 | #include "eval.h" |
49 | #include "throw.h" | |
50 | #include "genio.h" | |
51 | #include "smob.h" | |
52 | #include "procprop.h" | |
53 | #include "srcprop.h" | |
54 | #include "alist.h" | |
55 | #include "continuations.h" | |
56 | #include "strports.h" | |
57 | #include "read.h" | |
58 | #include "feature.h" | |
f0e9217a | 59 | |
20e6290e | 60 | #include "debug.h" |
f0e9217a MD |
61 | \f |
62 | ||
63 | /* {Run time control of the debugging evaluator} | |
64 | */ | |
65 | ||
5e8d7fd4 | 66 | SCM_PROC (s_debug_options, "debug-options-interface", 0, 1, 0, scm_debug_options); |
1cc91f1b | 67 | |
f0e9217a | 68 | SCM |
5e8d7fd4 MD |
69 | scm_debug_options (setting) |
70 | SCM setting; | |
f0e9217a MD |
71 | { |
72 | SCM ans; | |
73 | SCM_DEFER_INTS; | |
5e8d7fd4 MD |
74 | ans = scm_options (setting, |
75 | scm_debug_opts, | |
76 | SCM_N_DEBUG_OPTIONS, | |
77 | s_debug_options); | |
f0e9217a | 78 | #ifndef SCM_RECKLESS |
5e8d7fd4 | 79 | if (!(1 <= SCM_N_FRAMES && SCM_N_FRAMES <= SCM_MAX_FRAME_SIZE)) |
f0e9217a | 80 | { |
5e8d7fd4 | 81 | scm_options (ans, scm_debug_opts, SCM_N_DEBUG_OPTIONS, s_debug_options); |
52859adf | 82 | scm_out_of_range (s_debug_options, setting); |
f0e9217a MD |
83 | } |
84 | #endif | |
5e8d7fd4 MD |
85 | SCM_RESET_DEBUG_MODE; |
86 | scm_debug_eframe_size = 2 * SCM_N_FRAMES; | |
f0e9217a MD |
87 | SCM_ALLOW_INTS |
88 | return ans; | |
89 | } | |
90 | ||
5e8d7fd4 | 91 | SCM_PROC (s_evaluator_traps, "evaluator-traps-interface", 0, 1, 0, scm_evaluator_traps); |
1cc91f1b | 92 | |
f0e9217a | 93 | SCM |
5e8d7fd4 MD |
94 | scm_evaluator_traps (setting) |
95 | SCM setting; | |
f0e9217a MD |
96 | { |
97 | SCM ans; | |
98 | SCM_DEFER_INTS; | |
5e8d7fd4 MD |
99 | ans = scm_options (setting, |
100 | scm_evaluator_trap_table, | |
101 | SCM_N_EVALUATOR_TRAPS, | |
102 | s_evaluator_traps); | |
103 | SCM_RESET_DEBUG_MODE; | |
f0e9217a MD |
104 | SCM_ALLOW_INTS |
105 | return ans; | |
106 | } | |
107 | ||
108 | SCM_PROC (s_single_step, "single-step", 2, 0, 0, scm_single_step); | |
1cc91f1b | 109 | |
f0e9217a | 110 | SCM |
bba4bfdb | 111 | scm_single_step (cont, val) |
1cc91f1b JB |
112 | SCM cont; |
113 | SCM val; | |
f0e9217a MD |
114 | { |
115 | SCM_DEFER_INTS; | |
5e8d7fd4 MD |
116 | SCM_ENTER_FRAME_P = SCM_EXIT_FRAME_P = 1; |
117 | SCM_RESET_DEBUG_MODE; | |
f0e9217a | 118 | SCM_ALLOW_INTS; |
2c4bd736 | 119 | scm_call_continuation (cont, val); |
f0e9217a MD |
120 | return SCM_BOOL_F; /* never returns */ |
121 | } | |
122 | ||
123 | \f | |
124 | static SCM scm_i_source, scm_i_more; | |
125 | static SCM scm_i_proc, scm_i_args, scm_i_eval_args; | |
126 | static SCM scm_i_procname; | |
127 | ||
128 | /* {Memoized Source} | |
129 | */ | |
130 | ||
131 | long scm_tc16_memoized; | |
132 | ||
1cc91f1b JB |
133 | |
134 | static int prinmemoized SCM_P ((SCM obj, SCM port, scm_print_state *pstate)); | |
135 | ||
f0e9217a | 136 | static int |
9882ea19 | 137 | prinmemoized (obj, port, pstate) |
f0e9217a MD |
138 | SCM obj; |
139 | SCM port; | |
9882ea19 | 140 | scm_print_state *pstate; |
f0e9217a | 141 | { |
9882ea19 | 142 | int writingp = SCM_WRITINGP (pstate); |
b7f3516f | 143 | scm_puts ("#<memoized ", port); |
9882ea19 MD |
144 | SCM_SET_WRITINGP (pstate, 1); |
145 | scm_iprin1 (scm_unmemoize (obj), port, pstate); | |
146 | SCM_SET_WRITINGP (pstate, writingp); | |
b7f3516f | 147 | scm_putc ('>', port); |
f0e9217a MD |
148 | return 1; |
149 | } | |
150 | ||
151 | static scm_smobfuns memoizedsmob = | |
152 | {scm_markcdr, scm_free0, prinmemoized, 0}; | |
153 | ||
154 | SCM_PROC (s_memoized_p, "memoized?", 1, 0, 0, scm_memoized_p); | |
1cc91f1b | 155 | |
f0e9217a MD |
156 | SCM |
157 | scm_memoized_p (obj) | |
158 | SCM obj; | |
f0e9217a MD |
159 | { |
160 | return SCM_NIMP (obj) && SCM_MEMOIZEDP (obj) ? SCM_BOOL_T : SCM_BOOL_F; | |
161 | } | |
162 | ||
f0e9217a | 163 | SCM |
bba4bfdb | 164 | scm_make_memoized (exp, env) |
1cc91f1b JB |
165 | SCM exp; |
166 | SCM env; | |
f0e9217a | 167 | { |
6c179711 | 168 | /* *fixme* Check that env is a valid environment. */ |
f0e9217a MD |
169 | register SCM z, ans; |
170 | SCM_DEFER_INTS; | |
171 | SCM_NEWCELL (z); | |
a6c64c3c MD |
172 | SCM_SETCAR (z, exp); |
173 | SCM_SETCDR (z, env); | |
f0e9217a | 174 | SCM_NEWCELL (ans); |
a6c64c3c MD |
175 | SCM_SETCAR (ans, scm_tc16_memoized); |
176 | SCM_SETCDR (ans, z); | |
f0e9217a MD |
177 | SCM_ALLOW_INTS; |
178 | return ans; | |
179 | } | |
180 | ||
181 | SCM_PROC (s_unmemoize, "unmemoize", 1, 0, 0, scm_unmemoize); | |
1cc91f1b | 182 | |
f0e9217a MD |
183 | SCM |
184 | scm_unmemoize (m) | |
185 | SCM m; | |
f0e9217a | 186 | { |
6c179711 | 187 | SCM_ASSERT (SCM_NIMP (m) && SCM_MEMOIZEDP (m), m, SCM_ARG1, s_unmemoize); |
bfe3154c | 188 | return scm_unmemocopy (SCM_MEMOIZED_EXP (m), SCM_MEMOIZED_ENV (m)); |
f0e9217a MD |
189 | } |
190 | ||
191 | SCM_PROC (s_memoized_environment, "memoized-environment", 1, 0, 0, scm_memoized_environment); | |
1cc91f1b | 192 | |
f0e9217a MD |
193 | SCM |
194 | scm_memoized_environment (m) | |
195 | SCM m; | |
f0e9217a | 196 | { |
6c179711 | 197 | SCM_ASSERT (SCM_NIMP (m) && SCM_MEMOIZEDP (m), m, SCM_ARG1, s_unmemoize); |
bfe3154c | 198 | return SCM_MEMOIZED_ENV (m); |
f0e9217a MD |
199 | } |
200 | ||
201 | SCM_PROC (s_procedure_name, "procedure-name", 1, 0, 0, scm_procedure_name); | |
1cc91f1b | 202 | |
f0e9217a MD |
203 | SCM |
204 | scm_procedure_name (proc) | |
205 | SCM proc; | |
f0e9217a MD |
206 | { |
207 | SCM_ASSERT(scm_procedure_p (proc) == SCM_BOOL_T, | |
208 | proc, | |
209 | SCM_ARG1, | |
210 | s_procedure_name); | |
211 | switch (SCM_TYP7 (proc)) { | |
212 | case scm_tcs_closures: | |
c6b8a41a | 213 | case scm_tc7_cclo: |
f0e9217a MD |
214 | { |
215 | SCM name = scm_procedure_property (proc, scm_i_name); | |
216 | #if 0 | |
80ea260c | 217 | /* Source property scm_i_procname not implemented yet... */ |
f0e9217a MD |
218 | SCM name = scm_source_property (SCM_CAR (SCM_CDR (SCM_CODE (proc))), scm_i_procname); |
219 | if (SCM_FALSEP (name)) | |
220 | name = scm_procedure_property (proc, scm_i_name); | |
221 | #endif | |
80ea260c MD |
222 | if (SCM_FALSEP (name)) |
223 | name = scm_procedure_property (proc, scm_i_inner_name); | |
f0e9217a MD |
224 | return name; |
225 | } | |
226 | case scm_tcs_subrs: | |
227 | return SCM_SNAME (proc); | |
228 | default: | |
229 | return SCM_BOOL_F; | |
230 | } | |
231 | } | |
232 | ||
233 | SCM_PROC (s_procedure_source, "procedure-source", 1, 0, 0, scm_procedure_source); | |
1cc91f1b | 234 | |
f0e9217a MD |
235 | SCM |
236 | scm_procedure_source (proc) | |
237 | SCM proc; | |
f0e9217a MD |
238 | { |
239 | SCM_ASSERT(SCM_NIMP (proc), proc, SCM_ARG1, s_procedure_source); | |
240 | switch (SCM_TYP7 (proc)) { | |
241 | case scm_tcs_closures: | |
242 | { | |
243 | SCM src; | |
244 | src = scm_source_property (SCM_CDR (SCM_CODE (proc)), scm_i_copy); | |
245 | if (src != SCM_BOOL_F) | |
246 | return scm_cons2 (scm_i_lambda, SCM_CAR (SCM_CODE (proc)), src); | |
247 | src = SCM_CODE (proc); | |
248 | return scm_cons (scm_i_lambda, | |
249 | scm_unmemocopy (src, | |
e2806c10 | 250 | SCM_EXTEND_ENV (SCM_CAR (src), |
f0e9217a MD |
251 | SCM_EOL, |
252 | SCM_ENV (proc)))); | |
253 | } | |
254 | case scm_tc7_contin: | |
255 | case scm_tcs_subrs: | |
256 | #ifdef CCLO | |
257 | case scm_tc7_cclo: | |
258 | #endif | |
259 | /* It would indeed be a nice thing if we supplied source even for | |
260 | built in procedures! */ | |
261 | return scm_procedure_property (proc, scm_i_source); | |
262 | default: | |
263 | scm_wta (proc, (char *) SCM_ARG1, s_procedure_source); | |
264 | return 0; | |
265 | } | |
266 | } | |
267 | ||
268 | SCM_PROC (s_procedure_environment, "procedure-environment", 1, 0, 0, scm_procedure_environment); | |
1cc91f1b | 269 | |
f0e9217a MD |
270 | SCM |
271 | scm_procedure_environment (proc) | |
272 | SCM proc; | |
f0e9217a MD |
273 | { |
274 | SCM_ASSERT (SCM_NIMP (proc), proc, SCM_ARG1, s_procedure_environment); | |
275 | switch (SCM_TYP7 (proc)) { | |
276 | case scm_tcs_closures: | |
277 | return SCM_ENV (proc); | |
278 | case scm_tc7_contin: | |
279 | case scm_tcs_subrs: | |
280 | #ifdef CCLO | |
281 | case scm_tc7_cclo: | |
282 | #endif | |
283 | return SCM_EOL; | |
284 | default: | |
285 | scm_wta (proc, (char *) SCM_ARG1, s_procedure_environment); | |
286 | return 0; | |
287 | } | |
288 | } | |
289 | ||
bfe3154c | 290 | \f |
f0e9217a MD |
291 | |
292 | /* Eval in a local environment. We would like to have the ability to | |
e38ecb05 MD |
293 | * evaluate in a specified local environment, but due to the |
294 | * memoization this isn't normally possible. We solve it by copying | |
295 | * the code before evaluating. One solution would be to have eval.c | |
296 | * generate yet another evaluator. They are not very big actually. | |
f0e9217a | 297 | */ |
6c179711 | 298 | SCM_PROC (s_local_eval, "local-eval", 1, 1, 0, scm_local_eval); |
1cc91f1b | 299 | |
f0e9217a MD |
300 | SCM |
301 | scm_local_eval (exp, env) | |
302 | SCM exp; | |
303 | SCM env; | |
f0e9217a | 304 | { |
6c179711 MD |
305 | if (SCM_UNBNDP (env)) |
306 | { | |
b210cb73 | 307 | SCM_ASSERT (SCM_NIMP (exp) && SCM_MEMOIZEDP (exp), exp, SCM_ARG1, s_local_eval); |
6c179711 MD |
308 | return scm_eval_3 (SCM_MEMOIZED_EXP (exp), 0, SCM_MEMOIZED_ENV (exp)); |
309 | } | |
f0e9217a MD |
310 | return scm_eval_3 (exp, 1, env); |
311 | } | |
312 | ||
bfe3154c MD |
313 | static char s_start_stack[] = "start-stack"; |
314 | SCM | |
315 | scm_m_start_stack (exp, env) | |
316 | SCM exp; | |
317 | SCM env; | |
318 | { | |
319 | SCM answer; | |
c6b8a41a | 320 | scm_debug_frame vframe; |
c0ab1b8d | 321 | scm_debug_info vframe_vect_body; |
bfe3154c | 322 | exp = SCM_CDR (exp); |
c6b8a41a | 323 | SCM_ASSERT (SCM_NIMP (exp) |
e38ecb05 | 324 | && SCM_ECONSP (exp) |
c6b8a41a | 325 | && SCM_NIMP (SCM_CDR (exp)) |
e38ecb05 | 326 | && SCM_ECONSP (SCM_CDR (exp)) |
c6b8a41a | 327 | && SCM_NULLP (SCM_CDDR (exp)), |
bfe3154c MD |
328 | exp, |
329 | SCM_WNA, | |
330 | s_start_stack); | |
e38ecb05 | 331 | vframe.prev = scm_last_debug_frame; |
c6b8a41a | 332 | vframe.status = SCM_VOIDFRAME; |
c0ab1b8d | 333 | vframe.vect = &vframe_vect_body; |
c6b8a41a MD |
334 | vframe.vect[0].id = scm_eval_car (exp, env); |
335 | scm_last_debug_frame = &vframe; | |
336 | answer = scm_eval_car (SCM_CDR (exp), env); | |
e38ecb05 | 337 | scm_last_debug_frame = vframe.prev; |
bfe3154c MD |
338 | return answer; |
339 | } | |
f0e9217a MD |
340 | |
341 | /* {Debug Objects} | |
342 | * | |
343 | * The debugging evaluator throws these on frame traps. | |
344 | */ | |
345 | ||
346 | long scm_tc16_debugobj; | |
347 | ||
1cc91f1b JB |
348 | static int prindebugobj SCM_P ((SCM obj, SCM port, scm_print_state *pstate)); |
349 | ||
f0e9217a | 350 | static int |
1cc91f1b | 351 | prindebugobj (obj, port, pstate) |
9882ea19 MD |
352 | SCM obj; |
353 | SCM port; | |
354 | scm_print_state *pstate; | |
f0e9217a | 355 | { |
b7f3516f | 356 | scm_puts ("#<debug-object ", port); |
bfe3154c | 357 | scm_intprint (SCM_DEBUGOBJ_FRAME (obj), 16, port); |
b7f3516f | 358 | scm_putc ('>', port); |
f0e9217a MD |
359 | return 1; |
360 | } | |
361 | ||
362 | static scm_smobfuns debugobjsmob = | |
363 | {scm_mark0, scm_free0, prindebugobj, 0}; | |
364 | ||
365 | SCM_PROC (s_debug_object_p, "debug-object?", 1, 0, 0, scm_debug_object_p); | |
1cc91f1b | 366 | |
f0e9217a MD |
367 | SCM |
368 | scm_debug_object_p (obj) | |
369 | SCM obj; | |
f0e9217a | 370 | { |
bfe3154c | 371 | return SCM_NIMP (obj) && SCM_DEBUGOBJP (obj) ? SCM_BOOL_T : SCM_BOOL_F; |
f0e9217a MD |
372 | } |
373 | ||
1cc91f1b | 374 | |
f0e9217a MD |
375 | SCM |
376 | scm_make_debugobj (frame) | |
377 | scm_debug_frame *frame; | |
f0e9217a MD |
378 | { |
379 | register SCM z; | |
380 | SCM_DEFER_INTS; | |
381 | SCM_NEWCELL (z); | |
a6c64c3c MD |
382 | SCM_SETCAR (z, scm_tc16_debugobj); |
383 | SCM_SET_DEBUGOBJ_FRAME (z, (SCM) frame); | |
f0e9217a MD |
384 | SCM_ALLOW_INTS; |
385 | return z; | |
386 | } | |
387 | ||
f0e9217a MD |
388 | \f |
389 | ||
fe57f652 MD |
390 | /* Undocumented debugging procedure */ |
391 | #ifdef GUILE_DEBUG | |
e38ecb05 MD |
392 | SCM_PROC (s_debug_hang, "debug-hang", 0, 1, 0, scm_debug_hang); |
393 | ||
394 | SCM | |
395 | scm_debug_hang (obj) | |
396 | SCM obj; | |
397 | { | |
398 | int go = 0; | |
399 | while (!go) ; | |
400 | return SCM_UNSPECIFIED; | |
401 | } | |
fe57f652 | 402 | #endif |
e38ecb05 MD |
403 | |
404 | \f | |
405 | ||
f0e9217a MD |
406 | void |
407 | scm_init_debug () | |
408 | { | |
5e8d7fd4 | 409 | scm_init_opts (scm_debug_options, scm_debug_opts, SCM_N_DEBUG_OPTIONS); |
8755c9e4 MD |
410 | scm_init_opts (scm_evaluator_traps, |
411 | scm_evaluator_trap_table, | |
412 | SCM_N_EVALUATOR_TRAPS); | |
ee340120 | 413 | |
f0e9217a MD |
414 | scm_tc16_memoized = scm_newsmob (&memoizedsmob); |
415 | scm_tc16_debugobj = scm_newsmob (&debugobjsmob); | |
416 | ||
417 | scm_i_procname = SCM_CAR (scm_sysintern ("procname", SCM_UNDEFINED)); | |
418 | scm_i_more = SCM_CAR (scm_sysintern ("...", SCM_UNDEFINED)); | |
419 | scm_i_source = SCM_CAR (scm_sysintern ("source", SCM_UNDEFINED)); | |
420 | scm_i_proc = SCM_CAR (scm_sysintern ("proc", SCM_UNDEFINED)); | |
421 | scm_i_args = SCM_CAR (scm_sysintern ("args", SCM_UNDEFINED)); | |
422 | scm_i_eval_args = SCM_CAR (scm_sysintern ("eval-args", SCM_UNDEFINED)); | |
423 | ||
bfe3154c MD |
424 | scm_make_synt (s_start_stack, scm_makacro, scm_m_start_stack); |
425 | ||
f0e9217a MD |
426 | scm_add_feature ("debug-extensions"); |
427 | ||
428 | #include "debug.x" | |
429 | } |