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" |
a0599745 MD |
51 | |
52 | #include "libguile/validate.h" | |
53 | #include "libguile/debug.h" | |
22fc179a HWN |
54 | |
55 | #include "libguile/private-options.h" | |
f0e9217a MD |
56 | \f |
57 | ||
22fc179a | 58 | |
f0e9217a MD |
59 | /* {Run time control of the debugging evaluator} |
60 | */ | |
61 | ||
a1ec6916 | 62 | SCM_DEFINE (scm_debug_options, "debug-options-interface", 0, 1, 0, |
1bbd0b84 | 63 | (SCM setting), |
ba94f79e MG |
64 | "Option interface for the debug options. Instead of using\n" |
65 | "this procedure directly, use the procedures @code{debug-enable},\n" | |
3939e9df | 66 | "@code{debug-disable}, @code{debug-set!} and @code{debug-options}.") |
1bbd0b84 | 67 | #define FUNC_NAME s_scm_debug_options |
f0e9217a MD |
68 | { |
69 | SCM ans; | |
5e3545d0 | 70 | |
661ae7ab MV |
71 | scm_dynwind_begin (0); |
72 | scm_dynwind_critical_section (SCM_BOOL_F); | |
5e3545d0 | 73 | |
62560650 | 74 | ans = scm_options (setting, scm_debug_opts, FUNC_NAME); |
5e8d7fd4 | 75 | if (!(1 <= SCM_N_FRAMES && SCM_N_FRAMES <= SCM_MAX_FRAME_SIZE)) |
f0e9217a | 76 | { |
62560650 | 77 | scm_options (ans, scm_debug_opts, FUNC_NAME); |
1e76143f | 78 | SCM_OUT_OF_RANGE (1, setting); |
f0e9217a | 79 | } |
5e8d7fd4 | 80 | SCM_RESET_DEBUG_MODE; |
c0934652 | 81 | #ifdef STACK_CHECKING |
a6e350dd | 82 | scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P; |
c0934652 | 83 | #endif |
5e8d7fd4 | 84 | scm_debug_eframe_size = 2 * SCM_N_FRAMES; |
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 MD |
133 | |
134 | /* {Memoized Source} | |
135 | */ | |
136 | ||
92c2555f | 137 | scm_t_bits scm_tc16_memoized; |
1cc91f1b | 138 | |
f0e9217a | 139 | static int |
e841c3e0 | 140 | memoized_print (SCM obj, SCM port, scm_print_state *pstate) |
f0e9217a | 141 | { |
9882ea19 | 142 | int writingp = SCM_WRITINGP (pstate); |
b7f3516f | 143 | scm_puts ("#<memoized ", port); |
9882ea19 | 144 | SCM_SET_WRITINGP (pstate, 1); |
33b97402 | 145 | scm_iprin1 (SCM_MEMOIZED_EXP (obj), port, pstate); |
9882ea19 | 146 | SCM_SET_WRITINGP (pstate, writingp); |
b7f3516f | 147 | scm_putc ('>', port); |
f0e9217a MD |
148 | return 1; |
149 | } | |
150 | ||
a1ec6916 | 151 | SCM_DEFINE (scm_memoized_p, "memoized?", 1, 0, 0, |
1bbd0b84 | 152 | (SCM obj), |
ba94f79e | 153 | "Return @code{#t} if @var{obj} is memoized.") |
1bbd0b84 | 154 | #define FUNC_NAME s_scm_memoized_p |
f0e9217a | 155 | { |
7888309b | 156 | return scm_from_bool(SCM_MEMOIZEDP (obj)); |
f0e9217a | 157 | } |
1bbd0b84 | 158 | #undef FUNC_NAME |
f0e9217a | 159 | |
f0e9217a | 160 | SCM |
1bbd0b84 | 161 | scm_make_memoized (SCM exp, SCM env) |
f0e9217a | 162 | { |
6c179711 | 163 | /* *fixme* Check that env is a valid environment. */ |
d193b04b | 164 | SCM_RETURN_NEWSMOB (scm_tc16_memoized, SCM_UNPACK (scm_cons (exp, env))); |
f0e9217a MD |
165 | } |
166 | ||
33b97402 MD |
167 | #ifdef GUILE_DEBUG |
168 | /* | |
169 | * Some primitives for construction of memoized code | |
170 | * | |
171 | * - procedure: memcons CAR CDR [ENV] | |
172 | * | |
173 | * Construct a pair, encapsulated in a memoized object. | |
174 | * | |
175 | * The CAR and CDR can be either normal or memoized. If ENV isn't | |
176 | * specified, the top-level environment of the current module will | |
177 | * be assumed. All environments must match. | |
178 | * | |
33b97402 MD |
179 | * - procedure: make-iloc FRAME BINDING CDRP |
180 | * | |
181 | * Return an iloc referring to frame no. FRAME, binding | |
182 | * no. BINDING. If CDRP is non-#f, the iloc is referring to a | |
183 | * frame consisting of a single pair, with the value stored in the | |
184 | * CDR. | |
185 | * | |
186 | * - procedure: iloc? OBJECT | |
187 | * | |
188 | * Return #t if OBJECT is an iloc. | |
189 | * | |
190 | * - procedure: mem->proc MEMOIZED | |
191 | * | |
192 | * Construct a closure from the memoized lambda expression MEMOIZED | |
193 | * | |
194 | * WARNING! The code is not copied! | |
195 | * | |
196 | * - procedure: proc->mem CLOSURE | |
197 | * | |
198 | * Turn the closure CLOSURE into a memoized object. | |
199 | * | |
200 | * WARNING! The code is not copied! | |
201 | * | |
202 | * - constant: SCM_IM_AND | |
203 | * - constant: SCM_IM_BEGIN | |
204 | * - constant: SCM_IM_CASE | |
205 | * - constant: SCM_IM_COND | |
206 | * - constant: SCM_IM_DO | |
207 | * - constant: SCM_IM_IF | |
208 | * - constant: SCM_IM_LAMBDA | |
209 | * - constant: SCM_IM_LET | |
210 | * - constant: SCM_IM_LETSTAR | |
211 | * - constant: SCM_IM_LETREC | |
212 | * - constant: SCM_IM_OR | |
213 | * - constant: SCM_IM_QUOTE | |
214 | * - constant: SCM_IM_SET | |
215 | * - constant: SCM_IM_DEFINE | |
216 | * - constant: SCM_IM_APPLY | |
217 | * - constant: SCM_IM_CONT | |
bbab09f6 | 218 | * - constant: SCM_IM_DISPATCH |
33b97402 MD |
219 | */ |
220 | ||
a0599745 MD |
221 | #include "libguile/variable.h" |
222 | #include "libguile/procs.h" | |
33b97402 | 223 | |
a1ec6916 | 224 | SCM_DEFINE (scm_memcons, "memcons", 2, 1, 0, |
1bbd0b84 | 225 | (SCM car, SCM cdr, SCM env), |
ba94f79e MG |
226 | "Return a new memoized cons cell with @var{car} and @var{cdr}\n" |
227 | "as members and @var{env} as the environment.") | |
1bbd0b84 | 228 | #define FUNC_NAME s_scm_memcons |
33b97402 | 229 | { |
0c95b57d | 230 | if (SCM_MEMOIZEDP (car)) |
33b97402 MD |
231 | { |
232 | /*fixme* environments may be two different but equal top-level envs */ | |
233 | if (!SCM_UNBNDP (env) && SCM_MEMOIZED_ENV (car) != env) | |
e8e9b690 | 234 | SCM_MISC_ERROR ("environment mismatch arg1 <-> arg3", |
37c56aec | 235 | scm_list_2 (car, env)); |
33b97402 MD |
236 | else |
237 | env = SCM_MEMOIZED_ENV (car); | |
238 | car = SCM_MEMOIZED_EXP (car); | |
239 | } | |
0c95b57d | 240 | if (SCM_MEMOIZEDP (cdr)) |
33b97402 MD |
241 | { |
242 | if (!SCM_UNBNDP (env) && SCM_MEMOIZED_ENV (cdr) != env) | |
e8e9b690 | 243 | SCM_MISC_ERROR ("environment mismatch arg2 <-> arg3", |
37c56aec | 244 | scm_list_2 (cdr, env)); |
33b97402 MD |
245 | else |
246 | env = SCM_MEMOIZED_ENV (cdr); | |
247 | cdr = SCM_MEMOIZED_EXP (cdr); | |
248 | } | |
249 | if (SCM_UNBNDP (env)) | |
7e73eaee | 250 | env = scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE); |
33b97402 | 251 | else |
34d19ef6 | 252 | SCM_VALIDATE_NULLORCONS (3, env); |
33b97402 MD |
253 | return scm_make_memoized (scm_cons (car, cdr), env); |
254 | } | |
1bbd0b84 | 255 | #undef FUNC_NAME |
33b97402 | 256 | |
a1ec6916 | 257 | SCM_DEFINE (scm_mem_to_proc, "mem->proc", 1, 0, 0, |
1bbd0b84 | 258 | (SCM obj), |
9fcf3cbb | 259 | "Convert a memoized object (which must represent a body)\n" |
ba94f79e | 260 | "to a procedure.") |
1bbd0b84 | 261 | #define FUNC_NAME s_scm_mem_to_proc |
33b97402 MD |
262 | { |
263 | SCM env; | |
34d19ef6 | 264 | SCM_VALIDATE_MEMOIZED (1, obj); |
33b97402 MD |
265 | env = SCM_MEMOIZED_ENV (obj); |
266 | obj = SCM_MEMOIZED_EXP (obj); | |
9fcf3cbb | 267 | return scm_closure (obj, env); |
33b97402 | 268 | } |
1bbd0b84 | 269 | #undef FUNC_NAME |
33b97402 | 270 | |
a1ec6916 | 271 | SCM_DEFINE (scm_proc_to_mem, "proc->mem", 1, 0, 0, |
1bbd0b84 | 272 | (SCM obj), |
ba94f79e | 273 | "Convert a procedure to a memoized object.") |
1bbd0b84 | 274 | #define FUNC_NAME s_scm_proc_to_mem |
33b97402 | 275 | { |
5623a9b4 | 276 | SCM_VALIDATE_CLOSURE (1, obj); |
9fcf3cbb | 277 | return scm_make_memoized (SCM_CODE (obj), SCM_ENV (obj)); |
33b97402 | 278 | } |
1bbd0b84 | 279 | #undef FUNC_NAME |
33b97402 MD |
280 | |
281 | #endif /* GUILE_DEBUG */ | |
282 | ||
9fcf3cbb | 283 | SCM_DEFINE (scm_i_unmemoize_expr, "unmemoize-expr", 1, 0, 0, |
1bbd0b84 | 284 | (SCM m), |
ba94f79e | 285 | "Unmemoize the memoized expression @var{m},") |
9fcf3cbb | 286 | #define FUNC_NAME s_scm_i_unmemoize_expr |
f0e9217a | 287 | { |
34d19ef6 | 288 | SCM_VALIDATE_MEMOIZED (1, m); |
9fcf3cbb | 289 | return scm_i_unmemocopy_expr (SCM_MEMOIZED_EXP (m), SCM_MEMOIZED_ENV (m)); |
f0e9217a | 290 | } |
1bbd0b84 | 291 | #undef FUNC_NAME |
f0e9217a | 292 | |
a1ec6916 | 293 | SCM_DEFINE (scm_memoized_environment, "memoized-environment", 1, 0, 0, |
1bbd0b84 | 294 | (SCM m), |
ba94f79e | 295 | "Return the environment of the memoized expression @var{m}.") |
1bbd0b84 | 296 | #define FUNC_NAME s_scm_memoized_environment |
f0e9217a | 297 | { |
34d19ef6 | 298 | SCM_VALIDATE_MEMOIZED (1, m); |
bfe3154c | 299 | return SCM_MEMOIZED_ENV (m); |
f0e9217a | 300 | } |
1bbd0b84 | 301 | #undef FUNC_NAME |
f0e9217a | 302 | |
a1ec6916 | 303 | SCM_DEFINE (scm_procedure_name, "procedure-name", 1, 0, 0, |
1bbd0b84 | 304 | (SCM proc), |
ba94f79e | 305 | "Return the name of the procedure @var{proc}") |
1bbd0b84 | 306 | #define FUNC_NAME s_scm_procedure_name |
f0e9217a | 307 | { |
34d19ef6 | 308 | SCM_VALIDATE_PROC (1, proc); |
f0e9217a | 309 | switch (SCM_TYP7 (proc)) { |
a726dd9d | 310 | case scm_tcs_subrs: |
ce471ab8 | 311 | return SCM_SUBR_NAME (proc); |
a726dd9d | 312 | default: |
f0e9217a | 313 | { |
63c51b9a | 314 | SCM name = scm_procedure_property (proc, scm_sym_name); |
f0e9217a | 315 | #if 0 |
63c51b9a | 316 | /* Source property scm_sym_procname not implemented yet... */ |
f9450cdb | 317 | SCM name = scm_source_property (SCM_CAR (SCM_CLOSURE_BODY (proc)), scm_sym_procname); |
7888309b | 318 | if (scm_is_false (name)) |
63c51b9a | 319 | name = scm_procedure_property (proc, scm_sym_name); |
f0e9217a | 320 | #endif |
7888309b | 321 | if (scm_is_false (name) && SCM_CLOSUREP (proc)) |
c75512d6 | 322 | name = scm_reverse_lookup (SCM_ENV (proc), proc); |
e311f5fa AW |
323 | if (scm_is_false (name) && SCM_PROGRAM_P (proc)) |
324 | name = scm_program_name (proc); | |
f0e9217a MD |
325 | return name; |
326 | } | |
f0e9217a MD |
327 | } |
328 | } | |
1bbd0b84 | 329 | #undef FUNC_NAME |
f0e9217a | 330 | |
a1ec6916 | 331 | SCM_DEFINE (scm_procedure_source, "procedure-source", 1, 0, 0, |
1bbd0b84 | 332 | (SCM proc), |
ba94f79e | 333 | "Return the source of the procedure @var{proc}.") |
1bbd0b84 | 334 | #define FUNC_NAME s_scm_procedure_source |
f0e9217a | 335 | { |
34d19ef6 | 336 | SCM_VALIDATE_NIM (1, proc); |
b3d7f6df | 337 | again: |
f0e9217a MD |
338 | switch (SCM_TYP7 (proc)) { |
339 | case scm_tcs_closures: | |
340 | { | |
212e58ed DH |
341 | const SCM formals = SCM_CLOSURE_FORMALS (proc); |
342 | const SCM body = SCM_CLOSURE_BODY (proc); | |
343 | const SCM src = scm_source_property (body, scm_sym_copy); | |
344 | ||
7888309b | 345 | if (scm_is_true (src)) |
212e58ed DH |
346 | { |
347 | return scm_cons2 (scm_sym_lambda, formals, src); | |
348 | } | |
349 | else | |
350 | { | |
351 | const SCM env = SCM_EXTEND_ENV (formals, SCM_EOL, SCM_ENV (proc)); | |
352 | return scm_cons2 (scm_sym_lambda, | |
353 | scm_i_finite_list_copy (formals), | |
9fcf3cbb | 354 | scm_i_unmemocopy_body (body, env)); |
212e58ed | 355 | } |
f0e9217a | 356 | } |
b3d7f6df | 357 | case scm_tcs_struct: |
b6cf4d02 AW |
358 | if (!SCM_STRUCT_APPLICABLE_P (proc)) |
359 | break; | |
360 | proc = SCM_STRUCT_PROCEDURE (proc); | |
361 | if (SCM_IMP (proc)) | |
b3d7f6df MD |
362 | break; |
363 | goto procprop; | |
364 | case scm_tc7_smob: | |
365 | if (!SCM_SMOB_DESCRIPTOR (proc).apply) | |
366 | break; | |
f0e9217a | 367 | case scm_tcs_subrs: |
2fb924f6 | 368 | case scm_tc7_program: |
b3d7f6df | 369 | procprop: |
f0e9217a MD |
370 | /* It would indeed be a nice thing if we supplied source even for |
371 | built in procedures! */ | |
63c51b9a | 372 | return scm_procedure_property (proc, scm_sym_source); |
b3d7f6df MD |
373 | case scm_tc7_pws: |
374 | { | |
375 | SCM src = scm_procedure_property (proc, scm_sym_source); | |
7888309b | 376 | if (scm_is_true (src)) |
b3d7f6df MD |
377 | return src; |
378 | proc = SCM_PROCEDURE (proc); | |
379 | goto again; | |
380 | } | |
f0e9217a | 381 | default: |
b3d7f6df | 382 | ; |
f0e9217a | 383 | } |
b3d7f6df MD |
384 | SCM_WRONG_TYPE_ARG (1, proc); |
385 | return SCM_BOOL_F; /* not reached */ | |
f0e9217a | 386 | } |
1bbd0b84 | 387 | #undef FUNC_NAME |
f0e9217a | 388 | |
a1ec6916 | 389 | SCM_DEFINE (scm_procedure_environment, "procedure-environment", 1, 0, 0, |
1bbd0b84 | 390 | (SCM proc), |
ba94f79e | 391 | "Return the environment of the procedure @var{proc}.") |
1bbd0b84 | 392 | #define FUNC_NAME s_scm_procedure_environment |
f0e9217a | 393 | { |
34d19ef6 | 394 | SCM_VALIDATE_NIM (1, proc); |
f0e9217a MD |
395 | switch (SCM_TYP7 (proc)) { |
396 | case scm_tcs_closures: | |
397 | return SCM_ENV (proc); | |
f0e9217a | 398 | case scm_tcs_subrs: |
f0e9217a MD |
399 | return SCM_EOL; |
400 | default: | |
276dd677 DH |
401 | SCM_WRONG_TYPE_ARG (1, proc); |
402 | /* not reached */ | |
f0e9217a MD |
403 | } |
404 | } | |
1bbd0b84 | 405 | #undef FUNC_NAME |
f0e9217a | 406 | |
4e237f14 AW |
407 | SCM_DEFINE (scm_procedure_module, "procedure-module", 1, 0, 0, |
408 | (SCM proc), | |
69dd78d7 | 409 | "Return the module that was current when @var{proc} was defined.") |
4e237f14 AW |
410 | #define FUNC_NAME s_scm_procedure_module |
411 | { | |
412 | SCM_VALIDATE_PROC (SCM_ARG1, proc); | |
413 | ||
414 | if (scm_is_true (scm_program_p (proc))) | |
415 | return scm_program_module (proc); | |
416 | else | |
69dd78d7 | 417 | return scm_env_module (scm_procedure_environment (proc)); |
4e237f14 AW |
418 | } |
419 | #undef FUNC_NAME | |
420 | ||
421 | ||
bfe3154c | 422 | \f |
f0e9217a MD |
423 | |
424 | /* Eval in a local environment. We would like to have the ability to | |
e38ecb05 MD |
425 | * evaluate in a specified local environment, but due to the |
426 | * memoization this isn't normally possible. We solve it by copying | |
427 | * the code before evaluating. One solution would be to have eval.c | |
428 | * generate yet another evaluator. They are not very big actually. | |
f0e9217a | 429 | */ |
a1ec6916 | 430 | SCM_DEFINE (scm_local_eval, "local-eval", 1, 1, 0, |
1bbd0b84 | 431 | (SCM exp, SCM env), |
b380b885 MD |
432 | "Evaluate @var{exp} in its environment. If @var{env} is supplied,\n" |
433 | "it is the environment in which to evaluate @var{exp}. Otherwise,\n" | |
434 | "@var{exp} must be a memoized code object (in which case, its environment\n" | |
435 | "is implicit).") | |
1bbd0b84 | 436 | #define FUNC_NAME s_scm_local_eval |
f0e9217a | 437 | { |
6c179711 MD |
438 | if (SCM_UNBNDP (env)) |
439 | { | |
82b3290d MD |
440 | SCM_VALIDATE_MEMOIZED (1, exp); |
441 | return scm_i_eval_x (SCM_MEMOIZED_EXP (exp), SCM_MEMOIZED_ENV (exp)); | |
6c179711 | 442 | } |
82b3290d | 443 | return scm_i_eval (exp, env); |
f0e9217a | 444 | } |
1bbd0b84 | 445 | #undef FUNC_NAME |
f0e9217a | 446 | |
c75512d6 | 447 | #if 0 |
1bbd0b84 | 448 | SCM_REGISTER_PROC (s_reverse_lookup, "reverse-lookup", 2, 0, 0, scm_reverse_lookup); |
c75512d6 MD |
449 | #endif |
450 | ||
451 | SCM | |
452 | scm_reverse_lookup (SCM env, SCM data) | |
453 | { | |
d2e53ed6 | 454 | while (scm_is_pair (env) && scm_is_pair (SCM_CAR (env))) |
c75512d6 | 455 | { |
22a52da1 DH |
456 | SCM names = SCM_CAAR (env); |
457 | SCM values = SCM_CDAR (env); | |
d2e53ed6 | 458 | while (scm_is_pair (names)) |
c75512d6 | 459 | { |
bc36d050 | 460 | if (scm_is_eq (SCM_CAR (values), data)) |
c75512d6 MD |
461 | return SCM_CAR (names); |
462 | names = SCM_CDR (names); | |
463 | values = SCM_CDR (values); | |
464 | } | |
d2e53ed6 | 465 | if (!scm_is_null (names) && scm_is_eq (values, data)) |
c75512d6 MD |
466 | return names; |
467 | env = SCM_CDR (env); | |
468 | } | |
469 | return SCM_BOOL_F; | |
470 | } | |
471 | ||
107139ea AW |
472 | SCM_DEFINE (scm_sys_start_stack, "%start-stack", 2, 0, 0, |
473 | (SCM id, SCM thunk), | |
474 | "Call @var{thunk} on an evaluator stack tagged with @var{id}.") | |
475 | #define FUNC_NAME s_scm_sys_start_stack | |
bfe3154c MD |
476 | { |
477 | SCM answer; | |
92c2555f MV |
478 | scm_t_debug_frame vframe; |
479 | scm_t_debug_info vframe_vect_body; | |
9de87eea | 480 | vframe.prev = scm_i_last_debug_frame (); |
9fa2c7b1 MD |
481 | vframe.status = SCM_VOIDFRAME; |
482 | vframe.vect = &vframe_vect_body; | |
483 | vframe.vect[0].id = id; | |
9de87eea | 484 | scm_i_set_last_debug_frame (&vframe); |
107139ea | 485 | answer = scm_call_0 (thunk); |
9de87eea | 486 | scm_i_set_last_debug_frame (vframe.prev); |
9fa2c7b1 MD |
487 | return answer; |
488 | } | |
68baa7e7 DH |
489 | #undef FUNC_NAME |
490 | ||
f0e9217a MD |
491 | /* {Debug Objects} |
492 | * | |
493 | * The debugging evaluator throws these on frame traps. | |
494 | */ | |
495 | ||
92c2555f | 496 | scm_t_bits scm_tc16_debugobj; |
f0e9217a | 497 | |
f0e9217a | 498 | static int |
e81d98ec | 499 | debugobj_print (SCM obj, SCM port, scm_print_state *pstate SCM_UNUSED) |
f0e9217a | 500 | { |
b7f3516f | 501 | scm_puts ("#<debug-object ", port); |
37c56aec | 502 | scm_intprint ((long) SCM_DEBUGOBJ_FRAME (obj), 16, port); |
b7f3516f | 503 | scm_putc ('>', port); |
f0e9217a MD |
504 | return 1; |
505 | } | |
506 | ||
a1ec6916 | 507 | SCM_DEFINE (scm_debug_object_p, "debug-object?", 1, 0, 0, |
1bbd0b84 | 508 | (SCM obj), |
ba94f79e | 509 | "Return @code{#t} if @var{obj} is a debug object.") |
1bbd0b84 | 510 | #define FUNC_NAME s_scm_debug_object_p |
f0e9217a | 511 | { |
7888309b | 512 | return scm_from_bool(SCM_DEBUGOBJP (obj)); |
f0e9217a | 513 | } |
1bbd0b84 | 514 | #undef FUNC_NAME |
f0e9217a | 515 | |
1cc91f1b | 516 | |
f0e9217a | 517 | SCM |
92c2555f | 518 | scm_make_debugobj (scm_t_debug_frame *frame) |
f0e9217a | 519 | { |
228a24ef | 520 | return scm_cell (scm_tc16_debugobj, (scm_t_bits) frame); |
f0e9217a MD |
521 | } |
522 | ||
f0e9217a MD |
523 | \f |
524 | ||
fe57f652 MD |
525 | /* Undocumented debugging procedure */ |
526 | #ifdef GUILE_DEBUG | |
a1ec6916 | 527 | SCM_DEFINE (scm_debug_hang, "debug-hang", 0, 1, 0, |
1bbd0b84 | 528 | (SCM obj), |
ba94f79e MG |
529 | "Go into an endless loop, which can be only terminated with\n" |
530 | "a debugger.") | |
1bbd0b84 | 531 | #define FUNC_NAME s_scm_debug_hang |
e38ecb05 MD |
532 | { |
533 | int go = 0; | |
534 | while (!go) ; | |
535 | return SCM_UNSPECIFIED; | |
536 | } | |
1bbd0b84 | 537 | #undef FUNC_NAME |
fe57f652 | 538 | #endif |
e38ecb05 | 539 | |
ec900eac AW |
540 | static void |
541 | init_stack_limit (void) | |
542 | { | |
543 | #ifdef HAVE_GETRLIMIT | |
544 | struct rlimit lim; | |
545 | if (getrlimit (RLIMIT_STACK, &lim) == 0) | |
546 | { | |
6f36dbbe | 547 | rlim_t bytes = lim.rlim_cur; |
ec900eac | 548 | |
6f36dbbe | 549 | /* set our internal stack limit to 80% of the rlimit. */ |
ec900eac AW |
550 | if (bytes == RLIM_INFINITY) |
551 | bytes = lim.rlim_max; | |
552 | ||
6f36dbbe AW |
553 | if (bytes != RLIM_INFINITY) |
554 | SCM_STACK_LIMIT = bytes * 8 / 10 / sizeof (scm_t_bits); | |
ec900eac AW |
555 | } |
556 | errno = 0; | |
557 | #endif | |
558 | } | |
559 | ||
e38ecb05 MD |
560 | \f |
561 | ||
f0e9217a MD |
562 | void |
563 | scm_init_debug () | |
564 | { | |
ec900eac | 565 | init_stack_limit (); |
62560650 | 566 | scm_init_opts (scm_debug_options, scm_debug_opts); |
ee340120 | 567 | |
e841c3e0 | 568 | scm_tc16_memoized = scm_make_smob_type ("memoized", 0); |
e841c3e0 | 569 | scm_set_smob_print (scm_tc16_memoized, memoized_print); |
23a62151 | 570 | |
e841c3e0 KN |
571 | scm_tc16_debugobj = scm_make_smob_type ("debug-object", 0); |
572 | scm_set_smob_print (scm_tc16_debugobj, debugobj_print); | |
f0e9217a | 573 | |
33b97402 | 574 | #ifdef GUILE_DEBUG |
1be6b49c ML |
575 | scm_c_define ("SCM_IM_AND", SCM_IM_AND); |
576 | scm_c_define ("SCM_IM_BEGIN", SCM_IM_BEGIN); | |
577 | scm_c_define ("SCM_IM_CASE", SCM_IM_CASE); | |
578 | scm_c_define ("SCM_IM_COND", SCM_IM_COND); | |
579 | scm_c_define ("SCM_IM_DO", SCM_IM_DO); | |
580 | scm_c_define ("SCM_IM_IF", SCM_IM_IF); | |
581 | scm_c_define ("SCM_IM_LAMBDA", SCM_IM_LAMBDA); | |
582 | scm_c_define ("SCM_IM_LET", SCM_IM_LET); | |
583 | scm_c_define ("SCM_IM_LETSTAR", SCM_IM_LETSTAR); | |
584 | scm_c_define ("SCM_IM_LETREC", SCM_IM_LETREC); | |
585 | scm_c_define ("SCM_IM_OR", SCM_IM_OR); | |
586 | scm_c_define ("SCM_IM_QUOTE", SCM_IM_QUOTE); | |
587 | scm_c_define ("SCM_IM_SET_X", SCM_IM_SET_X); | |
588 | scm_c_define ("SCM_IM_DEFINE", SCM_IM_DEFINE); | |
589 | scm_c_define ("SCM_IM_APPLY", SCM_IM_APPLY); | |
590 | scm_c_define ("SCM_IM_CONT", SCM_IM_CONT); | |
591 | scm_c_define ("SCM_IM_DISPATCH", SCM_IM_DISPATCH); | |
33b97402 | 592 | #endif |
f0e9217a MD |
593 | scm_add_feature ("debug-extensions"); |
594 | ||
a0599745 | 595 | #include "libguile/debug.x" |
f0e9217a | 596 | } |
89e00824 ML |
597 | |
598 | /* | |
599 | Local Variables: | |
600 | c-file-style: "gnu" | |
601 | End: | |
602 | */ |