Commit | Line | Data |
---|---|---|
68baa7e7 | 1 | /* Debugging extensions for Guile |
d062a8c1 | 2 | * Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, 2008, 2009, 2010, 2011, 2012 Free Software Foundation |
ee340120 | 3 | * |
73be1d9e | 4 | * This library is free software; you can redistribute it and/or |
53befeb7 NJ |
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. | |
ee340120 | 8 | * |
53befeb7 NJ |
9 | * This library is distributed in the hope that it will be useful, but |
10 | * WITHOUT ANY WARRANTY; without even the implied warranty of | |
73be1d9e MV |
11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
12 | * Lesser General Public License for more details. | |
ee340120 | 13 | * |
73be1d9e MV |
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 | |
53befeb7 NJ |
16 | * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA |
17 | * 02110-1301 USA | |
73be1d9e | 18 | */ |
f0e9217a | 19 | |
1bbd0b84 | 20 | |
dbb605f5 LC |
21 | #ifdef HAVE_CONFIG_H |
22 | # include <config.h> | |
23 | #endif | |
1bbd0b84 | 24 | |
ec900eac AW |
25 | #ifdef HAVE_GETRLIMIT |
26 | #include <sys/time.h> | |
27 | #include <sys/resource.h> | |
28 | #endif | |
29 | ||
a0599745 | 30 | #include "libguile/_scm.h" |
5e3545d0 | 31 | #include "libguile/async.h" |
a0599745 | 32 | #include "libguile/eval.h" |
37c56aec | 33 | #include "libguile/list.h" |
a0599745 MD |
34 | #include "libguile/stackchk.h" |
35 | #include "libguile/throw.h" | |
36 | #include "libguile/macros.h" | |
37 | #include "libguile/smob.h" | |
6c2961a0 | 38 | #include "libguile/struct.h" |
a0599745 MD |
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" | |
b06a8b87 | 50 | #include "libguile/fluids.h" |
e311f5fa | 51 | #include "libguile/programs.h" |
b7742c6b | 52 | #include "libguile/memoize.h" |
14aa25e4 | 53 | #include "libguile/vm.h" |
a0599745 MD |
54 | |
55 | #include "libguile/validate.h" | |
56 | #include "libguile/debug.h" | |
22fc179a HWN |
57 | |
58 | #include "libguile/private-options.h" | |
f0e9217a MD |
59 | \f |
60 | ||
22fc179a | 61 | |
ab9c9100 AW |
62 | /* |
63 | * Debugging options. | |
64 | */ | |
65 | ||
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. | |
76 | ||
77 | The situation is aggravated by certain compilers, which can consume | |
78 | "beaucoup de stack", as they say in France. | |
79 | ||
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. | |
83 | */ | |
84 | { SCM_OPTION_INTEGER, "stack", 160000, "Stack size limit (measured in words; 0 = no check)." }, | |
210c0325 | 85 | { SCM_OPTION_SCM, "show-file-name", SCM_BOOL_T_BITS, |
ab9c9100 AW |
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." }, | |
91 | { 0 }, | |
92 | }; | |
93 | ||
94 | ||
f0e9217a MD |
95 | /* {Run time control of the debugging evaluator} |
96 | */ | |
97 | ||
a1ec6916 | 98 | SCM_DEFINE (scm_debug_options, "debug-options-interface", 0, 1, 0, |
1bbd0b84 | 99 | (SCM setting), |
ba94f79e MG |
100 | "Option interface for the debug options. Instead of using\n" |
101 | "this procedure directly, use the procedures @code{debug-enable},\n" | |
3939e9df | 102 | "@code{debug-disable}, @code{debug-set!} and @code{debug-options}.") |
1bbd0b84 | 103 | #define FUNC_NAME s_scm_debug_options |
f0e9217a MD |
104 | { |
105 | SCM ans; | |
5e3545d0 | 106 | |
661ae7ab MV |
107 | scm_dynwind_begin (0); |
108 | scm_dynwind_critical_section (SCM_BOOL_F); | |
5e3545d0 | 109 | |
62560650 | 110 | ans = scm_options (setting, scm_debug_opts, FUNC_NAME); |
c0934652 | 111 | #ifdef STACK_CHECKING |
a6e350dd | 112 | scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P; |
c0934652 | 113 | #endif |
5e3545d0 | 114 | |
661ae7ab | 115 | scm_dynwind_end (); |
f0e9217a MD |
116 | return ans; |
117 | } | |
1bbd0b84 | 118 | #undef FUNC_NAME |
260b1416 | 119 | |
f0e9217a | 120 | \f |
85db4a2c | 121 | SCM_SYMBOL (scm_sym_source, "source"); |
f0e9217a | 122 | |
a1ec6916 | 123 | SCM_DEFINE (scm_procedure_name, "procedure-name", 1, 0, 0, |
1bbd0b84 | 124 | (SCM proc), |
ba94f79e | 125 | "Return the name of the procedure @var{proc}") |
1bbd0b84 | 126 | #define FUNC_NAME s_scm_procedure_name |
f0e9217a | 127 | { |
34d19ef6 | 128 | SCM_VALIDATE_PROC (1, proc); |
6c2961a0 AW |
129 | while (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc)) |
130 | proc = SCM_STRUCT_PROCEDURE (proc); | |
1e23b461 | 131 | return scm_procedure_property (proc, scm_sym_name); |
f0e9217a | 132 | } |
1bbd0b84 | 133 | #undef FUNC_NAME |
f0e9217a | 134 | |
a1ec6916 | 135 | SCM_DEFINE (scm_procedure_source, "procedure-source", 1, 0, 0, |
1bbd0b84 | 136 | (SCM proc), |
ba94f79e | 137 | "Return the source of the procedure @var{proc}.") |
1bbd0b84 | 138 | #define FUNC_NAME s_scm_procedure_source |
f0e9217a | 139 | { |
b7742c6b AW |
140 | SCM src; |
141 | SCM_VALIDATE_PROC (1, proc); | |
212e58ed | 142 | |
b7742c6b | 143 | do |
b3d7f6df | 144 | { |
b7742c6b | 145 | src = scm_procedure_property (proc, scm_sym_source); |
7888309b | 146 | if (scm_is_true (src)) |
b7742c6b AW |
147 | return src; |
148 | ||
149 | switch (SCM_TYP7 (proc)) { | |
150 | case scm_tcs_struct: | |
151 | if (!SCM_STRUCT_APPLICABLE_P (proc) | |
152 | || SCM_IMP (SCM_STRUCT_PROCEDURE (proc))) | |
153 | break; | |
154 | proc = SCM_STRUCT_PROCEDURE (proc); | |
155 | continue; | |
b7742c6b AW |
156 | default: |
157 | break; | |
158 | } | |
b3d7f6df | 159 | } |
b7742c6b | 160 | while (0); |
f0e9217a | 161 | |
b7742c6b | 162 | return SCM_BOOL_F; |
f0e9217a | 163 | } |
1bbd0b84 | 164 | #undef FUNC_NAME |
f0e9217a | 165 | |
4e237f14 | 166 | |
bfe3154c | 167 | \f |
f0e9217a | 168 | |
c75512d6 | 169 | #if 0 |
1bbd0b84 | 170 | SCM_REGISTER_PROC (s_reverse_lookup, "reverse-lookup", 2, 0, 0, scm_reverse_lookup); |
c75512d6 MD |
171 | #endif |
172 | ||
173 | SCM | |
174 | scm_reverse_lookup (SCM env, SCM data) | |
175 | { | |
d2e53ed6 | 176 | while (scm_is_pair (env) && scm_is_pair (SCM_CAR (env))) |
c75512d6 | 177 | { |
22a52da1 DH |
178 | SCM names = SCM_CAAR (env); |
179 | SCM values = SCM_CDAR (env); | |
d2e53ed6 | 180 | while (scm_is_pair (names)) |
c75512d6 | 181 | { |
bc36d050 | 182 | if (scm_is_eq (SCM_CAR (values), data)) |
c75512d6 MD |
183 | return SCM_CAR (names); |
184 | names = SCM_CDR (names); | |
185 | values = SCM_CDR (values); | |
186 | } | |
d2e53ed6 | 187 | if (!scm_is_null (names) && scm_is_eq (values, data)) |
c75512d6 MD |
188 | return names; |
189 | env = SCM_CDR (env); | |
190 | } | |
191 | return SCM_BOOL_F; | |
192 | } | |
193 | ||
f0e9217a MD |
194 | \f |
195 | ||
fe57f652 MD |
196 | /* Undocumented debugging procedure */ |
197 | #ifdef GUILE_DEBUG | |
a1ec6916 | 198 | SCM_DEFINE (scm_debug_hang, "debug-hang", 0, 1, 0, |
1bbd0b84 | 199 | (SCM obj), |
ba94f79e MG |
200 | "Go into an endless loop, which can be only terminated with\n" |
201 | "a debugger.") | |
1bbd0b84 | 202 | #define FUNC_NAME s_scm_debug_hang |
e38ecb05 MD |
203 | { |
204 | int go = 0; | |
205 | while (!go) ; | |
206 | return SCM_UNSPECIFIED; | |
207 | } | |
1bbd0b84 | 208 | #undef FUNC_NAME |
fe57f652 | 209 | #endif |
e38ecb05 | 210 | |
d062a8c1 AW |
211 | SCM |
212 | scm_local_eval (SCM exp, SCM env) | |
213 | { | |
f57ea23a MW |
214 | static SCM local_eval_var = SCM_UNDEFINED; |
215 | static scm_i_pthread_mutex_t local_eval_var_mutex | |
216 | = SCM_I_PTHREAD_MUTEX_INITIALIZER; | |
d062a8c1 | 217 | |
f57ea23a MW |
218 | scm_i_scm_pthread_mutex_lock (&local_eval_var_mutex); |
219 | if (SCM_UNBNDP (local_eval_var)) | |
d062a8c1 | 220 | local_eval_var = scm_c_public_variable ("ice-9 local-eval", "local-eval"); |
f57ea23a | 221 | scm_i_pthread_mutex_unlock (&local_eval_var_mutex); |
d062a8c1 AW |
222 | |
223 | return scm_call_2 (SCM_VARIABLE_REF (local_eval_var), exp, env); | |
224 | } | |
225 | ||
ec900eac AW |
226 | static void |
227 | init_stack_limit (void) | |
228 | { | |
229 | #ifdef HAVE_GETRLIMIT | |
230 | struct rlimit lim; | |
231 | if (getrlimit (RLIMIT_STACK, &lim) == 0) | |
232 | { | |
6f36dbbe | 233 | rlim_t bytes = lim.rlim_cur; |
ec900eac | 234 | |
6f36dbbe | 235 | /* set our internal stack limit to 80% of the rlimit. */ |
ec900eac AW |
236 | if (bytes == RLIM_INFINITY) |
237 | bytes = lim.rlim_max; | |
238 | ||
6f36dbbe AW |
239 | if (bytes != RLIM_INFINITY) |
240 | SCM_STACK_LIMIT = bytes * 8 / 10 / sizeof (scm_t_bits); | |
ec900eac AW |
241 | } |
242 | errno = 0; | |
243 | #endif | |
244 | } | |
245 | ||
e38ecb05 MD |
246 | \f |
247 | ||
f0e9217a MD |
248 | void |
249 | scm_init_debug () | |
250 | { | |
ec900eac | 251 | init_stack_limit (); |
62560650 | 252 | scm_init_opts (scm_debug_options, scm_debug_opts); |
ee340120 | 253 | |
f0e9217a MD |
254 | scm_add_feature ("debug-extensions"); |
255 | ||
a0599745 | 256 | #include "libguile/debug.x" |
f0e9217a | 257 | } |
89e00824 ML |
258 | |
259 | /* | |
260 | Local Variables: | |
261 | c-file-style: "gnu" | |
262 | End: | |
263 | */ |