1 /* Debugging extensions for Guile
2 * Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, 2008, 2009, 2010 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 License
6 * as published by the Free Software Foundation; either version 3 of
7 * the License, or (at your option) any later version.
9 * This library is distributed in the hope that it will be useful, but
10 * 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
27 #include <sys/resource.h>
30 #include "libguile/_scm.h"
31 #include "libguile/async.h"
32 #include "libguile/eval.h"
33 #include "libguile/list.h"
34 #include "libguile/stackchk.h"
35 #include "libguile/throw.h"
36 #include "libguile/macros.h"
37 #include "libguile/smob.h"
38 #include "libguile/struct.h"
39 #include "libguile/procprop.h"
40 #include "libguile/srcprop.h"
41 #include "libguile/alist.h"
42 #include "libguile/continuations.h"
43 #include "libguile/strports.h"
44 #include "libguile/read.h"
45 #include "libguile/feature.h"
46 #include "libguile/dynwind.h"
47 #include "libguile/modules.h"
48 #include "libguile/ports.h"
49 #include "libguile/root.h"
50 #include "libguile/fluids.h"
51 #include "libguile/programs.h"
52 #include "libguile/memoize.h"
53 #include "libguile/vm.h"
55 #include "libguile/validate.h"
56 #include "libguile/debug.h"
58 #include "libguile/private-options.h"
66 scm_t_option scm_debug_opts
[] = {
67 { SCM_OPTION_BOOLEAN
, "backwards", 0,
68 "Display backtrace in anti-chronological order." },
69 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
70 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
71 { SCM_OPTION_BOOLEAN
, "backtrace", 1, "Show backtrace on error." },
72 /* This default stack limit will be overridden by init_stack_limit(),
73 if we have getrlimit() and the stack limit is not INFINITY. But it is still
74 important, as some systems have both the soft and the hard limits set to
75 INFINITY; in that case we fall back to this value.
77 The situation is aggravated by certain compilers, which can consume
78 "beaucoup de stack", as they say in France.
80 See http://thread.gmane.org/gmane.lisp.guile.devel/8599/focus=8662 for
81 more discussion. This setting is 640 KB on 32-bit arches (should be enough
82 for anyone!) or a whoppin' 1280 KB on 64-bit arches.
84 { SCM_OPTION_INTEGER
, "stack", 160000, "Stack size limit (measured in words; 0 = no check)." },
85 { SCM_OPTION_SCM
, "show-file-name", (unsigned long)SCM_BOOL_T
,
86 "Show file names and line numbers "
87 "in backtraces when not `#f'. A value of `base' "
88 "displays only base names, while `#t' displays full names."},
89 { SCM_OPTION_BOOLEAN
, "warn-deprecated", 0,
90 "Warn when deprecated features are used." },
95 /* {Run time control of the debugging evaluator}
98 SCM_DEFINE (scm_debug_options
, "debug-options-interface", 0, 1, 0,
100 "Option interface for the debug options. Instead of using\n"
101 "this procedure directly, use the procedures @code{debug-enable},\n"
102 "@code{debug-disable}, @code{debug-set!} and @code{debug-options}.")
103 #define FUNC_NAME s_scm_debug_options
107 scm_dynwind_begin (0);
108 scm_dynwind_critical_section (SCM_BOOL_F
);
110 ans
= scm_options (setting
, scm_debug_opts
, FUNC_NAME
);
111 #ifdef STACK_CHECKING
112 scm_stack_checking_enabled_p
= SCM_STACK_CHECKING_P
;
121 SCM_SYMBOL (scm_sym_source
, "source");
123 SCM_DEFINE (scm_procedure_name
, "procedure-name", 1, 0, 0,
125 "Return the name of the procedure @var{proc}")
126 #define FUNC_NAME s_scm_procedure_name
128 SCM_VALIDATE_PROC (1, proc
);
129 while (SCM_STRUCTP (proc
) && SCM_STRUCT_APPLICABLE_P (proc
))
130 proc
= SCM_STRUCT_PROCEDURE (proc
);
131 return scm_procedure_property (proc
, scm_sym_name
);
135 SCM_DEFINE (scm_procedure_source
, "procedure-source", 1, 0, 0,
137 "Return the source of the procedure @var{proc}.")
138 #define FUNC_NAME s_scm_procedure_source
141 SCM_VALIDATE_PROC (1, proc
);
145 src
= scm_procedure_property (proc
, scm_sym_source
);
146 if (scm_is_true (src
))
149 switch (SCM_TYP7 (proc
)) {
151 if (!SCM_STRUCT_APPLICABLE_P (proc
)
152 || SCM_IMP (SCM_STRUCT_PROCEDURE (proc
)))
154 proc
= SCM_STRUCT_PROCEDURE (proc
);
170 SCM_REGISTER_PROC (s_reverse_lookup
, "reverse-lookup", 2, 0, 0, scm_reverse_lookup
);
174 scm_reverse_lookup (SCM env
, SCM data
)
176 while (scm_is_pair (env
) && scm_is_pair (SCM_CAR (env
)))
178 SCM names
= SCM_CAAR (env
);
179 SCM values
= SCM_CDAR (env
);
180 while (scm_is_pair (names
))
182 if (scm_is_eq (SCM_CAR (values
), data
))
183 return SCM_CAR (names
);
184 names
= SCM_CDR (names
);
185 values
= SCM_CDR (values
);
187 if (!scm_is_null (names
) && scm_is_eq (values
, data
))
196 /* Undocumented debugging procedure */
198 SCM_DEFINE (scm_debug_hang
, "debug-hang", 0, 1, 0,
200 "Go into an endless loop, which can be only terminated with\n"
202 #define FUNC_NAME s_scm_debug_hang
206 return SCM_UNSPECIFIED
;
212 init_stack_limit (void)
214 #ifdef HAVE_GETRLIMIT
216 if (getrlimit (RLIMIT_STACK
, &lim
) == 0)
218 rlim_t bytes
= lim
.rlim_cur
;
220 /* set our internal stack limit to 80% of the rlimit. */
221 if (bytes
== RLIM_INFINITY
)
222 bytes
= lim
.rlim_max
;
224 if (bytes
!= RLIM_INFINITY
)
225 SCM_STACK_LIMIT
= bytes
* 8 / 10 / sizeof (scm_t_bits
);
237 scm_init_opts (scm_debug_options
, scm_debug_opts
);
239 scm_add_feature ("debug-extensions");
241 #include "libguile/debug.x"