Commit | Line | Data |
---|---|---|
f0e9217a | 1 | /* Debugging extensions for Guile |
ee340120 MD |
2 | * Copyright (C) 1995, 1996 Mikael Djurfeldt |
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 | |
16 | * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. | |
17 | * | |
18 | * As a special exception, the Free Software Foundation gives permission | |
19 | * for additional uses of the text contained in its release of GUILE. | |
20 | * | |
21 | * The exception is that, if you link the GUILE library with other files | |
22 | * to produce an executable, this does not by itself cause the | |
23 | * resulting executable to be covered by the GNU General Public License. | |
24 | * Your use of that executable is in no way restricted on account of | |
25 | * linking the GUILE library code into it. | |
26 | * | |
27 | * This exception does not however invalidate any other reasons why | |
28 | * the executable file might be covered by the GNU General Public License. | |
29 | * | |
30 | * This exception applies only to the code released by the | |
31 | * Free Software Foundation under the name GUILE. If you copy | |
32 | * code from other Free Software Foundation releases into a copy of | |
33 | * GUILE, as the General Public License permits, the exception does | |
34 | * not apply to the code that you add in this way. To avoid misleading | |
35 | * anyone as to the status of such modified files, you must delete | |
36 | * this exception notice from them. | |
37 | * | |
38 | * If you write modifications of your own for GUILE, it is your choice | |
39 | * whether to permit this exception to apply to your modifications. | |
40 | * If you do not wish that, delete this exception notice. | |
41 | * | |
42 | * The author can be reached at djurfeldt@nada.kth.se | |
43 | * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN | |
44 | */ | |
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); |
f0e9217a | 143 | scm_gen_puts (scm_regular_string, "#<memoized ", port); |
9882ea19 MD |
144 | SCM_SET_WRITINGP (pstate, 1); |
145 | scm_iprin1 (scm_unmemoize (obj), port, pstate); | |
146 | SCM_SET_WRITINGP (pstate, writingp); | |
f0e9217a MD |
147 | scm_gen_putc ('>', port); |
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 | |
217 | /* Procedure property scm_i_procname not implemented yet... */ | |
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 | |
222 | return name; | |
223 | } | |
224 | case scm_tcs_subrs: | |
225 | return SCM_SNAME (proc); | |
226 | default: | |
227 | return SCM_BOOL_F; | |
228 | } | |
229 | } | |
230 | ||
231 | SCM_PROC (s_procedure_source, "procedure-source", 1, 0, 0, scm_procedure_source); | |
1cc91f1b | 232 | |
f0e9217a MD |
233 | SCM |
234 | scm_procedure_source (proc) | |
235 | SCM proc; | |
f0e9217a MD |
236 | { |
237 | SCM_ASSERT(SCM_NIMP (proc), proc, SCM_ARG1, s_procedure_source); | |
238 | switch (SCM_TYP7 (proc)) { | |
239 | case scm_tcs_closures: | |
240 | { | |
241 | SCM src; | |
242 | src = scm_source_property (SCM_CDR (SCM_CODE (proc)), scm_i_copy); | |
243 | if (src != SCM_BOOL_F) | |
244 | return scm_cons2 (scm_i_lambda, SCM_CAR (SCM_CODE (proc)), src); | |
245 | src = SCM_CODE (proc); | |
246 | return scm_cons (scm_i_lambda, | |
247 | scm_unmemocopy (src, | |
e2806c10 | 248 | SCM_EXTEND_ENV (SCM_CAR (src), |
f0e9217a MD |
249 | SCM_EOL, |
250 | SCM_ENV (proc)))); | |
251 | } | |
252 | case scm_tc7_contin: | |
253 | case scm_tcs_subrs: | |
254 | #ifdef CCLO | |
255 | case scm_tc7_cclo: | |
256 | #endif | |
257 | /* It would indeed be a nice thing if we supplied source even for | |
258 | built in procedures! */ | |
259 | return scm_procedure_property (proc, scm_i_source); | |
260 | default: | |
261 | scm_wta (proc, (char *) SCM_ARG1, s_procedure_source); | |
262 | return 0; | |
263 | } | |
264 | } | |
265 | ||
266 | SCM_PROC (s_procedure_environment, "procedure-environment", 1, 0, 0, scm_procedure_environment); | |
1cc91f1b | 267 | |
f0e9217a MD |
268 | SCM |
269 | scm_procedure_environment (proc) | |
270 | SCM proc; | |
f0e9217a MD |
271 | { |
272 | SCM_ASSERT (SCM_NIMP (proc), proc, SCM_ARG1, s_procedure_environment); | |
273 | switch (SCM_TYP7 (proc)) { | |
274 | case scm_tcs_closures: | |
275 | return SCM_ENV (proc); | |
276 | case scm_tc7_contin: | |
277 | case scm_tcs_subrs: | |
278 | #ifdef CCLO | |
279 | case scm_tc7_cclo: | |
280 | #endif | |
281 | return SCM_EOL; | |
282 | default: | |
283 | scm_wta (proc, (char *) SCM_ARG1, s_procedure_environment); | |
284 | return 0; | |
285 | } | |
286 | } | |
287 | ||
bfe3154c | 288 | \f |
f0e9217a MD |
289 | |
290 | /* Eval in a local environment. We would like to have the ability to | |
e38ecb05 MD |
291 | * evaluate in a specified local environment, but due to the |
292 | * memoization this isn't normally possible. We solve it by copying | |
293 | * the code before evaluating. One solution would be to have eval.c | |
294 | * generate yet another evaluator. They are not very big actually. | |
f0e9217a | 295 | */ |
6c179711 | 296 | SCM_PROC (s_local_eval, "local-eval", 1, 1, 0, scm_local_eval); |
1cc91f1b | 297 | |
f0e9217a MD |
298 | SCM |
299 | scm_local_eval (exp, env) | |
300 | SCM exp; | |
301 | SCM env; | |
f0e9217a | 302 | { |
6c179711 MD |
303 | if (SCM_UNBNDP (env)) |
304 | { | |
b210cb73 | 305 | SCM_ASSERT (SCM_NIMP (exp) && SCM_MEMOIZEDP (exp), exp, SCM_ARG1, s_local_eval); |
6c179711 MD |
306 | return scm_eval_3 (SCM_MEMOIZED_EXP (exp), 0, SCM_MEMOIZED_ENV (exp)); |
307 | } | |
f0e9217a MD |
308 | return scm_eval_3 (exp, 1, env); |
309 | } | |
310 | ||
bfe3154c MD |
311 | static char s_start_stack[] = "start-stack"; |
312 | SCM | |
313 | scm_m_start_stack (exp, env) | |
314 | SCM exp; | |
315 | SCM env; | |
316 | { | |
317 | SCM answer; | |
c6b8a41a | 318 | scm_debug_frame vframe; |
c0ab1b8d | 319 | scm_debug_info vframe_vect_body; |
bfe3154c | 320 | exp = SCM_CDR (exp); |
c6b8a41a | 321 | SCM_ASSERT (SCM_NIMP (exp) |
e38ecb05 | 322 | && SCM_ECONSP (exp) |
c6b8a41a | 323 | && SCM_NIMP (SCM_CDR (exp)) |
e38ecb05 | 324 | && SCM_ECONSP (SCM_CDR (exp)) |
c6b8a41a | 325 | && SCM_NULLP (SCM_CDDR (exp)), |
bfe3154c MD |
326 | exp, |
327 | SCM_WNA, | |
328 | s_start_stack); | |
e38ecb05 | 329 | vframe.prev = scm_last_debug_frame; |
c6b8a41a | 330 | vframe.status = SCM_VOIDFRAME; |
c0ab1b8d | 331 | vframe.vect = &vframe_vect_body; |
c6b8a41a MD |
332 | vframe.vect[0].id = scm_eval_car (exp, env); |
333 | scm_last_debug_frame = &vframe; | |
334 | answer = scm_eval_car (SCM_CDR (exp), env); | |
e38ecb05 | 335 | scm_last_debug_frame = vframe.prev; |
bfe3154c MD |
336 | return answer; |
337 | } | |
f0e9217a MD |
338 | |
339 | /* {Debug Objects} | |
340 | * | |
341 | * The debugging evaluator throws these on frame traps. | |
342 | */ | |
343 | ||
344 | long scm_tc16_debugobj; | |
345 | ||
1cc91f1b JB |
346 | static int prindebugobj SCM_P ((SCM obj, SCM port, scm_print_state *pstate)); |
347 | ||
f0e9217a | 348 | static int |
1cc91f1b | 349 | prindebugobj (obj, port, pstate) |
9882ea19 MD |
350 | SCM obj; |
351 | SCM port; | |
352 | scm_print_state *pstate; | |
f0e9217a MD |
353 | { |
354 | scm_gen_puts (scm_regular_string, "#<debug-object ", port); | |
bfe3154c | 355 | scm_intprint (SCM_DEBUGOBJ_FRAME (obj), 16, port); |
f0e9217a MD |
356 | scm_gen_putc ('>', port); |
357 | return 1; | |
358 | } | |
359 | ||
360 | static scm_smobfuns debugobjsmob = | |
361 | {scm_mark0, scm_free0, prindebugobj, 0}; | |
362 | ||
363 | SCM_PROC (s_debug_object_p, "debug-object?", 1, 0, 0, scm_debug_object_p); | |
1cc91f1b | 364 | |
f0e9217a MD |
365 | SCM |
366 | scm_debug_object_p (obj) | |
367 | SCM obj; | |
f0e9217a | 368 | { |
bfe3154c | 369 | return SCM_NIMP (obj) && SCM_DEBUGOBJP (obj) ? SCM_BOOL_T : SCM_BOOL_F; |
f0e9217a MD |
370 | } |
371 | ||
1cc91f1b | 372 | |
f0e9217a MD |
373 | SCM |
374 | scm_make_debugobj (frame) | |
375 | scm_debug_frame *frame; | |
f0e9217a MD |
376 | { |
377 | register SCM z; | |
378 | SCM_DEFER_INTS; | |
379 | SCM_NEWCELL (z); | |
a6c64c3c MD |
380 | SCM_SETCAR (z, scm_tc16_debugobj); |
381 | SCM_SET_DEBUGOBJ_FRAME (z, (SCM) frame); | |
f0e9217a MD |
382 | SCM_ALLOW_INTS; |
383 | return z; | |
384 | } | |
385 | ||
f0e9217a MD |
386 | \f |
387 | ||
fe57f652 MD |
388 | /* Undocumented debugging procedure */ |
389 | #ifdef GUILE_DEBUG | |
e38ecb05 MD |
390 | SCM_PROC (s_debug_hang, "debug-hang", 0, 1, 0, scm_debug_hang); |
391 | ||
392 | SCM | |
393 | scm_debug_hang (obj) | |
394 | SCM obj; | |
395 | { | |
396 | int go = 0; | |
397 | while (!go) ; | |
398 | return SCM_UNSPECIFIED; | |
399 | } | |
fe57f652 | 400 | #endif |
e38ecb05 MD |
401 | |
402 | \f | |
403 | ||
f0e9217a MD |
404 | void |
405 | scm_init_debug () | |
406 | { | |
5e8d7fd4 | 407 | scm_init_opts (scm_debug_options, scm_debug_opts, SCM_N_DEBUG_OPTIONS); |
8755c9e4 MD |
408 | scm_init_opts (scm_evaluator_traps, |
409 | scm_evaluator_trap_table, | |
410 | SCM_N_EVALUATOR_TRAPS); | |
ee340120 | 411 | |
f0e9217a MD |
412 | scm_tc16_memoized = scm_newsmob (&memoizedsmob); |
413 | scm_tc16_debugobj = scm_newsmob (&debugobjsmob); | |
414 | ||
415 | scm_i_procname = SCM_CAR (scm_sysintern ("procname", SCM_UNDEFINED)); | |
416 | scm_i_more = SCM_CAR (scm_sysintern ("...", SCM_UNDEFINED)); | |
417 | scm_i_source = SCM_CAR (scm_sysintern ("source", SCM_UNDEFINED)); | |
418 | scm_i_proc = SCM_CAR (scm_sysintern ("proc", SCM_UNDEFINED)); | |
419 | scm_i_args = SCM_CAR (scm_sysintern ("args", SCM_UNDEFINED)); | |
420 | scm_i_eval_args = SCM_CAR (scm_sysintern ("eval-args", SCM_UNDEFINED)); | |
421 | ||
bfe3154c MD |
422 | scm_make_synt (s_start_stack, scm_makacro, scm_m_start_stack); |
423 | ||
f0e9217a MD |
424 | scm_add_feature ("debug-extensions"); |
425 | ||
426 | #include "debug.x" | |
427 | } |