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