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 MD |
118 | SCM_ALLOW_INTS; |
119 | scm_throw (cont, val); | |
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 | ||
1cc91f1b | 163 | |
f0e9217a | 164 | SCM |
bba4bfdb | 165 | scm_make_memoized (exp, env) |
1cc91f1b JB |
166 | SCM exp; |
167 | SCM env; | |
f0e9217a MD |
168 | { |
169 | register SCM z, ans; | |
170 | SCM_DEFER_INTS; | |
171 | SCM_NEWCELL (z); | |
172 | SCM_CAR (z) = exp; | |
173 | SCM_CDR (z) = env; | |
174 | SCM_NEWCELL (ans); | |
175 | SCM_CAR (ans) = scm_tc16_memoized; | |
176 | SCM_CDR (ans) = z; | |
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 MD |
186 | { |
187 | SCM_ASSERT (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 MD |
196 | { |
197 | SCM_ASSERT (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 | |
291 | * evaluate in a specified local environment, but due to the memoization | |
292 | * this isn't normally possible. We solve it by copying the code before | |
293 | * evaluating. Probably the best solution would be to have eval.c generate | |
294 | * yet another evaluator. They are not very big actually. | |
295 | */ | |
296 | SCM_PROC (s_local_eval, "local-eval", 2, 0, 0, scm_local_eval); | |
1cc91f1b | 297 | |
f0e9217a MD |
298 | SCM |
299 | scm_local_eval (exp, env) | |
300 | SCM exp; | |
301 | SCM env; | |
f0e9217a MD |
302 | { |
303 | return scm_eval_3 (exp, 1, env); | |
304 | } | |
305 | ||
bfe3154c MD |
306 | static char s_start_stack[] = "start-stack"; |
307 | SCM | |
308 | scm_m_start_stack (exp, env) | |
309 | SCM exp; | |
310 | SCM env; | |
311 | { | |
312 | SCM answer; | |
c6b8a41a MD |
313 | scm_debug_frame *oframe = scm_last_debug_frame; |
314 | scm_debug_frame vframe; | |
bfe3154c | 315 | exp = SCM_CDR (exp); |
c6b8a41a MD |
316 | SCM_ASSERT (SCM_NIMP (exp) |
317 | && SCM_CONSP (exp) | |
318 | && SCM_NIMP (SCM_CDR (exp)) | |
319 | && SCM_CONSP (SCM_CDR (exp)) | |
320 | && SCM_NULLP (SCM_CDDR (exp)), | |
bfe3154c MD |
321 | exp, |
322 | SCM_WNA, | |
323 | s_start_stack); | |
c6b8a41a MD |
324 | vframe.prev = 0; |
325 | vframe.status = SCM_VOIDFRAME; | |
326 | vframe.vect[0].id = scm_eval_car (exp, env); | |
327 | scm_last_debug_frame = &vframe; | |
328 | answer = scm_eval_car (SCM_CDR (exp), env); | |
329 | scm_last_debug_frame = oframe; | |
bfe3154c MD |
330 | return answer; |
331 | } | |
f0e9217a MD |
332 | |
333 | /* {Debug Objects} | |
334 | * | |
335 | * The debugging evaluator throws these on frame traps. | |
336 | */ | |
337 | ||
338 | long scm_tc16_debugobj; | |
339 | ||
1cc91f1b JB |
340 | static int prindebugobj SCM_P ((SCM obj, SCM port, scm_print_state *pstate)); |
341 | ||
f0e9217a | 342 | static int |
1cc91f1b | 343 | prindebugobj (obj, port, pstate) |
9882ea19 MD |
344 | SCM obj; |
345 | SCM port; | |
346 | scm_print_state *pstate; | |
f0e9217a MD |
347 | { |
348 | scm_gen_puts (scm_regular_string, "#<debug-object ", port); | |
bfe3154c | 349 | scm_intprint (SCM_DEBUGOBJ_FRAME (obj), 16, port); |
f0e9217a MD |
350 | scm_gen_putc ('>', port); |
351 | return 1; | |
352 | } | |
353 | ||
354 | static scm_smobfuns debugobjsmob = | |
355 | {scm_mark0, scm_free0, prindebugobj, 0}; | |
356 | ||
357 | SCM_PROC (s_debug_object_p, "debug-object?", 1, 0, 0, scm_debug_object_p); | |
1cc91f1b | 358 | |
f0e9217a MD |
359 | SCM |
360 | scm_debug_object_p (obj) | |
361 | SCM obj; | |
f0e9217a | 362 | { |
bfe3154c | 363 | return SCM_NIMP (obj) && SCM_DEBUGOBJP (obj) ? SCM_BOOL_T : SCM_BOOL_F; |
f0e9217a MD |
364 | } |
365 | ||
1cc91f1b | 366 | |
f0e9217a MD |
367 | SCM |
368 | scm_make_debugobj (frame) | |
369 | scm_debug_frame *frame; | |
f0e9217a MD |
370 | { |
371 | register SCM z; | |
372 | SCM_DEFER_INTS; | |
373 | SCM_NEWCELL (z); | |
374 | SCM_CAR (z) = scm_tc16_debugobj; | |
bfe3154c | 375 | SCM_DEBUGOBJ_FRAME (z) = (SCM) frame; |
f0e9217a MD |
376 | SCM_ALLOW_INTS; |
377 | return z; | |
378 | } | |
379 | ||
f0e9217a MD |
380 | \f |
381 | ||
382 | void | |
383 | scm_init_debug () | |
384 | { | |
5e8d7fd4 | 385 | scm_init_opts (scm_debug_options, scm_debug_opts, SCM_N_DEBUG_OPTIONS); |
8755c9e4 MD |
386 | scm_init_opts (scm_evaluator_traps, |
387 | scm_evaluator_trap_table, | |
388 | SCM_N_EVALUATOR_TRAPS); | |
ee340120 | 389 | |
f0e9217a MD |
390 | scm_tc16_memoized = scm_newsmob (&memoizedsmob); |
391 | scm_tc16_debugobj = scm_newsmob (&debugobjsmob); | |
392 | ||
393 | scm_i_procname = SCM_CAR (scm_sysintern ("procname", SCM_UNDEFINED)); | |
394 | scm_i_more = SCM_CAR (scm_sysintern ("...", SCM_UNDEFINED)); | |
395 | scm_i_source = SCM_CAR (scm_sysintern ("source", SCM_UNDEFINED)); | |
396 | scm_i_proc = SCM_CAR (scm_sysintern ("proc", SCM_UNDEFINED)); | |
397 | scm_i_args = SCM_CAR (scm_sysintern ("args", SCM_UNDEFINED)); | |
398 | scm_i_eval_args = SCM_CAR (scm_sysintern ("eval-args", SCM_UNDEFINED)); | |
399 | ||
bfe3154c MD |
400 | scm_make_synt (s_start_stack, scm_makacro, scm_m_start_stack); |
401 | ||
f0e9217a MD |
402 | scm_add_feature ("debug-extensions"); |
403 | ||
404 | #include "debug.x" | |
405 | } |