Commit | Line | Data |
---|---|---|
68baa7e7 | 1 | /* Debugging extensions for Guile |
e20d7001 | 2 | * Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, 2008, 2009 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" | |
38 | #include "libguile/procprop.h" | |
39 | #include "libguile/srcprop.h" | |
40 | #include "libguile/alist.h" | |
41 | #include "libguile/continuations.h" | |
42 | #include "libguile/strports.h" | |
43 | #include "libguile/read.h" | |
44 | #include "libguile/feature.h" | |
45 | #include "libguile/dynwind.h" | |
46 | #include "libguile/modules.h" | |
47 | #include "libguile/ports.h" | |
48 | #include "libguile/root.h" | |
b06a8b87 | 49 | #include "libguile/fluids.h" |
e311f5fa | 50 | #include "libguile/programs.h" |
b7742c6b | 51 | #include "libguile/memoize.h" |
14aa25e4 | 52 | #include "libguile/vm.h" |
a0599745 MD |
53 | |
54 | #include "libguile/validate.h" | |
55 | #include "libguile/debug.h" | |
22fc179a HWN |
56 | |
57 | #include "libguile/private-options.h" | |
f0e9217a MD |
58 | \f |
59 | ||
22fc179a | 60 | |
f0e9217a MD |
61 | /* {Run time control of the debugging evaluator} |
62 | */ | |
63 | ||
a1ec6916 | 64 | SCM_DEFINE (scm_debug_options, "debug-options-interface", 0, 1, 0, |
1bbd0b84 | 65 | (SCM setting), |
ba94f79e MG |
66 | "Option interface for the debug options. Instead of using\n" |
67 | "this procedure directly, use the procedures @code{debug-enable},\n" | |
3939e9df | 68 | "@code{debug-disable}, @code{debug-set!} and @code{debug-options}.") |
1bbd0b84 | 69 | #define FUNC_NAME s_scm_debug_options |
f0e9217a MD |
70 | { |
71 | SCM ans; | |
5e3545d0 | 72 | |
661ae7ab MV |
73 | scm_dynwind_begin (0); |
74 | scm_dynwind_critical_section (SCM_BOOL_F); | |
5e3545d0 | 75 | |
62560650 | 76 | ans = scm_options (setting, scm_debug_opts, FUNC_NAME); |
14aa25e4 | 77 | if (SCM_N_FRAMES < 1) |
f0e9217a | 78 | { |
62560650 | 79 | scm_options (ans, scm_debug_opts, FUNC_NAME); |
1e76143f | 80 | SCM_OUT_OF_RANGE (1, setting); |
f0e9217a | 81 | } |
c0934652 | 82 | #ifdef STACK_CHECKING |
a6e350dd | 83 | scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P; |
c0934652 | 84 | #endif |
5e3545d0 | 85 | |
661ae7ab | 86 | scm_dynwind_end (); |
f0e9217a MD |
87 | return ans; |
88 | } | |
1bbd0b84 | 89 | #undef FUNC_NAME |
260b1416 | 90 | |
22fc179a | 91 | |
260b1416 MD |
92 | static void |
93 | with_traps_before (void *data) | |
94 | { | |
95 | int *trap_flag = data; | |
96 | *trap_flag = SCM_TRAPS_P; | |
97 | SCM_TRAPS_P = 1; | |
98 | } | |
99 | ||
100 | static void | |
101 | with_traps_after (void *data) | |
102 | { | |
103 | int *trap_flag = data; | |
104 | SCM_TRAPS_P = *trap_flag; | |
105 | } | |
106 | ||
107 | static SCM | |
108 | with_traps_inner (void *data) | |
109 | { | |
702551e6 | 110 | SCM thunk = SCM_PACK ((scm_t_bits) data); |
fdc28395 | 111 | return scm_call_0 (thunk); |
260b1416 | 112 | } |
1cc91f1b | 113 | |
a1ec6916 | 114 | SCM_DEFINE (scm_with_traps, "with-traps", 1, 0, 0, |
1bbd0b84 | 115 | (SCM thunk), |
ba94f79e | 116 | "Call @var{thunk} with traps enabled.") |
1bbd0b84 | 117 | #define FUNC_NAME s_scm_with_traps |
f0e9217a | 118 | { |
260b1416 | 119 | int trap_flag; |
34d19ef6 | 120 | SCM_VALIDATE_THUNK (1, thunk); |
260b1416 MD |
121 | return scm_internal_dynamic_wind (with_traps_before, |
122 | with_traps_inner, | |
123 | with_traps_after, | |
451e591c | 124 | (void *) SCM_UNPACK (thunk), |
260b1416 | 125 | &trap_flag); |
f0e9217a | 126 | } |
1bbd0b84 | 127 | #undef FUNC_NAME |
f0e9217a MD |
128 | |
129 | \f | |
85db4a2c DH |
130 | SCM_SYMBOL (scm_sym_procname, "procname"); |
131 | SCM_SYMBOL (scm_sym_dots, "..."); | |
132 | SCM_SYMBOL (scm_sym_source, "source"); | |
f0e9217a | 133 | |
a1ec6916 | 134 | SCM_DEFINE (scm_procedure_name, "procedure-name", 1, 0, 0, |
1bbd0b84 | 135 | (SCM proc), |
ba94f79e | 136 | "Return the name of the procedure @var{proc}") |
1bbd0b84 | 137 | #define FUNC_NAME s_scm_procedure_name |
f0e9217a | 138 | { |
34d19ef6 | 139 | SCM_VALIDATE_PROC (1, proc); |
f0e9217a | 140 | switch (SCM_TYP7 (proc)) { |
f36878ba | 141 | case scm_tc7_gsubr: |
ce471ab8 | 142 | return SCM_SUBR_NAME (proc); |
a726dd9d | 143 | default: |
f0e9217a | 144 | { |
63c51b9a | 145 | SCM name = scm_procedure_property (proc, scm_sym_name); |
e311f5fa AW |
146 | if (scm_is_false (name) && SCM_PROGRAM_P (proc)) |
147 | name = scm_program_name (proc); | |
f0e9217a MD |
148 | return name; |
149 | } | |
f0e9217a MD |
150 | } |
151 | } | |
1bbd0b84 | 152 | #undef FUNC_NAME |
f0e9217a | 153 | |
a1ec6916 | 154 | SCM_DEFINE (scm_procedure_source, "procedure-source", 1, 0, 0, |
1bbd0b84 | 155 | (SCM proc), |
ba94f79e | 156 | "Return the source of the procedure @var{proc}.") |
1bbd0b84 | 157 | #define FUNC_NAME s_scm_procedure_source |
f0e9217a | 158 | { |
b7742c6b AW |
159 | SCM src; |
160 | SCM_VALIDATE_PROC (1, proc); | |
212e58ed | 161 | |
b7742c6b | 162 | do |
b3d7f6df | 163 | { |
b7742c6b | 164 | src = scm_procedure_property (proc, scm_sym_source); |
7888309b | 165 | if (scm_is_true (src)) |
b7742c6b AW |
166 | return src; |
167 | ||
168 | switch (SCM_TYP7 (proc)) { | |
169 | case scm_tcs_struct: | |
170 | if (!SCM_STRUCT_APPLICABLE_P (proc) | |
171 | || SCM_IMP (SCM_STRUCT_PROCEDURE (proc))) | |
172 | break; | |
173 | proc = SCM_STRUCT_PROCEDURE (proc); | |
174 | continue; | |
b7742c6b AW |
175 | default: |
176 | break; | |
177 | } | |
b3d7f6df | 178 | } |
b7742c6b | 179 | while (0); |
f0e9217a | 180 | |
b7742c6b | 181 | return SCM_BOOL_F; |
f0e9217a | 182 | } |
1bbd0b84 | 183 | #undef FUNC_NAME |
f0e9217a | 184 | |
4e237f14 | 185 | |
bfe3154c | 186 | \f |
f0e9217a | 187 | |
c75512d6 | 188 | #if 0 |
1bbd0b84 | 189 | SCM_REGISTER_PROC (s_reverse_lookup, "reverse-lookup", 2, 0, 0, scm_reverse_lookup); |
c75512d6 MD |
190 | #endif |
191 | ||
192 | SCM | |
193 | scm_reverse_lookup (SCM env, SCM data) | |
194 | { | |
d2e53ed6 | 195 | while (scm_is_pair (env) && scm_is_pair (SCM_CAR (env))) |
c75512d6 | 196 | { |
22a52da1 DH |
197 | SCM names = SCM_CAAR (env); |
198 | SCM values = SCM_CDAR (env); | |
d2e53ed6 | 199 | while (scm_is_pair (names)) |
c75512d6 | 200 | { |
bc36d050 | 201 | if (scm_is_eq (SCM_CAR (values), data)) |
c75512d6 MD |
202 | return SCM_CAR (names); |
203 | names = SCM_CDR (names); | |
204 | values = SCM_CDR (values); | |
205 | } | |
d2e53ed6 | 206 | if (!scm_is_null (names) && scm_is_eq (values, data)) |
c75512d6 MD |
207 | return names; |
208 | env = SCM_CDR (env); | |
209 | } | |
210 | return SCM_BOOL_F; | |
211 | } | |
212 | ||
107139ea AW |
213 | SCM_DEFINE (scm_sys_start_stack, "%start-stack", 2, 0, 0, |
214 | (SCM id, SCM thunk), | |
215 | "Call @var{thunk} on an evaluator stack tagged with @var{id}.") | |
216 | #define FUNC_NAME s_scm_sys_start_stack | |
bfe3154c | 217 | { |
14aa25e4 | 218 | return scm_vm_call_with_new_stack (scm_the_vm (), thunk, id); |
9fa2c7b1 | 219 | } |
68baa7e7 DH |
220 | #undef FUNC_NAME |
221 | ||
f0e9217a MD |
222 | \f |
223 | ||
fe57f652 MD |
224 | /* Undocumented debugging procedure */ |
225 | #ifdef GUILE_DEBUG | |
a1ec6916 | 226 | SCM_DEFINE (scm_debug_hang, "debug-hang", 0, 1, 0, |
1bbd0b84 | 227 | (SCM obj), |
ba94f79e MG |
228 | "Go into an endless loop, which can be only terminated with\n" |
229 | "a debugger.") | |
1bbd0b84 | 230 | #define FUNC_NAME s_scm_debug_hang |
e38ecb05 MD |
231 | { |
232 | int go = 0; | |
233 | while (!go) ; | |
234 | return SCM_UNSPECIFIED; | |
235 | } | |
1bbd0b84 | 236 | #undef FUNC_NAME |
fe57f652 | 237 | #endif |
e38ecb05 | 238 | |
ec900eac AW |
239 | static void |
240 | init_stack_limit (void) | |
241 | { | |
242 | #ifdef HAVE_GETRLIMIT | |
243 | struct rlimit lim; | |
244 | if (getrlimit (RLIMIT_STACK, &lim) == 0) | |
245 | { | |
6f36dbbe | 246 | rlim_t bytes = lim.rlim_cur; |
ec900eac | 247 | |
6f36dbbe | 248 | /* set our internal stack limit to 80% of the rlimit. */ |
ec900eac AW |
249 | if (bytes == RLIM_INFINITY) |
250 | bytes = lim.rlim_max; | |
251 | ||
6f36dbbe AW |
252 | if (bytes != RLIM_INFINITY) |
253 | SCM_STACK_LIMIT = bytes * 8 / 10 / sizeof (scm_t_bits); | |
ec900eac AW |
254 | } |
255 | errno = 0; | |
256 | #endif | |
257 | } | |
258 | ||
e38ecb05 MD |
259 | \f |
260 | ||
f0e9217a MD |
261 | void |
262 | scm_init_debug () | |
263 | { | |
ec900eac | 264 | init_stack_limit (); |
62560650 | 265 | scm_init_opts (scm_debug_options, scm_debug_opts); |
ee340120 | 266 | |
f0e9217a MD |
267 | scm_add_feature ("debug-extensions"); |
268 | ||
a0599745 | 269 | #include "libguile/debug.x" |
f0e9217a | 270 | } |
89e00824 ML |
271 | |
272 | /* | |
273 | Local Variables: | |
274 | c-file-style: "gnu" | |
275 | End: | |
276 | */ |