Commit | Line | Data |
---|---|---|
68baa7e7 DH |
1 | /* Debugging extensions for Guile |
2 | * Copyright (C) 1995,1996,1997,1998,1999,2000,2001 Free Software Foundation | |
ee340120 MD |
3 | * |
4 | * This program is free software; you can redistribute it and/or modify | |
5 | * it under the terms of the GNU General Public License as published by | |
6 | * the Free Software Foundation; either version 2, or (at your option) | |
7 | * any later version. | |
8 | * | |
9 | * This program is distributed in the hope that it will be useful, | |
10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of | |
11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
12 | * GNU General Public License for more details. | |
13 | * | |
14 | * You should have received a copy of the GNU General Public License | |
15 | * along with this software; see the file COPYING. If not, write to | |
82892bed JB |
16 | * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, |
17 | * Boston, MA 02111-1307 USA | |
ee340120 MD |
18 | * |
19 | * As a special exception, the Free Software Foundation gives permission | |
20 | * for additional uses of the text contained in its release of GUILE. | |
21 | * | |
22 | * The exception is that, if you link the GUILE library with other files | |
23 | * to produce an executable, this does not by itself cause the | |
24 | * resulting executable to be covered by the GNU General Public License. | |
25 | * Your use of that executable is in no way restricted on account of | |
26 | * linking the GUILE library code into it. | |
27 | * | |
28 | * This exception does not however invalidate any other reasons why | |
29 | * the executable file might be covered by the GNU General Public License. | |
30 | * | |
31 | * This exception applies only to the code released by the | |
32 | * Free Software Foundation under the name GUILE. If you copy | |
33 | * code from other Free Software Foundation releases into a copy of | |
34 | * GUILE, as the General Public License permits, the exception does | |
35 | * not apply to the code that you add in this way. To avoid misleading | |
36 | * anyone as to the status of such modified files, you must delete | |
37 | * this exception notice from them. | |
38 | * | |
39 | * If you write modifications of your own for GUILE, it is your choice | |
40 | * whether to permit this exception to apply to your modifications. | |
41 | * If you do not wish that, delete this exception notice. | |
42 | * | |
43 | * The author can be reached at djurfeldt@nada.kth.se | |
82892bed | 44 | * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN */ |
f0e9217a | 45 | |
1bbd0b84 GB |
46 | |
47 | ||
a0599745 MD |
48 | #include "libguile/_scm.h" |
49 | #include "libguile/eval.h" | |
37c56aec | 50 | #include "libguile/list.h" |
a0599745 MD |
51 | #include "libguile/stackchk.h" |
52 | #include "libguile/throw.h" | |
53 | #include "libguile/macros.h" | |
54 | #include "libguile/smob.h" | |
55 | #include "libguile/procprop.h" | |
56 | #include "libguile/srcprop.h" | |
57 | #include "libguile/alist.h" | |
58 | #include "libguile/continuations.h" | |
59 | #include "libguile/strports.h" | |
60 | #include "libguile/read.h" | |
61 | #include "libguile/feature.h" | |
62 | #include "libguile/dynwind.h" | |
63 | #include "libguile/modules.h" | |
64 | #include "libguile/ports.h" | |
65 | #include "libguile/root.h" | |
b06a8b87 | 66 | #include "libguile/fluids.h" |
a0599745 MD |
67 | |
68 | #include "libguile/validate.h" | |
69 | #include "libguile/debug.h" | |
f0e9217a MD |
70 | \f |
71 | ||
72 | /* {Run time control of the debugging evaluator} | |
73 | */ | |
74 | ||
a1ec6916 | 75 | SCM_DEFINE (scm_debug_options, "debug-options-interface", 0, 1, 0, |
1bbd0b84 | 76 | (SCM setting), |
ba94f79e MG |
77 | "Option interface for the debug options. Instead of using\n" |
78 | "this procedure directly, use the procedures @code{debug-enable},\n" | |
79 | "@code{debug-disable}, @code{debug-set!} and @var{debug-options}.") | |
1bbd0b84 | 80 | #define FUNC_NAME s_scm_debug_options |
f0e9217a MD |
81 | { |
82 | SCM ans; | |
83 | SCM_DEFER_INTS; | |
5e8d7fd4 MD |
84 | ans = scm_options (setting, |
85 | scm_debug_opts, | |
86 | SCM_N_DEBUG_OPTIONS, | |
1bbd0b84 | 87 | FUNC_NAME); |
f0e9217a | 88 | #ifndef SCM_RECKLESS |
5e8d7fd4 | 89 | if (!(1 <= SCM_N_FRAMES && SCM_N_FRAMES <= SCM_MAX_FRAME_SIZE)) |
f0e9217a | 90 | { |
1bbd0b84 | 91 | scm_options (ans, scm_debug_opts, SCM_N_DEBUG_OPTIONS, FUNC_NAME); |
1e76143f | 92 | SCM_OUT_OF_RANGE (1, setting); |
f0e9217a MD |
93 | } |
94 | #endif | |
5e8d7fd4 | 95 | SCM_RESET_DEBUG_MODE; |
a6e350dd | 96 | scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P; |
5e8d7fd4 | 97 | scm_debug_eframe_size = 2 * SCM_N_FRAMES; |
bfc69694 | 98 | SCM_ALLOW_INTS; |
f0e9217a MD |
99 | return ans; |
100 | } | |
1bbd0b84 | 101 | #undef FUNC_NAME |
260b1416 MD |
102 | |
103 | static void | |
104 | with_traps_before (void *data) | |
105 | { | |
106 | int *trap_flag = data; | |
107 | *trap_flag = SCM_TRAPS_P; | |
108 | SCM_TRAPS_P = 1; | |
109 | } | |
110 | ||
111 | static void | |
112 | with_traps_after (void *data) | |
113 | { | |
114 | int *trap_flag = data; | |
115 | SCM_TRAPS_P = *trap_flag; | |
116 | } | |
117 | ||
118 | static SCM | |
119 | with_traps_inner (void *data) | |
120 | { | |
451e591c | 121 | SCM thunk = SCM_PACK (data); |
fdc28395 | 122 | return scm_call_0 (thunk); |
260b1416 | 123 | } |
1cc91f1b | 124 | |
a1ec6916 | 125 | SCM_DEFINE (scm_with_traps, "with-traps", 1, 0, 0, |
1bbd0b84 | 126 | (SCM thunk), |
ba94f79e | 127 | "Call @var{thunk} with traps enabled.") |
1bbd0b84 | 128 | #define FUNC_NAME s_scm_with_traps |
f0e9217a | 129 | { |
260b1416 | 130 | int trap_flag; |
3b3b36dd | 131 | SCM_VALIDATE_THUNK (1,thunk); |
260b1416 MD |
132 | return scm_internal_dynamic_wind (with_traps_before, |
133 | with_traps_inner, | |
134 | with_traps_after, | |
451e591c | 135 | (void *) SCM_UNPACK (thunk), |
260b1416 | 136 | &trap_flag); |
f0e9217a | 137 | } |
1bbd0b84 | 138 | #undef FUNC_NAME |
f0e9217a MD |
139 | |
140 | \f | |
85db4a2c DH |
141 | |
142 | SCM_SYMBOL (scm_sym_procname, "procname"); | |
143 | SCM_SYMBOL (scm_sym_dots, "..."); | |
144 | SCM_SYMBOL (scm_sym_source, "source"); | |
f0e9217a MD |
145 | |
146 | /* {Memoized Source} | |
147 | */ | |
148 | ||
92c2555f | 149 | scm_t_bits scm_tc16_memoized; |
1cc91f1b | 150 | |
f0e9217a | 151 | static int |
e841c3e0 | 152 | memoized_print (SCM obj, SCM port, scm_print_state *pstate) |
f0e9217a | 153 | { |
9882ea19 | 154 | int writingp = SCM_WRITINGP (pstate); |
b7f3516f | 155 | scm_puts ("#<memoized ", port); |
9882ea19 | 156 | SCM_SET_WRITINGP (pstate, 1); |
33b97402 MD |
157 | #ifdef GUILE_DEBUG |
158 | scm_iprin1 (SCM_MEMOIZED_EXP (obj), port, pstate); | |
159 | #else | |
9882ea19 | 160 | scm_iprin1 (scm_unmemoize (obj), port, pstate); |
33b97402 | 161 | #endif |
9882ea19 | 162 | SCM_SET_WRITINGP (pstate, writingp); |
b7f3516f | 163 | scm_putc ('>', port); |
f0e9217a MD |
164 | return 1; |
165 | } | |
166 | ||
a1ec6916 | 167 | SCM_DEFINE (scm_memoized_p, "memoized?", 1, 0, 0, |
1bbd0b84 | 168 | (SCM obj), |
ba94f79e | 169 | "Return @code{#t} if @var{obj} is memoized.") |
1bbd0b84 | 170 | #define FUNC_NAME s_scm_memoized_p |
f0e9217a | 171 | { |
0c95b57d | 172 | return SCM_BOOL(SCM_MEMOIZEDP (obj)); |
f0e9217a | 173 | } |
1bbd0b84 | 174 | #undef FUNC_NAME |
f0e9217a | 175 | |
f0e9217a | 176 | SCM |
1bbd0b84 | 177 | scm_make_memoized (SCM exp, SCM env) |
f0e9217a | 178 | { |
6c179711 | 179 | /* *fixme* Check that env is a valid environment. */ |
f0e9217a | 180 | register SCM z, ans; |
f83e2737 | 181 | SCM_ENTER_A_SECTION; |
cffcab30 DH |
182 | SCM_NEWSMOB (z, SCM_UNPACK (exp), SCM_UNPACK (env)); |
183 | SCM_NEWSMOB (ans, scm_tc16_memoized, SCM_UNPACK (z)); | |
f83e2737 | 184 | SCM_EXIT_A_SECTION; |
f0e9217a MD |
185 | return ans; |
186 | } | |
187 | ||
33b97402 MD |
188 | #ifdef GUILE_DEBUG |
189 | /* | |
190 | * Some primitives for construction of memoized code | |
191 | * | |
192 | * - procedure: memcons CAR CDR [ENV] | |
193 | * | |
194 | * Construct a pair, encapsulated in a memoized object. | |
195 | * | |
196 | * The CAR and CDR can be either normal or memoized. If ENV isn't | |
197 | * specified, the top-level environment of the current module will | |
198 | * be assumed. All environments must match. | |
199 | * | |
33b97402 MD |
200 | * - procedure: make-iloc FRAME BINDING CDRP |
201 | * | |
202 | * Return an iloc referring to frame no. FRAME, binding | |
203 | * no. BINDING. If CDRP is non-#f, the iloc is referring to a | |
204 | * frame consisting of a single pair, with the value stored in the | |
205 | * CDR. | |
206 | * | |
207 | * - procedure: iloc? OBJECT | |
208 | * | |
209 | * Return #t if OBJECT is an iloc. | |
210 | * | |
211 | * - procedure: mem->proc MEMOIZED | |
212 | * | |
213 | * Construct a closure from the memoized lambda expression MEMOIZED | |
214 | * | |
215 | * WARNING! The code is not copied! | |
216 | * | |
217 | * - procedure: proc->mem CLOSURE | |
218 | * | |
219 | * Turn the closure CLOSURE into a memoized object. | |
220 | * | |
221 | * WARNING! The code is not copied! | |
222 | * | |
223 | * - constant: SCM_IM_AND | |
224 | * - constant: SCM_IM_BEGIN | |
225 | * - constant: SCM_IM_CASE | |
226 | * - constant: SCM_IM_COND | |
227 | * - constant: SCM_IM_DO | |
228 | * - constant: SCM_IM_IF | |
229 | * - constant: SCM_IM_LAMBDA | |
230 | * - constant: SCM_IM_LET | |
231 | * - constant: SCM_IM_LETSTAR | |
232 | * - constant: SCM_IM_LETREC | |
233 | * - constant: SCM_IM_OR | |
234 | * - constant: SCM_IM_QUOTE | |
235 | * - constant: SCM_IM_SET | |
236 | * - constant: SCM_IM_DEFINE | |
237 | * - constant: SCM_IM_APPLY | |
238 | * - constant: SCM_IM_CONT | |
bbab09f6 | 239 | * - constant: SCM_IM_DISPATCH |
33b97402 MD |
240 | */ |
241 | ||
a0599745 MD |
242 | #include "libguile/variable.h" |
243 | #include "libguile/procs.h" | |
33b97402 | 244 | |
a1ec6916 | 245 | SCM_DEFINE (scm_make_iloc, "make-iloc", 3, 0, 0, |
1bbd0b84 | 246 | (SCM frame, SCM binding, SCM cdrp), |
ba94f79e MG |
247 | "Return a new iloc with frame offset @var{frame}, binding\n" |
248 | "offset @var{binding} and the cdr flag @var{cdrp}.") | |
1bbd0b84 | 249 | #define FUNC_NAME s_scm_make_iloc |
33b97402 | 250 | { |
3b3b36dd GB |
251 | SCM_VALIDATE_INUM (1,frame); |
252 | SCM_VALIDATE_INUM (2,binding); | |
dd85ce47 ML |
253 | return SCM_PACK (SCM_UNPACK (SCM_ILOC00) |
254 | + SCM_IFRINC * SCM_INUM (frame) | |
37c56aec | 255 | + (!SCM_FALSEP (cdrp) ? SCM_ICDR : 0) |
dd85ce47 | 256 | + SCM_IDINC * SCM_INUM (binding)); |
33b97402 | 257 | } |
1bbd0b84 | 258 | #undef FUNC_NAME |
33b97402 | 259 | |
a1ec6916 | 260 | SCM_DEFINE (scm_iloc_p, "iloc?", 1, 0, 0, |
1bbd0b84 | 261 | (SCM obj), |
ba94f79e | 262 | "Return @code{#t} if @var{obj} is an iloc.") |
0f981281 | 263 | #define FUNC_NAME s_scm_iloc_p |
33b97402 | 264 | { |
1bbd0b84 | 265 | return SCM_BOOL(SCM_ILOCP (obj)); |
33b97402 | 266 | } |
1bbd0b84 | 267 | #undef FUNC_NAME |
33b97402 | 268 | |
a1ec6916 | 269 | SCM_DEFINE (scm_memcons, "memcons", 2, 1, 0, |
1bbd0b84 | 270 | (SCM car, SCM cdr, SCM env), |
ba94f79e MG |
271 | "Return a new memoized cons cell with @var{car} and @var{cdr}\n" |
272 | "as members and @var{env} as the environment.") | |
1bbd0b84 | 273 | #define FUNC_NAME s_scm_memcons |
33b97402 | 274 | { |
0c95b57d | 275 | if (SCM_MEMOIZEDP (car)) |
33b97402 MD |
276 | { |
277 | /*fixme* environments may be two different but equal top-level envs */ | |
278 | if (!SCM_UNBNDP (env) && SCM_MEMOIZED_ENV (car) != env) | |
e8e9b690 | 279 | SCM_MISC_ERROR ("environment mismatch arg1 <-> arg3", |
37c56aec | 280 | scm_list_2 (car, env)); |
33b97402 MD |
281 | else |
282 | env = SCM_MEMOIZED_ENV (car); | |
283 | car = SCM_MEMOIZED_EXP (car); | |
284 | } | |
0c95b57d | 285 | if (SCM_MEMOIZEDP (cdr)) |
33b97402 MD |
286 | { |
287 | if (!SCM_UNBNDP (env) && SCM_MEMOIZED_ENV (cdr) != env) | |
e8e9b690 | 288 | SCM_MISC_ERROR ("environment mismatch arg2 <-> arg3", |
37c56aec | 289 | scm_list_2 (cdr, env)); |
33b97402 MD |
290 | else |
291 | env = SCM_MEMOIZED_ENV (cdr); | |
292 | cdr = SCM_MEMOIZED_EXP (cdr); | |
293 | } | |
294 | if (SCM_UNBNDP (env)) | |
7e73eaee | 295 | env = scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE); |
33b97402 | 296 | else |
3b3b36dd | 297 | SCM_VALIDATE_NULLORCONS (3,env); |
33b97402 MD |
298 | return scm_make_memoized (scm_cons (car, cdr), env); |
299 | } | |
1bbd0b84 | 300 | #undef FUNC_NAME |
33b97402 | 301 | |
a1ec6916 | 302 | SCM_DEFINE (scm_mem_to_proc, "mem->proc", 1, 0, 0, |
1bbd0b84 | 303 | (SCM obj), |
ba94f79e MG |
304 | "Convert a memoized object (which must be a lambda expression)\n" |
305 | "to a procedure.") | |
1bbd0b84 | 306 | #define FUNC_NAME s_scm_mem_to_proc |
33b97402 MD |
307 | { |
308 | SCM env; | |
3b3b36dd | 309 | SCM_VALIDATE_MEMOIZED (1,obj); |
33b97402 MD |
310 | env = SCM_MEMOIZED_ENV (obj); |
311 | obj = SCM_MEMOIZED_EXP (obj); | |
aa5e5d63 | 312 | if (!SCM_CONSP (obj) || !SCM_EQ_P (SCM_CAR (obj), SCM_IM_LAMBDA)) |
37c56aec | 313 | SCM_MISC_ERROR ("expected lambda expression", scm_list_1 (obj)); |
33b97402 MD |
314 | return scm_closure (SCM_CDR (obj), env); |
315 | } | |
1bbd0b84 | 316 | #undef FUNC_NAME |
33b97402 | 317 | |
a1ec6916 | 318 | SCM_DEFINE (scm_proc_to_mem, "proc->mem", 1, 0, 0, |
1bbd0b84 | 319 | (SCM obj), |
ba94f79e | 320 | "Convert a procedure to a memoized object.") |
1bbd0b84 | 321 | #define FUNC_NAME s_scm_proc_to_mem |
33b97402 | 322 | { |
5623a9b4 | 323 | SCM_VALIDATE_CLOSURE (1, obj); |
33b97402 MD |
324 | return scm_make_memoized (scm_cons (SCM_IM_LAMBDA, SCM_CODE (obj)), |
325 | SCM_ENV (obj)); | |
326 | } | |
1bbd0b84 | 327 | #undef FUNC_NAME |
33b97402 MD |
328 | |
329 | #endif /* GUILE_DEBUG */ | |
330 | ||
a1ec6916 | 331 | SCM_DEFINE (scm_unmemoize, "unmemoize", 1, 0, 0, |
1bbd0b84 | 332 | (SCM m), |
ba94f79e | 333 | "Unmemoize the memoized expression @var{m},") |
1bbd0b84 | 334 | #define FUNC_NAME s_scm_unmemoize |
f0e9217a | 335 | { |
3b3b36dd | 336 | SCM_VALIDATE_MEMOIZED (1,m); |
bfe3154c | 337 | return scm_unmemocopy (SCM_MEMOIZED_EXP (m), SCM_MEMOIZED_ENV (m)); |
f0e9217a | 338 | } |
1bbd0b84 | 339 | #undef FUNC_NAME |
f0e9217a | 340 | |
a1ec6916 | 341 | SCM_DEFINE (scm_memoized_environment, "memoized-environment", 1, 0, 0, |
1bbd0b84 | 342 | (SCM m), |
ba94f79e | 343 | "Return the environment of the memoized expression @var{m}.") |
1bbd0b84 | 344 | #define FUNC_NAME s_scm_memoized_environment |
f0e9217a | 345 | { |
3b3b36dd | 346 | SCM_VALIDATE_MEMOIZED (1,m); |
bfe3154c | 347 | return SCM_MEMOIZED_ENV (m); |
f0e9217a | 348 | } |
1bbd0b84 | 349 | #undef FUNC_NAME |
f0e9217a | 350 | |
a1ec6916 | 351 | SCM_DEFINE (scm_procedure_name, "procedure-name", 1, 0, 0, |
1bbd0b84 | 352 | (SCM proc), |
ba94f79e | 353 | "Return the name of the procedure @var{proc}") |
1bbd0b84 | 354 | #define FUNC_NAME s_scm_procedure_name |
f0e9217a | 355 | { |
3b3b36dd | 356 | SCM_VALIDATE_PROC (1,proc); |
f0e9217a | 357 | switch (SCM_TYP7 (proc)) { |
a726dd9d MD |
358 | case scm_tcs_subrs: |
359 | return SCM_SNAME (proc); | |
360 | default: | |
f0e9217a | 361 | { |
63c51b9a | 362 | SCM name = scm_procedure_property (proc, scm_sym_name); |
f0e9217a | 363 | #if 0 |
63c51b9a | 364 | /* Source property scm_sym_procname not implemented yet... */ |
f9450cdb | 365 | SCM name = scm_source_property (SCM_CAR (SCM_CLOSURE_BODY (proc)), scm_sym_procname); |
f0e9217a | 366 | if (SCM_FALSEP (name)) |
63c51b9a | 367 | name = scm_procedure_property (proc, scm_sym_name); |
f0e9217a | 368 | #endif |
c75512d6 MD |
369 | if (SCM_FALSEP (name) && SCM_CLOSUREP (proc)) |
370 | name = scm_reverse_lookup (SCM_ENV (proc), proc); | |
f0e9217a MD |
371 | return name; |
372 | } | |
f0e9217a MD |
373 | } |
374 | } | |
1bbd0b84 | 375 | #undef FUNC_NAME |
f0e9217a | 376 | |
a1ec6916 | 377 | SCM_DEFINE (scm_procedure_source, "procedure-source", 1, 0, 0, |
1bbd0b84 | 378 | (SCM proc), |
ba94f79e | 379 | "Return the source of the procedure @var{proc}.") |
1bbd0b84 | 380 | #define FUNC_NAME s_scm_procedure_source |
f0e9217a | 381 | { |
6b5a304f | 382 | SCM_VALIDATE_NIM (1,proc); |
f0e9217a MD |
383 | switch (SCM_TYP7 (proc)) { |
384 | case scm_tcs_closures: | |
385 | { | |
4daecfee | 386 | SCM formals = SCM_CLOSURE_FORMALS (proc); |
f9450cdb | 387 | SCM src = scm_source_property (SCM_CLOSURE_BODY (proc), scm_sym_copy); |
4daecfee DH |
388 | if (!SCM_FALSEP (src)) |
389 | return scm_cons2 (scm_sym_lambda, formals, src); | |
63c51b9a | 390 | return scm_cons (scm_sym_lambda, |
4daecfee DH |
391 | scm_unmemocopy (SCM_CODE (proc), |
392 | SCM_EXTEND_ENV (formals, | |
393 | SCM_EOL, | |
394 | SCM_ENV (proc)))); | |
f0e9217a | 395 | } |
f0e9217a MD |
396 | case scm_tcs_subrs: |
397 | #ifdef CCLO | |
398 | case scm_tc7_cclo: | |
399 | #endif | |
400 | /* It would indeed be a nice thing if we supplied source even for | |
401 | built in procedures! */ | |
63c51b9a | 402 | return scm_procedure_property (proc, scm_sym_source); |
f0e9217a | 403 | default: |
276dd677 DH |
404 | SCM_WRONG_TYPE_ARG (1, proc); |
405 | /* not reached */ | |
f0e9217a MD |
406 | } |
407 | } | |
1bbd0b84 | 408 | #undef FUNC_NAME |
f0e9217a | 409 | |
a1ec6916 | 410 | SCM_DEFINE (scm_procedure_environment, "procedure-environment", 1, 0, 0, |
1bbd0b84 | 411 | (SCM proc), |
ba94f79e | 412 | "Return the environment of the procedure @var{proc}.") |
1bbd0b84 | 413 | #define FUNC_NAME s_scm_procedure_environment |
f0e9217a | 414 | { |
6b5a304f | 415 | SCM_VALIDATE_NIM (1,proc); |
f0e9217a MD |
416 | switch (SCM_TYP7 (proc)) { |
417 | case scm_tcs_closures: | |
418 | return SCM_ENV (proc); | |
f0e9217a MD |
419 | case scm_tcs_subrs: |
420 | #ifdef CCLO | |
421 | case scm_tc7_cclo: | |
422 | #endif | |
423 | return SCM_EOL; | |
424 | default: | |
276dd677 DH |
425 | SCM_WRONG_TYPE_ARG (1, proc); |
426 | /* not reached */ | |
f0e9217a MD |
427 | } |
428 | } | |
1bbd0b84 | 429 | #undef FUNC_NAME |
f0e9217a | 430 | |
bfe3154c | 431 | \f |
f0e9217a MD |
432 | |
433 | /* Eval in a local environment. We would like to have the ability to | |
e38ecb05 MD |
434 | * evaluate in a specified local environment, but due to the |
435 | * memoization this isn't normally possible. We solve it by copying | |
436 | * the code before evaluating. One solution would be to have eval.c | |
437 | * generate yet another evaluator. They are not very big actually. | |
f0e9217a | 438 | */ |
a1ec6916 | 439 | SCM_DEFINE (scm_local_eval, "local-eval", 1, 1, 0, |
1bbd0b84 | 440 | (SCM exp, SCM env), |
b380b885 MD |
441 | "Evaluate @var{exp} in its environment. If @var{env} is supplied,\n" |
442 | "it is the environment in which to evaluate @var{exp}. Otherwise,\n" | |
443 | "@var{exp} must be a memoized code object (in which case, its environment\n" | |
444 | "is implicit).") | |
1bbd0b84 | 445 | #define FUNC_NAME s_scm_local_eval |
f0e9217a | 446 | { |
6c179711 MD |
447 | if (SCM_UNBNDP (env)) |
448 | { | |
82b3290d MD |
449 | SCM_VALIDATE_MEMOIZED (1, exp); |
450 | return scm_i_eval_x (SCM_MEMOIZED_EXP (exp), SCM_MEMOIZED_ENV (exp)); | |
6c179711 | 451 | } |
82b3290d | 452 | return scm_i_eval (exp, env); |
f0e9217a | 453 | } |
1bbd0b84 | 454 | #undef FUNC_NAME |
f0e9217a | 455 | |
c75512d6 | 456 | #if 0 |
1bbd0b84 | 457 | SCM_REGISTER_PROC (s_reverse_lookup, "reverse-lookup", 2, 0, 0, scm_reverse_lookup); |
c75512d6 MD |
458 | #endif |
459 | ||
460 | SCM | |
461 | scm_reverse_lookup (SCM env, SCM data) | |
462 | { | |
22a52da1 | 463 | while (SCM_CONSP (env) && SCM_CONSP (SCM_CAR (env))) |
c75512d6 | 464 | { |
22a52da1 DH |
465 | SCM names = SCM_CAAR (env); |
466 | SCM values = SCM_CDAR (env); | |
0c95b57d | 467 | while (SCM_CONSP (names)) |
c75512d6 | 468 | { |
cffcab30 | 469 | if (SCM_EQ_P (SCM_CAR (values), data)) |
c75512d6 MD |
470 | return SCM_CAR (names); |
471 | names = SCM_CDR (names); | |
472 | values = SCM_CDR (values); | |
473 | } | |
22a52da1 | 474 | if (!SCM_NULLP (names) && SCM_EQ_P (values, data)) |
c75512d6 MD |
475 | return names; |
476 | env = SCM_CDR (env); | |
477 | } | |
478 | return SCM_BOOL_F; | |
479 | } | |
480 | ||
bfe3154c | 481 | SCM |
6e8d25a6 | 482 | scm_start_stack (SCM id, SCM exp, SCM env) |
bfe3154c MD |
483 | { |
484 | SCM answer; | |
92c2555f MV |
485 | scm_t_debug_frame vframe; |
486 | scm_t_debug_info vframe_vect_body; | |
9fa2c7b1 MD |
487 | vframe.prev = scm_last_debug_frame; |
488 | vframe.status = SCM_VOIDFRAME; | |
489 | vframe.vect = &vframe_vect_body; | |
490 | vframe.vect[0].id = id; | |
491 | scm_last_debug_frame = &vframe; | |
82b3290d | 492 | answer = scm_i_eval (exp, env); |
9fa2c7b1 MD |
493 | scm_last_debug_frame = vframe.prev; |
494 | return answer; | |
495 | } | |
496 | ||
b8229a3b MS |
497 | SCM_SYNTAX(s_start_stack, "start-stack", scm_makacro, scm_m_start_stack); |
498 | ||
8a04c1a2 | 499 | static SCM |
6e8d25a6 | 500 | scm_m_start_stack (SCM exp, SCM env) |
68baa7e7 | 501 | #define FUNC_NAME s_start_stack |
9fa2c7b1 | 502 | { |
bfe3154c | 503 | exp = SCM_CDR (exp); |
904a077d MV |
504 | if (!SCM_CONSP (exp) |
505 | || !SCM_CONSP (SCM_CDR (exp)) | |
68baa7e7 DH |
506 | || !SCM_NULLP (SCM_CDDR (exp))) |
507 | SCM_WRONG_NUM_ARGS (); | |
9fa2c7b1 | 508 | return scm_start_stack (scm_eval_car (exp, env), SCM_CADR (exp), env); |
bfe3154c | 509 | } |
68baa7e7 DH |
510 | #undef FUNC_NAME |
511 | ||
f0e9217a MD |
512 | |
513 | /* {Debug Objects} | |
514 | * | |
515 | * The debugging evaluator throws these on frame traps. | |
516 | */ | |
517 | ||
92c2555f | 518 | scm_t_bits scm_tc16_debugobj; |
f0e9217a | 519 | |
f0e9217a | 520 | static int |
e81d98ec | 521 | debugobj_print (SCM obj, SCM port, scm_print_state *pstate SCM_UNUSED) |
f0e9217a | 522 | { |
b7f3516f | 523 | scm_puts ("#<debug-object ", port); |
37c56aec | 524 | scm_intprint ((long) SCM_DEBUGOBJ_FRAME (obj), 16, port); |
b7f3516f | 525 | scm_putc ('>', port); |
f0e9217a MD |
526 | return 1; |
527 | } | |
528 | ||
a1ec6916 | 529 | SCM_DEFINE (scm_debug_object_p, "debug-object?", 1, 0, 0, |
1bbd0b84 | 530 | (SCM obj), |
ba94f79e | 531 | "Return @code{#t} if @var{obj} is a debug object.") |
1bbd0b84 | 532 | #define FUNC_NAME s_scm_debug_object_p |
f0e9217a | 533 | { |
0c95b57d | 534 | return SCM_BOOL(SCM_DEBUGOBJP (obj)); |
f0e9217a | 535 | } |
1bbd0b84 | 536 | #undef FUNC_NAME |
f0e9217a | 537 | |
1cc91f1b | 538 | |
f0e9217a | 539 | SCM |
92c2555f | 540 | scm_make_debugobj (scm_t_debug_frame *frame) |
f0e9217a | 541 | { |
16d4699b | 542 | return scm_alloc_cell (scm_tc16_debugobj, (scm_t_bits) frame); |
f0e9217a MD |
543 | } |
544 | ||
f0e9217a MD |
545 | \f |
546 | ||
fe57f652 MD |
547 | /* Undocumented debugging procedure */ |
548 | #ifdef GUILE_DEBUG | |
a1ec6916 | 549 | SCM_DEFINE (scm_debug_hang, "debug-hang", 0, 1, 0, |
1bbd0b84 | 550 | (SCM obj), |
ba94f79e MG |
551 | "Go into an endless loop, which can be only terminated with\n" |
552 | "a debugger.") | |
1bbd0b84 | 553 | #define FUNC_NAME s_scm_debug_hang |
e38ecb05 MD |
554 | { |
555 | int go = 0; | |
556 | while (!go) ; | |
557 | return SCM_UNSPECIFIED; | |
558 | } | |
1bbd0b84 | 559 | #undef FUNC_NAME |
fe57f652 | 560 | #endif |
e38ecb05 MD |
561 | |
562 | \f | |
563 | ||
f0e9217a MD |
564 | void |
565 | scm_init_debug () | |
566 | { | |
5e8d7fd4 | 567 | scm_init_opts (scm_debug_options, scm_debug_opts, SCM_N_DEBUG_OPTIONS); |
ee340120 | 568 | |
e841c3e0 KN |
569 | scm_tc16_memoized = scm_make_smob_type ("memoized", 0); |
570 | scm_set_smob_mark (scm_tc16_memoized, scm_markcdr); | |
571 | scm_set_smob_print (scm_tc16_memoized, memoized_print); | |
23a62151 | 572 | |
e841c3e0 KN |
573 | scm_tc16_debugobj = scm_make_smob_type ("debug-object", 0); |
574 | scm_set_smob_print (scm_tc16_debugobj, debugobj_print); | |
f0e9217a | 575 | |
33b97402 | 576 | #ifdef GUILE_DEBUG |
1be6b49c ML |
577 | scm_c_define ("SCM_IM_AND", SCM_IM_AND); |
578 | scm_c_define ("SCM_IM_BEGIN", SCM_IM_BEGIN); | |
579 | scm_c_define ("SCM_IM_CASE", SCM_IM_CASE); | |
580 | scm_c_define ("SCM_IM_COND", SCM_IM_COND); | |
581 | scm_c_define ("SCM_IM_DO", SCM_IM_DO); | |
582 | scm_c_define ("SCM_IM_IF", SCM_IM_IF); | |
583 | scm_c_define ("SCM_IM_LAMBDA", SCM_IM_LAMBDA); | |
584 | scm_c_define ("SCM_IM_LET", SCM_IM_LET); | |
585 | scm_c_define ("SCM_IM_LETSTAR", SCM_IM_LETSTAR); | |
586 | scm_c_define ("SCM_IM_LETREC", SCM_IM_LETREC); | |
587 | scm_c_define ("SCM_IM_OR", SCM_IM_OR); | |
588 | scm_c_define ("SCM_IM_QUOTE", SCM_IM_QUOTE); | |
589 | scm_c_define ("SCM_IM_SET_X", SCM_IM_SET_X); | |
590 | scm_c_define ("SCM_IM_DEFINE", SCM_IM_DEFINE); | |
591 | scm_c_define ("SCM_IM_APPLY", SCM_IM_APPLY); | |
592 | scm_c_define ("SCM_IM_CONT", SCM_IM_CONT); | |
593 | scm_c_define ("SCM_IM_DISPATCH", SCM_IM_DISPATCH); | |
33b97402 | 594 | #endif |
f0e9217a MD |
595 | scm_add_feature ("debug-extensions"); |
596 | ||
8dc9439f | 597 | #ifndef SCM_MAGIC_SNARFER |
a0599745 | 598 | #include "libguile/debug.x" |
8dc9439f | 599 | #endif |
f0e9217a | 600 | } |
89e00824 ML |
601 | |
602 | /* | |
603 | Local Variables: | |
604 | c-file-style: "gnu" | |
605 | End: | |
606 | */ |