1
/* Debugging extensions for Guile
2
* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006 Free Software Foundation
4
* This library is free software; you can redistribute it and/or
5
* modify it under the terms of the GNU Lesser General Public
6
* License as published by the Free Software Foundation; either
7
* version 2.1 of the License, or (at your option) any later version.
9
* This library 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 GNU
12
* Lesser General Public License for more details.
14
* You should have received a copy of the GNU Lesser General Public
15
* License along with this library; if not, write to the Free Software
16
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
21
#include "libguile/_scm.h"
22
#include "libguile/async.h"
23
#include "libguile/eval.h"
24
#include "libguile/list.h"
25
#include "libguile/stackchk.h"
26
#include "libguile/throw.h"
27
#include "libguile/macros.h"
28
#include "libguile/smob.h"
29
#include "libguile/procprop.h"
30
#include "libguile/srcprop.h"
31
#include "libguile/alist.h"
32
#include "libguile/continuations.h"
33
#include "libguile/strports.h"
34
#include "libguile/read.h"
35
#include "libguile/feature.h"
36
#include "libguile/dynwind.h"
37
#include "libguile/modules.h"
38
#include "libguile/ports.h"
39
#include "libguile/root.h"
40
#include "libguile/fluids.h"
41
#include "libguile/objects.h"
43
#include "libguile/validate.h"
44
#include "libguile/debug.h"
47
/* {Run time control of the debugging evaluator}
50
SCM_DEFINE (scm_debug_options, "debug-options-interface", 0, 1, 0,
52
"Option interface for the debug options. Instead of using\n"
53
"this procedure directly, use the procedures @code{debug-enable},\n"
54
"@code{debug-disable}, @code{debug-set!} and @code{debug-options}.")
55
#define FUNC_NAME s_scm_debug_options
59
scm_dynwind_begin (0);
60
scm_dynwind_critical_section (SCM_BOOL_F);
62
ans = scm_options (setting, scm_debug_opts, SCM_N_DEBUG_OPTIONS, FUNC_NAME);
63
if (!(1 <= SCM_N_FRAMES && SCM_N_FRAMES <= SCM_MAX_FRAME_SIZE))
65
scm_options (ans, scm_debug_opts, SCM_N_DEBUG_OPTIONS, FUNC_NAME);
66
SCM_OUT_OF_RANGE (1, setting);
69
scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
70
scm_debug_eframe_size = 2 * SCM_N_FRAMES;
78
with_traps_before (void *data)
80
int *trap_flag = data;
81
*trap_flag = SCM_TRAPS_P;
86
with_traps_after (void *data)
88
int *trap_flag = data;
89
SCM_TRAPS_P = *trap_flag;
93
with_traps_inner (void *data)
95
SCM thunk = SCM_PACK ((scm_t_bits) data);
96
return scm_call_0 (thunk);
99
SCM_DEFINE (scm_with_traps, "with-traps", 1, 0, 0,
101
"Call @var{thunk} with traps enabled.")
102
#define FUNC_NAME s_scm_with_traps
105
SCM_VALIDATE_THUNK (1, thunk);
106
return scm_internal_dynamic_wind (with_traps_before,
109
(void *) SCM_UNPACK (thunk),
116
SCM_SYMBOL (scm_sym_procname, "procname");
117
SCM_SYMBOL (scm_sym_dots, "...");
118
SCM_SYMBOL (scm_sym_source, "source");
123
scm_t_bits scm_tc16_memoized;
126
memoized_print (SCM obj, SCM port, scm_print_state *pstate)
128
int writingp = SCM_WRITINGP (pstate);
129
scm_puts ("#<memoized ", port);
130
SCM_SET_WRITINGP (pstate, 1);
131
scm_iprin1 (SCM_MEMOIZED_EXP (obj), port, pstate);
132
SCM_SET_WRITINGP (pstate, writingp);
133
scm_putc ('>', port);
137
SCM_DEFINE (scm_memoized_p, "memoized?", 1, 0, 0,
139
"Return @code{#t} if @var{obj} is memoized.")
140
#define FUNC_NAME s_scm_memoized_p
142
return scm_from_bool(SCM_MEMOIZEDP (obj));
147
scm_make_memoized (SCM exp, SCM env)
149
/* *fixme* Check that env is a valid environment. */
150
SCM_RETURN_NEWSMOB (scm_tc16_memoized, SCM_UNPACK (scm_cons (exp, env)));
155
* Some primitives for construction of memoized code
157
* - procedure: memcons CAR CDR [ENV]
159
* Construct a pair, encapsulated in a memoized object.
161
* The CAR and CDR can be either normal or memoized. If ENV isn't
162
* specified, the top-level environment of the current module will
163
* be assumed. All environments must match.
165
* - procedure: make-iloc FRAME BINDING CDRP
167
* Return an iloc referring to frame no. FRAME, binding
168
* no. BINDING. If CDRP is non-#f, the iloc is referring to a
169
* frame consisting of a single pair, with the value stored in the
172
* - procedure: iloc? OBJECT
174
* Return #t if OBJECT is an iloc.
176
* - procedure: mem->proc MEMOIZED
178
* Construct a closure from the memoized lambda expression MEMOIZED
180
* WARNING! The code is not copied!
182
* - procedure: proc->mem CLOSURE
184
* Turn the closure CLOSURE into a memoized object.
186
* WARNING! The code is not copied!
188
* - constant: SCM_IM_AND
189
* - constant: SCM_IM_BEGIN
190
* - constant: SCM_IM_CASE
191
* - constant: SCM_IM_COND
192
* - constant: SCM_IM_DO
193
* - constant: SCM_IM_IF
194
* - constant: SCM_IM_LAMBDA
195
* - constant: SCM_IM_LET
196
* - constant: SCM_IM_LETSTAR
197
* - constant: SCM_IM_LETREC
198
* - constant: SCM_IM_OR
199
* - constant: SCM_IM_QUOTE
200
* - constant: SCM_IM_SET
201
* - constant: SCM_IM_DEFINE
202
* - constant: SCM_IM_APPLY
203
* - constant: SCM_IM_CONT
204
* - constant: SCM_IM_DISPATCH
207
#include "libguile/variable.h"
208
#include "libguile/procs.h"
210
SCM_DEFINE (scm_memcons, "memcons", 2, 1, 0,
211
(SCM car, SCM cdr, SCM env),
212
"Return a new memoized cons cell with @var{car} and @var{cdr}\n"
213
"as members and @var{env} as the environment.")
214
#define FUNC_NAME s_scm_memcons
216
if (SCM_MEMOIZEDP (car))
218
/*fixme* environments may be two different but equal top-level envs */
219
if (!SCM_UNBNDP (env) && SCM_MEMOIZED_ENV (car) != env)
220
SCM_MISC_ERROR ("environment mismatch arg1 <-> arg3",
221
scm_list_2 (car, env));
223
env = SCM_MEMOIZED_ENV (car);
224
car = SCM_MEMOIZED_EXP (car);
226
if (SCM_MEMOIZEDP (cdr))
228
if (!SCM_UNBNDP (env) && SCM_MEMOIZED_ENV (cdr) != env)
229
SCM_MISC_ERROR ("environment mismatch arg2 <-> arg3",
230
scm_list_2 (cdr, env));
232
env = SCM_MEMOIZED_ENV (cdr);
233
cdr = SCM_MEMOIZED_EXP (cdr);
235
if (SCM_UNBNDP (env))
236
env = scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE);
238
SCM_VALIDATE_NULLORCONS (3, env);
239
return scm_make_memoized (scm_cons (car, cdr), env);
243
SCM_DEFINE (scm_mem_to_proc, "mem->proc", 1, 0, 0,
245
"Convert a memoized object (which must represent a body)\n"
247
#define FUNC_NAME s_scm_mem_to_proc
250
SCM_VALIDATE_MEMOIZED (1, obj);
251
env = SCM_MEMOIZED_ENV (obj);
252
obj = SCM_MEMOIZED_EXP (obj);
253
return scm_closure (obj, env);
257
SCM_DEFINE (scm_proc_to_mem, "proc->mem", 1, 0, 0,
259
"Convert a procedure to a memoized object.")
260
#define FUNC_NAME s_scm_proc_to_mem
262
SCM_VALIDATE_CLOSURE (1, obj);
263
return scm_make_memoized (SCM_CODE (obj), SCM_ENV (obj));
267
#endif /* GUILE_DEBUG */
269
SCM_DEFINE (scm_i_unmemoize_expr, "unmemoize-expr", 1, 0, 0,
271
"Unmemoize the memoized expression @var{m},")
272
#define FUNC_NAME s_scm_i_unmemoize_expr
274
SCM_VALIDATE_MEMOIZED (1, m);
275
return scm_i_unmemocopy_expr (SCM_MEMOIZED_EXP (m), SCM_MEMOIZED_ENV (m));
279
SCM_DEFINE (scm_memoized_environment, "memoized-environment", 1, 0, 0,
281
"Return the environment of the memoized expression @var{m}.")
282
#define FUNC_NAME s_scm_memoized_environment
284
SCM_VALIDATE_MEMOIZED (1, m);
285
return SCM_MEMOIZED_ENV (m);
289
SCM_DEFINE (scm_procedure_name, "procedure-name", 1, 0, 0,
291
"Return the name of the procedure @var{proc}")
292
#define FUNC_NAME s_scm_procedure_name
294
SCM_VALIDATE_PROC (1, proc);
295
switch (SCM_TYP7 (proc)) {
297
return SCM_SNAME (proc);
300
SCM name = scm_procedure_property (proc, scm_sym_name);
302
/* Source property scm_sym_procname not implemented yet... */
303
SCM name = scm_source_property (SCM_CAR (SCM_CLOSURE_BODY (proc)), scm_sym_procname);
304
if (scm_is_false (name))
305
name = scm_procedure_property (proc, scm_sym_name);
307
if (scm_is_false (name) && SCM_CLOSUREP (proc))
308
name = scm_reverse_lookup (SCM_ENV (proc), proc);
315
SCM_DEFINE (scm_procedure_source, "procedure-source", 1, 0, 0,
317
"Return the source of the procedure @var{proc}.")
318
#define FUNC_NAME s_scm_procedure_source
320
SCM_VALIDATE_NIM (1, proc);
322
switch (SCM_TYP7 (proc)) {
323
case scm_tcs_closures:
325
const SCM formals = SCM_CLOSURE_FORMALS (proc);
326
const SCM body = SCM_CLOSURE_BODY (proc);
327
const SCM src = scm_source_property (body, scm_sym_copy);
329
if (scm_is_true (src))
331
return scm_cons2 (scm_sym_lambda, formals, src);
335
const SCM env = SCM_EXTEND_ENV (formals, SCM_EOL, SCM_ENV (proc));
336
return scm_cons2 (scm_sym_lambda,
337
scm_i_finite_list_copy (formals),
338
scm_i_unmemocopy_body (body, env));
342
if (!SCM_I_OPERATORP (proc))
346
if (!SCM_SMOB_DESCRIPTOR (proc).apply)
353
/* It would indeed be a nice thing if we supplied source even for
354
built in procedures! */
355
return scm_procedure_property (proc, scm_sym_source);
358
SCM src = scm_procedure_property (proc, scm_sym_source);
359
if (scm_is_true (src))
361
proc = SCM_PROCEDURE (proc);
367
SCM_WRONG_TYPE_ARG (1, proc);
368
return SCM_BOOL_F; /* not reached */
372
SCM_DEFINE (scm_procedure_environment, "procedure-environment", 1, 0, 0,
374
"Return the environment of the procedure @var{proc}.")
375
#define FUNC_NAME s_scm_procedure_environment
377
SCM_VALIDATE_NIM (1, proc);
378
switch (SCM_TYP7 (proc)) {
379
case scm_tcs_closures:
380
return SCM_ENV (proc);
387
SCM_WRONG_TYPE_ARG (1, proc);
395
/* Eval in a local environment. We would like to have the ability to
396
* evaluate in a specified local environment, but due to the
397
* memoization this isn't normally possible. We solve it by copying
398
* the code before evaluating. One solution would be to have eval.c
399
* generate yet another evaluator. They are not very big actually.
401
SCM_DEFINE (scm_local_eval, "local-eval", 1, 1, 0,
403
"Evaluate @var{exp} in its environment. If @var{env} is supplied,\n"
404
"it is the environment in which to evaluate @var{exp}. Otherwise,\n"
405
"@var{exp} must be a memoized code object (in which case, its environment\n"
407
#define FUNC_NAME s_scm_local_eval
409
if (SCM_UNBNDP (env))
411
SCM_VALIDATE_MEMOIZED (1, exp);
412
return scm_i_eval_x (SCM_MEMOIZED_EXP (exp), SCM_MEMOIZED_ENV (exp));
414
return scm_i_eval (exp, env);
419
SCM_REGISTER_PROC (s_reverse_lookup, "reverse-lookup", 2, 0, 0, scm_reverse_lookup);
423
scm_reverse_lookup (SCM env, SCM data)
425
while (scm_is_pair (env) && scm_is_pair (SCM_CAR (env)))
427
SCM names = SCM_CAAR (env);
428
SCM values = SCM_CDAR (env);
429
while (scm_is_pair (names))
431
if (scm_is_eq (SCM_CAR (values), data))
432
return SCM_CAR (names);
433
names = SCM_CDR (names);
434
values = SCM_CDR (values);
436
if (!scm_is_null (names) && scm_is_eq (values, data))
444
scm_start_stack (SCM id, SCM exp, SCM env)
447
scm_t_debug_frame vframe;
448
scm_t_debug_info vframe_vect_body;
449
vframe.prev = scm_i_last_debug_frame ();
450
vframe.status = SCM_VOIDFRAME;
451
vframe.vect = &vframe_vect_body;
452
vframe.vect[0].id = id;
453
scm_i_set_last_debug_frame (&vframe);
454
answer = scm_i_eval (exp, env);
455
scm_i_set_last_debug_frame (vframe.prev);
459
SCM_SYNTAX(s_start_stack, "start-stack", scm_makacro, scm_m_start_stack);
462
scm_m_start_stack (SCM exp, SCM env)
463
#define FUNC_NAME s_start_stack
466
if (!scm_is_pair (exp)
467
|| !scm_is_pair (SCM_CDR (exp))
468
|| !scm_is_null (SCM_CDDR (exp)))
469
SCM_WRONG_NUM_ARGS ();
470
return scm_start_stack (scm_eval_car (exp, env), SCM_CADR (exp), env);
477
* The debugging evaluator throws these on frame traps.
480
scm_t_bits scm_tc16_debugobj;
483
debugobj_print (SCM obj, SCM port, scm_print_state *pstate SCM_UNUSED)
485
scm_puts ("#<debug-object ", port);
486
scm_intprint ((long) SCM_DEBUGOBJ_FRAME (obj), 16, port);
487
scm_putc ('>', port);
491
SCM_DEFINE (scm_debug_object_p, "debug-object?", 1, 0, 0,
493
"Return @code{#t} if @var{obj} is a debug object.")
494
#define FUNC_NAME s_scm_debug_object_p
496
return scm_from_bool(SCM_DEBUGOBJP (obj));
502
scm_make_debugobj (scm_t_debug_frame *frame)
504
return scm_cell (scm_tc16_debugobj, (scm_t_bits) frame);
509
/* Undocumented debugging procedure */
511
SCM_DEFINE (scm_debug_hang, "debug-hang", 0, 1, 0,
513
"Go into an endless loop, which can be only terminated with\n"
515
#define FUNC_NAME s_scm_debug_hang
519
return SCM_UNSPECIFIED;
529
scm_init_opts (scm_debug_options, scm_debug_opts, SCM_N_DEBUG_OPTIONS);
531
scm_tc16_memoized = scm_make_smob_type ("memoized", 0);
532
scm_set_smob_mark (scm_tc16_memoized, scm_markcdr);
533
scm_set_smob_print (scm_tc16_memoized, memoized_print);
535
scm_tc16_debugobj = scm_make_smob_type ("debug-object", 0);
536
scm_set_smob_print (scm_tc16_debugobj, debugobj_print);
539
scm_c_define ("SCM_IM_AND", SCM_IM_AND);
540
scm_c_define ("SCM_IM_BEGIN", SCM_IM_BEGIN);
541
scm_c_define ("SCM_IM_CASE", SCM_IM_CASE);
542
scm_c_define ("SCM_IM_COND", SCM_IM_COND);
543
scm_c_define ("SCM_IM_DO", SCM_IM_DO);
544
scm_c_define ("SCM_IM_IF", SCM_IM_IF);
545
scm_c_define ("SCM_IM_LAMBDA", SCM_IM_LAMBDA);
546
scm_c_define ("SCM_IM_LET", SCM_IM_LET);
547
scm_c_define ("SCM_IM_LETSTAR", SCM_IM_LETSTAR);
548
scm_c_define ("SCM_IM_LETREC", SCM_IM_LETREC);
549
scm_c_define ("SCM_IM_OR", SCM_IM_OR);
550
scm_c_define ("SCM_IM_QUOTE", SCM_IM_QUOTE);
551
scm_c_define ("SCM_IM_SET_X", SCM_IM_SET_X);
552
scm_c_define ("SCM_IM_DEFINE", SCM_IM_DEFINE);
553
scm_c_define ("SCM_IM_APPLY", SCM_IM_APPLY);
554
scm_c_define ("SCM_IM_CONT", SCM_IM_CONT);
555
scm_c_define ("SCM_IM_DISPATCH", SCM_IM_DISPATCH);
557
scm_add_feature ("debug-extensions");
559
#include "libguile/debug.x"
added
removed
libguile/debug.c
