Commit | Line | Data |
---|---|---|
63c51b9a | 1 | /* Debugging extensions for Guile |
78a0461a | 2 | * Copyright (C) 1995, 1996, 1997, 1998, 1999 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 | /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, |
47 | gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ | |
48 | ||
49 | ||
f0e9217a MD |
50 | #include <stdio.h> |
51 | #include "_scm.h" | |
20e6290e | 52 | #include "eval.h" |
a6e350dd | 53 | #include "stackchk.h" |
20e6290e JB |
54 | #include "throw.h" |
55 | #include "genio.h" | |
41d3b325 | 56 | #include "macros.h" |
20e6290e JB |
57 | #include "smob.h" |
58 | #include "procprop.h" | |
59 | #include "srcprop.h" | |
60 | #include "alist.h" | |
61 | #include "continuations.h" | |
62 | #include "strports.h" | |
63 | #include "read.h" | |
64 | #include "feature.h" | |
260b1416 | 65 | #include "dynwind.h" |
650de6d7 | 66 | #include "modules.h" |
f0e9217a | 67 | |
1bbd0b84 | 68 | #include "scm_validate.h" |
20e6290e | 69 | #include "debug.h" |
f0e9217a MD |
70 | \f |
71 | ||
72 | /* {Run time control of the debugging evaluator} | |
73 | */ | |
74 | ||
1bbd0b84 GB |
75 | GUILE_PROC (scm_debug_options, "debug-options-interface", 0, 1, 0, |
76 | (SCM setting), | |
77 | "") | |
78 | #define FUNC_NAME s_scm_debug_options | |
f0e9217a MD |
79 | { |
80 | SCM ans; | |
81 | SCM_DEFER_INTS; | |
5e8d7fd4 MD |
82 | ans = scm_options (setting, |
83 | scm_debug_opts, | |
84 | SCM_N_DEBUG_OPTIONS, | |
1bbd0b84 | 85 | FUNC_NAME); |
f0e9217a | 86 | #ifndef SCM_RECKLESS |
5e8d7fd4 | 87 | if (!(1 <= SCM_N_FRAMES && SCM_N_FRAMES <= SCM_MAX_FRAME_SIZE)) |
f0e9217a | 88 | { |
1bbd0b84 GB |
89 | scm_options (ans, scm_debug_opts, SCM_N_DEBUG_OPTIONS, FUNC_NAME); |
90 | scm_out_of_range (FUNC_NAME, setting); | |
f0e9217a MD |
91 | } |
92 | #endif | |
5e8d7fd4 | 93 | SCM_RESET_DEBUG_MODE; |
a6e350dd | 94 | scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P; |
5e8d7fd4 | 95 | scm_debug_eframe_size = 2 * SCM_N_FRAMES; |
bfc69694 | 96 | SCM_ALLOW_INTS; |
f0e9217a MD |
97 | return ans; |
98 | } | |
1bbd0b84 | 99 | #undef FUNC_NAME |
260b1416 MD |
100 | |
101 | static void | |
102 | with_traps_before (void *data) | |
103 | { | |
104 | int *trap_flag = data; | |
105 | *trap_flag = SCM_TRAPS_P; | |
106 | SCM_TRAPS_P = 1; | |
107 | } | |
108 | ||
109 | static void | |
110 | with_traps_after (void *data) | |
111 | { | |
112 | int *trap_flag = data; | |
113 | SCM_TRAPS_P = *trap_flag; | |
114 | } | |
115 | ||
116 | static SCM | |
117 | with_traps_inner (void *data) | |
118 | { | |
119 | SCM thunk = (SCM) data; | |
120 | return scm_apply (thunk, SCM_EOL, SCM_EOL); | |
121 | } | |
1cc91f1b | 122 | |
1bbd0b84 GB |
123 | GUILE_PROC (scm_with_traps, "with-traps", 1, 0, 0, |
124 | (SCM thunk), | |
125 | "") | |
126 | #define FUNC_NAME s_scm_with_traps | |
f0e9217a | 127 | { |
260b1416 | 128 | int trap_flag; |
1bbd0b84 | 129 | SCM_VALIDATE_THUNK(1,thunk); |
260b1416 MD |
130 | return scm_internal_dynamic_wind (with_traps_before, |
131 | with_traps_inner, | |
132 | with_traps_after, | |
133 | (void *) thunk, | |
134 | &trap_flag); | |
f0e9217a | 135 | } |
1bbd0b84 | 136 | #undef FUNC_NAME |
f0e9217a MD |
137 | |
138 | \f | |
63c51b9a MD |
139 | static SCM scm_sym_source, scm_sym_dots; |
140 | static SCM scm_sym_procname; | |
f0e9217a MD |
141 | |
142 | /* {Memoized Source} | |
143 | */ | |
144 | ||
145 | long scm_tc16_memoized; | |
146 | ||
1cc91f1b | 147 | |
f0e9217a | 148 | static int |
1bbd0b84 | 149 | prinmemoized (SCM obj,SCM port,scm_print_state *pstate) |
f0e9217a | 150 | { |
9882ea19 | 151 | int writingp = SCM_WRITINGP (pstate); |
b7f3516f | 152 | scm_puts ("#<memoized ", port); |
9882ea19 | 153 | SCM_SET_WRITINGP (pstate, 1); |
33b97402 MD |
154 | #ifdef GUILE_DEBUG |
155 | scm_iprin1 (SCM_MEMOIZED_EXP (obj), port, pstate); | |
156 | #else | |
9882ea19 | 157 | scm_iprin1 (scm_unmemoize (obj), port, pstate); |
33b97402 | 158 | #endif |
9882ea19 | 159 | SCM_SET_WRITINGP (pstate, writingp); |
b7f3516f | 160 | scm_putc ('>', port); |
f0e9217a MD |
161 | return 1; |
162 | } | |
163 | ||
1bbd0b84 GB |
164 | GUILE_PROC (scm_memoized_p, "memoized?", 1, 0, 0, |
165 | (SCM obj), | |
166 | "") | |
167 | #define FUNC_NAME s_scm_memoized_p | |
f0e9217a | 168 | { |
1bbd0b84 | 169 | return SCM_BOOL(SCM_NIMP (obj) && SCM_MEMOIZEDP (obj)); |
f0e9217a | 170 | } |
1bbd0b84 | 171 | #undef FUNC_NAME |
f0e9217a | 172 | |
f0e9217a | 173 | SCM |
1bbd0b84 | 174 | scm_make_memoized (SCM exp, SCM env) |
f0e9217a | 175 | { |
6c179711 | 176 | /* *fixme* Check that env is a valid environment. */ |
f0e9217a | 177 | register SCM z, ans; |
f83e2737 | 178 | SCM_ENTER_A_SECTION; |
23a62151 MD |
179 | SCM_NEWSMOB (z, exp, env); |
180 | SCM_NEWSMOB (ans, scm_tc16_memoized, z); | |
f83e2737 | 181 | SCM_EXIT_A_SECTION; |
f0e9217a MD |
182 | return ans; |
183 | } | |
184 | ||
33b97402 MD |
185 | #ifdef GUILE_DEBUG |
186 | /* | |
187 | * Some primitives for construction of memoized code | |
188 | * | |
189 | * - procedure: memcons CAR CDR [ENV] | |
190 | * | |
191 | * Construct a pair, encapsulated in a memoized object. | |
192 | * | |
193 | * The CAR and CDR can be either normal or memoized. If ENV isn't | |
194 | * specified, the top-level environment of the current module will | |
195 | * be assumed. All environments must match. | |
196 | * | |
197 | * - procedure: make-gloc VARIABLE [ENV] | |
198 | * | |
199 | * Return a gloc, encapsulated in a memoized object. | |
200 | * | |
201 | * (Glocs can't exist in normal list structures, since they will | |
202 | * be mistaken for structs.) | |
203 | * | |
204 | * - procedure: gloc? OBJECT | |
205 | * | |
206 | * Return #t if OBJECT is a memoized gloc. | |
207 | * | |
208 | * - procedure: make-iloc FRAME BINDING CDRP | |
209 | * | |
210 | * Return an iloc referring to frame no. FRAME, binding | |
211 | * no. BINDING. If CDRP is non-#f, the iloc is referring to a | |
212 | * frame consisting of a single pair, with the value stored in the | |
213 | * CDR. | |
214 | * | |
215 | * - procedure: iloc? OBJECT | |
216 | * | |
217 | * Return #t if OBJECT is an iloc. | |
218 | * | |
219 | * - procedure: mem->proc MEMOIZED | |
220 | * | |
221 | * Construct a closure from the memoized lambda expression MEMOIZED | |
222 | * | |
223 | * WARNING! The code is not copied! | |
224 | * | |
225 | * - procedure: proc->mem CLOSURE | |
226 | * | |
227 | * Turn the closure CLOSURE into a memoized object. | |
228 | * | |
229 | * WARNING! The code is not copied! | |
230 | * | |
231 | * - constant: SCM_IM_AND | |
232 | * - constant: SCM_IM_BEGIN | |
233 | * - constant: SCM_IM_CASE | |
234 | * - constant: SCM_IM_COND | |
235 | * - constant: SCM_IM_DO | |
236 | * - constant: SCM_IM_IF | |
237 | * - constant: SCM_IM_LAMBDA | |
238 | * - constant: SCM_IM_LET | |
239 | * - constant: SCM_IM_LETSTAR | |
240 | * - constant: SCM_IM_LETREC | |
241 | * - constant: SCM_IM_OR | |
242 | * - constant: SCM_IM_QUOTE | |
243 | * - constant: SCM_IM_SET | |
244 | * - constant: SCM_IM_DEFINE | |
245 | * - constant: SCM_IM_APPLY | |
246 | * - constant: SCM_IM_CONT | |
bbab09f6 | 247 | * - constant: SCM_IM_DISPATCH |
33b97402 MD |
248 | */ |
249 | ||
250 | #include "variable.h" | |
251 | #include "procs.h" | |
252 | ||
1bbd0b84 GB |
253 | GUILE_PROC (scm_make_gloc, "make-gloc", 1, 1, 0, |
254 | (SCM var, SCM env), | |
255 | "") | |
256 | #define FUNC_NAME s_scm_make_gloc | |
33b97402 MD |
257 | { |
258 | #if 1 /* Unsafe */ | |
259 | if (SCM_NIMP (var) && SCM_CONSP (var)) | |
260 | var = scm_cons (SCM_BOOL_F, var); | |
261 | else | |
262 | #endif | |
1bbd0b84 | 263 | SCM_VALIDATE_VARIABLE(1,var); |
33b97402 MD |
264 | if (SCM_UNBNDP (env)) |
265 | env = scm_top_level_env (SCM_CDR (scm_top_level_lookup_closure_var)); | |
266 | else | |
1bbd0b84 | 267 | SCM_VALIDATE_NULLORCONS(2,env); |
33b97402 MD |
268 | return scm_make_memoized (SCM_VARVCELL (var) + 1, env); |
269 | } | |
1bbd0b84 | 270 | #undef FUNC_NAME |
33b97402 | 271 | |
1bbd0b84 GB |
272 | GUILE_PROC (scm_gloc_p, "gloc?", 1, 0, 0, |
273 | (SCM obj), | |
274 | "") | |
275 | #define FUNC_NAME s_scm_gloc_p | |
33b97402 | 276 | { |
1bbd0b84 GB |
277 | return SCM_BOOL((SCM_NIMP (obj) |
278 | && SCM_MEMOIZEDP (obj) | |
279 | && (SCM_MEMOIZED_EXP (obj) & 7) == 1)); | |
33b97402 | 280 | } |
1bbd0b84 | 281 | #undef FUNC_NAME |
33b97402 | 282 | |
1bbd0b84 GB |
283 | GUILE_PROC (scm_make_iloc, "make-iloc", 3, 0, 0, |
284 | (SCM frame, SCM binding, SCM cdrp), | |
285 | "") | |
286 | #define FUNC_NAME s_scm_make_iloc | |
33b97402 | 287 | { |
1bbd0b84 | 288 | SCM_VALIDATE_INT(1,frame); |
5623a9b4 | 289 | SCM_VALIDATE_INT(2,binding); |
33b97402 MD |
290 | return (SCM_ILOC00 |
291 | + SCM_IFRINC * SCM_INUM (frame) | |
292 | + (SCM_NFALSEP (cdrp) ? SCM_ICDR : 0) | |
293 | + SCM_IDINC * SCM_INUM (binding)); | |
294 | } | |
1bbd0b84 | 295 | #undef FUNC_NAME |
33b97402 | 296 | |
1bbd0b84 GB |
297 | GUILE_PROC (scm_iloc_p, "iloc?", 1, 0, 0, |
298 | (SCM obj), | |
299 | "") | |
300 | #define FUNC_NAME s_scm_iGUILE_p | |
33b97402 | 301 | { |
1bbd0b84 | 302 | return SCM_BOOL(SCM_ILOCP (obj)); |
33b97402 | 303 | } |
1bbd0b84 | 304 | #undef FUNC_NAME |
33b97402 | 305 | |
1bbd0b84 GB |
306 | GUILE_PROC (scm_memcons, "memcons", 2, 1, 0, |
307 | (SCM car, SCM cdr, SCM env), | |
308 | "") | |
309 | #define FUNC_NAME s_scm_memcons | |
33b97402 MD |
310 | { |
311 | if (SCM_NIMP (car) && SCM_MEMOIZEDP (car)) | |
312 | { | |
313 | /*fixme* environments may be two different but equal top-level envs */ | |
314 | if (!SCM_UNBNDP (env) && SCM_MEMOIZED_ENV (car) != env) | |
5623a9b4 | 315 | scm_misc_error (s_scm_memcons, |
33b97402 MD |
316 | "environment mismatch arg1 <-> arg3", |
317 | scm_cons2 (car, env, SCM_EOL)); | |
318 | else | |
319 | env = SCM_MEMOIZED_ENV (car); | |
320 | car = SCM_MEMOIZED_EXP (car); | |
321 | } | |
322 | if (SCM_NIMP (cdr) && SCM_MEMOIZEDP (cdr)) | |
323 | { | |
324 | if (!SCM_UNBNDP (env) && SCM_MEMOIZED_ENV (cdr) != env) | |
5623a9b4 | 325 | scm_misc_error (s_scm_memcons, |
33b97402 MD |
326 | "environment mismatch arg2 <-> arg3", |
327 | scm_cons2 (cdr, env, SCM_EOL)); | |
328 | else | |
329 | env = SCM_MEMOIZED_ENV (cdr); | |
330 | cdr = SCM_MEMOIZED_EXP (cdr); | |
331 | } | |
332 | if (SCM_UNBNDP (env)) | |
333 | env = scm_top_level_env (SCM_CDR (scm_top_level_lookup_closure_var)); | |
334 | else | |
335 | SCM_ASSERT (SCM_NULLP (env) || (SCM_NIMP (env) && SCM_CONSP (env)), | |
336 | env, | |
337 | SCM_ARG3, | |
5623a9b4 | 338 | s_scm_make_iloc); |
33b97402 MD |
339 | return scm_make_memoized (scm_cons (car, cdr), env); |
340 | } | |
1bbd0b84 | 341 | #undef FUNC_NAME |
33b97402 | 342 | |
1bbd0b84 GB |
343 | GUILE_PROC (scm_mem_to_proc, "mem->proc", 1, 0, 0, |
344 | (SCM obj), | |
345 | "") | |
346 | #define FUNC_NAME s_scm_mem_to_proc | |
33b97402 MD |
347 | { |
348 | SCM env; | |
1bbd0b84 | 349 | SCM_VALIDATE_MEMOIZED(1,obj); |
33b97402 MD |
350 | env = SCM_MEMOIZED_ENV (obj); |
351 | obj = SCM_MEMOIZED_EXP (obj); | |
352 | if (!(SCM_NIMP (obj) && SCM_CAR (obj) == SCM_IM_LAMBDA)) | |
5623a9b4 | 353 | scm_misc_error (s_scm_mem_to_proc, |
33b97402 MD |
354 | "expected lambda expression", |
355 | scm_cons (obj, SCM_EOL)); | |
356 | return scm_closure (SCM_CDR (obj), env); | |
357 | } | |
1bbd0b84 | 358 | #undef FUNC_NAME |
33b97402 | 359 | |
1bbd0b84 GB |
360 | GUILE_PROC (scm_proc_to_mem, "proc->mem", 1, 0, 0, |
361 | (SCM obj), | |
362 | "") | |
363 | #define FUNC_NAME s_scm_proc_to_mem | |
33b97402 | 364 | { |
5623a9b4 | 365 | SCM_VALIDATE_CLOSURE (1, obj); |
33b97402 MD |
366 | return scm_make_memoized (scm_cons (SCM_IM_LAMBDA, SCM_CODE (obj)), |
367 | SCM_ENV (obj)); | |
368 | } | |
1bbd0b84 | 369 | #undef FUNC_NAME |
33b97402 MD |
370 | |
371 | #endif /* GUILE_DEBUG */ | |
372 | ||
1bbd0b84 GB |
373 | GUILE_PROC (scm_unmemoize, "unmemoize", 1, 0, 0, |
374 | (SCM m), | |
375 | "") | |
376 | #define FUNC_NAME s_scm_unmemoize | |
f0e9217a | 377 | { |
1bbd0b84 | 378 | SCM_VALIDATE_MEMOIZED(1,m); |
bfe3154c | 379 | return scm_unmemocopy (SCM_MEMOIZED_EXP (m), SCM_MEMOIZED_ENV (m)); |
f0e9217a | 380 | } |
1bbd0b84 | 381 | #undef FUNC_NAME |
f0e9217a | 382 | |
1bbd0b84 GB |
383 | GUILE_PROC (scm_memoized_environment, "memoized-environment", 1, 0, 0, |
384 | (SCM m), | |
385 | "") | |
386 | #define FUNC_NAME s_scm_memoized_environment | |
f0e9217a | 387 | { |
1bbd0b84 | 388 | SCM_VALIDATE_MEMOIZED(1,m); |
bfe3154c | 389 | return SCM_MEMOIZED_ENV (m); |
f0e9217a | 390 | } |
1bbd0b84 | 391 | #undef FUNC_NAME |
f0e9217a | 392 | |
1bbd0b84 GB |
393 | GUILE_PROC (scm_procedure_name, "procedure-name", 1, 0, 0, |
394 | (SCM proc), | |
395 | "") | |
396 | #define FUNC_NAME s_scm_procedure_name | |
f0e9217a | 397 | { |
1bbd0b84 | 398 | SCM_VALIDATE_PROC(1,proc); |
f0e9217a | 399 | switch (SCM_TYP7 (proc)) { |
a726dd9d MD |
400 | case scm_tcs_subrs: |
401 | return SCM_SNAME (proc); | |
402 | default: | |
f0e9217a | 403 | { |
63c51b9a | 404 | SCM name = scm_procedure_property (proc, scm_sym_name); |
f0e9217a | 405 | #if 0 |
63c51b9a MD |
406 | /* Source property scm_sym_procname not implemented yet... */ |
407 | SCM name = scm_source_property (SCM_CAR (SCM_CDR (SCM_CODE (proc))), scm_sym_procname); | |
f0e9217a | 408 | if (SCM_FALSEP (name)) |
63c51b9a | 409 | name = scm_procedure_property (proc, scm_sym_name); |
f0e9217a | 410 | #endif |
c75512d6 MD |
411 | if (SCM_FALSEP (name) && SCM_CLOSUREP (proc)) |
412 | name = scm_reverse_lookup (SCM_ENV (proc), proc); | |
f0e9217a MD |
413 | return name; |
414 | } | |
f0e9217a MD |
415 | } |
416 | } | |
1bbd0b84 | 417 | #undef FUNC_NAME |
f0e9217a | 418 | |
1bbd0b84 GB |
419 | GUILE_PROC (scm_procedure_source, "procedure-source", 1, 0, 0, |
420 | (SCM proc), | |
421 | "") | |
422 | #define FUNC_NAME s_scm_procedure_source | |
f0e9217a | 423 | { |
6b5a304f | 424 | SCM_VALIDATE_NIM (1,proc); |
f0e9217a MD |
425 | switch (SCM_TYP7 (proc)) { |
426 | case scm_tcs_closures: | |
427 | { | |
428 | SCM src; | |
63c51b9a | 429 | src = scm_source_property (SCM_CDR (SCM_CODE (proc)), scm_sym_copy); |
f0e9217a | 430 | if (src != SCM_BOOL_F) |
63c51b9a | 431 | return scm_cons2 (scm_sym_lambda, SCM_CAR (SCM_CODE (proc)), src); |
f0e9217a | 432 | src = SCM_CODE (proc); |
63c51b9a | 433 | return scm_cons (scm_sym_lambda, |
f0e9217a | 434 | scm_unmemocopy (src, |
e2806c10 | 435 | SCM_EXTEND_ENV (SCM_CAR (src), |
f0e9217a MD |
436 | SCM_EOL, |
437 | SCM_ENV (proc)))); | |
438 | } | |
439 | case scm_tc7_contin: | |
440 | case scm_tcs_subrs: | |
441 | #ifdef CCLO | |
442 | case scm_tc7_cclo: | |
443 | #endif | |
444 | /* It would indeed be a nice thing if we supplied source even for | |
445 | built in procedures! */ | |
63c51b9a | 446 | return scm_procedure_property (proc, scm_sym_source); |
f0e9217a | 447 | default: |
1bbd0b84 | 448 | SCM_WTA(1,proc); |
f0e9217a MD |
449 | return 0; |
450 | } | |
451 | } | |
1bbd0b84 | 452 | #undef FUNC_NAME |
f0e9217a | 453 | |
1bbd0b84 GB |
454 | GUILE_PROC (scm_procedure_environment, "procedure-environment", 1, 0, 0, |
455 | (SCM proc), | |
456 | "") | |
457 | #define FUNC_NAME s_scm_procedure_environment | |
f0e9217a | 458 | { |
6b5a304f | 459 | SCM_VALIDATE_NIM (1,proc); |
f0e9217a MD |
460 | switch (SCM_TYP7 (proc)) { |
461 | case scm_tcs_closures: | |
462 | return SCM_ENV (proc); | |
463 | case scm_tc7_contin: | |
464 | case scm_tcs_subrs: | |
465 | #ifdef CCLO | |
466 | case scm_tc7_cclo: | |
467 | #endif | |
468 | return SCM_EOL; | |
469 | default: | |
1bbd0b84 | 470 | SCM_WTA(1,proc); |
f0e9217a MD |
471 | return 0; |
472 | } | |
473 | } | |
1bbd0b84 | 474 | #undef FUNC_NAME |
f0e9217a | 475 | |
bfe3154c | 476 | \f |
f0e9217a MD |
477 | |
478 | /* Eval in a local environment. We would like to have the ability to | |
e38ecb05 MD |
479 | * evaluate in a specified local environment, but due to the |
480 | * memoization this isn't normally possible. We solve it by copying | |
481 | * the code before evaluating. One solution would be to have eval.c | |
482 | * generate yet another evaluator. They are not very big actually. | |
f0e9217a | 483 | */ |
1bbd0b84 GB |
484 | GUILE_PROC (scm_local_eval, "local-eval", 1, 1, 0, |
485 | (SCM exp, SCM env), | |
4079f87e GB |
486 | "Evaluate @var{exp} in its environment. If @var{env} is supplied, |
487 | it is the environment in which to evaluate @var{exp}. Otherwise, | |
488 | @var{exp} must be a memoized code object (in which case, its environment | |
489 | is implicit).") | |
1bbd0b84 | 490 | #define FUNC_NAME s_scm_local_eval |
f0e9217a | 491 | { |
6c179711 MD |
492 | if (SCM_UNBNDP (env)) |
493 | { | |
1bbd0b84 | 494 | SCM_VALIDATE_MEMOIZED(1,exp); |
6c179711 MD |
495 | return scm_eval_3 (SCM_MEMOIZED_EXP (exp), 0, SCM_MEMOIZED_ENV (exp)); |
496 | } | |
f0e9217a MD |
497 | return scm_eval_3 (exp, 1, env); |
498 | } | |
1bbd0b84 | 499 | #undef FUNC_NAME |
f0e9217a | 500 | |
c75512d6 | 501 | #if 0 |
1bbd0b84 | 502 | SCM_REGISTER_PROC (s_reverse_lookup, "reverse-lookup", 2, 0, 0, scm_reverse_lookup); |
c75512d6 MD |
503 | #endif |
504 | ||
505 | SCM | |
506 | scm_reverse_lookup (SCM env, SCM data) | |
507 | { | |
508 | SCM names, values; | |
509 | while (SCM_NIMP (env) && SCM_CONSP (SCM_CAR (env))) | |
510 | { | |
511 | names = SCM_CAAR (env); | |
512 | values = SCM_CDAR (env); | |
513 | while (SCM_NIMP (names) && SCM_CONSP (names)) | |
514 | { | |
515 | if (SCM_CAR (values) == data) | |
516 | return SCM_CAR (names); | |
517 | names = SCM_CDR (names); | |
518 | values = SCM_CDR (values); | |
519 | } | |
520 | if (names != SCM_EOL && values == data) | |
521 | return names; | |
522 | env = SCM_CDR (env); | |
523 | } | |
524 | return SCM_BOOL_F; | |
525 | } | |
526 | ||
bfe3154c | 527 | SCM |
6e8d25a6 | 528 | scm_start_stack (SCM id, SCM exp, SCM env) |
bfe3154c MD |
529 | { |
530 | SCM answer; | |
c6b8a41a | 531 | scm_debug_frame vframe; |
c0ab1b8d | 532 | scm_debug_info vframe_vect_body; |
9fa2c7b1 MD |
533 | vframe.prev = scm_last_debug_frame; |
534 | vframe.status = SCM_VOIDFRAME; | |
535 | vframe.vect = &vframe_vect_body; | |
536 | vframe.vect[0].id = id; | |
537 | scm_last_debug_frame = &vframe; | |
cb412265 | 538 | answer = scm_eval_3 (exp, 1, env); |
9fa2c7b1 MD |
539 | scm_last_debug_frame = vframe.prev; |
540 | return answer; | |
541 | } | |
542 | ||
b8229a3b MS |
543 | SCM_SYNTAX(s_start_stack, "start-stack", scm_makacro, scm_m_start_stack); |
544 | ||
8a04c1a2 | 545 | static SCM |
6e8d25a6 | 546 | scm_m_start_stack (SCM exp, SCM env) |
9fa2c7b1 | 547 | { |
bfe3154c | 548 | exp = SCM_CDR (exp); |
c6b8a41a | 549 | SCM_ASSERT (SCM_NIMP (exp) |
e38ecb05 | 550 | && SCM_ECONSP (exp) |
c6b8a41a | 551 | && SCM_NIMP (SCM_CDR (exp)) |
e38ecb05 | 552 | && SCM_ECONSP (SCM_CDR (exp)) |
c6b8a41a | 553 | && SCM_NULLP (SCM_CDDR (exp)), |
bfe3154c MD |
554 | exp, |
555 | SCM_WNA, | |
556 | s_start_stack); | |
9fa2c7b1 | 557 | return scm_start_stack (scm_eval_car (exp, env), SCM_CADR (exp), env); |
bfe3154c | 558 | } |
f0e9217a MD |
559 | |
560 | /* {Debug Objects} | |
561 | * | |
562 | * The debugging evaluator throws these on frame traps. | |
563 | */ | |
564 | ||
565 | long scm_tc16_debugobj; | |
566 | ||
f0e9217a | 567 | static int |
1bbd0b84 | 568 | prindebugobj (SCM obj,SCM port,scm_print_state *pstate) |
f0e9217a | 569 | { |
b7f3516f | 570 | scm_puts ("#<debug-object ", port); |
bfe3154c | 571 | scm_intprint (SCM_DEBUGOBJ_FRAME (obj), 16, port); |
b7f3516f | 572 | scm_putc ('>', port); |
f0e9217a MD |
573 | return 1; |
574 | } | |
575 | ||
1bbd0b84 GB |
576 | GUILE_PROC (scm_debug_object_p, "debug-object?", 1, 0, 0, |
577 | (SCM obj), | |
578 | "") | |
579 | #define FUNC_NAME s_scm_debug_object_p | |
f0e9217a | 580 | { |
1bbd0b84 | 581 | return SCM_BOOL(SCM_NIMP (obj) && SCM_DEBUGOBJP (obj)); |
f0e9217a | 582 | } |
1bbd0b84 | 583 | #undef FUNC_NAME |
f0e9217a | 584 | |
1cc91f1b | 585 | |
f0e9217a | 586 | SCM |
1bbd0b84 | 587 | scm_make_debugobj (scm_debug_frame *frame) |
f0e9217a MD |
588 | { |
589 | register SCM z; | |
f0e9217a | 590 | SCM_NEWCELL (z); |
f83e2737 | 591 | SCM_ENTER_A_SECTION; |
a6c64c3c | 592 | SCM_SET_DEBUGOBJ_FRAME (z, (SCM) frame); |
f83e2737 MD |
593 | SCM_SETCAR (z, scm_tc16_debugobj); |
594 | SCM_EXIT_A_SECTION; | |
f0e9217a MD |
595 | return z; |
596 | } | |
597 | ||
f0e9217a MD |
598 | \f |
599 | ||
fe57f652 MD |
600 | /* Undocumented debugging procedure */ |
601 | #ifdef GUILE_DEBUG | |
1bbd0b84 GB |
602 | GUILE_PROC (scm_debug_hang, "debug-hang", 0, 1, 0, |
603 | (SCM obj), | |
604 | "") | |
605 | #define FUNC_NAME s_scm_debug_hang | |
e38ecb05 MD |
606 | { |
607 | int go = 0; | |
608 | while (!go) ; | |
609 | return SCM_UNSPECIFIED; | |
610 | } | |
1bbd0b84 | 611 | #undef FUNC_NAME |
fe57f652 | 612 | #endif |
e38ecb05 MD |
613 | |
614 | \f | |
615 | ||
f0e9217a MD |
616 | void |
617 | scm_init_debug () | |
618 | { | |
5e8d7fd4 | 619 | scm_init_opts (scm_debug_options, scm_debug_opts, SCM_N_DEBUG_OPTIONS); |
ee340120 | 620 | |
23a62151 MD |
621 | scm_tc16_memoized = scm_make_smob_type_mfpe ("memoized", 0, |
622 | scm_markcdr, NULL, prinmemoized, NULL); | |
623 | ||
624 | scm_tc16_debugobj = scm_make_smob_type_mfpe ("debug-object", 0, | |
625 | NULL, NULL, prindebugobj, NULL); | |
f0e9217a | 626 | |
63c51b9a MD |
627 | scm_sym_procname = SCM_CAR (scm_sysintern ("procname", SCM_UNDEFINED)); |
628 | scm_sym_dots = SCM_CAR (scm_sysintern ("...", SCM_UNDEFINED)); | |
629 | scm_sym_source = SCM_CAR (scm_sysintern ("source", SCM_UNDEFINED)); | |
f0e9217a | 630 | |
33b97402 MD |
631 | #ifdef GUILE_DEBUG |
632 | scm_sysintern ("SCM_IM_AND", SCM_IM_AND); | |
633 | scm_sysintern ("SCM_IM_BEGIN", SCM_IM_BEGIN); | |
634 | scm_sysintern ("SCM_IM_CASE", SCM_IM_CASE); | |
635 | scm_sysintern ("SCM_IM_COND", SCM_IM_COND); | |
636 | scm_sysintern ("SCM_IM_DO", SCM_IM_DO); | |
637 | scm_sysintern ("SCM_IM_IF", SCM_IM_IF); | |
638 | scm_sysintern ("SCM_IM_LAMBDA", SCM_IM_LAMBDA); | |
639 | scm_sysintern ("SCM_IM_LET", SCM_IM_LET); | |
640 | scm_sysintern ("SCM_IM_LETSTAR", SCM_IM_LETSTAR); | |
641 | scm_sysintern ("SCM_IM_LETREC", SCM_IM_LETREC); | |
642 | scm_sysintern ("SCM_IM_OR", SCM_IM_OR); | |
643 | scm_sysintern ("SCM_IM_QUOTE", SCM_IM_QUOTE); | |
bbab09f6 | 644 | scm_sysintern ("SCM_IM_SET_X", SCM_IM_SET_X); |
33b97402 MD |
645 | scm_sysintern ("SCM_IM_DEFINE", SCM_IM_DEFINE); |
646 | scm_sysintern ("SCM_IM_APPLY", SCM_IM_APPLY); | |
647 | scm_sysintern ("SCM_IM_CONT", SCM_IM_CONT); | |
bbab09f6 | 648 | scm_sysintern ("SCM_IM_DISPATCH", SCM_IM_DISPATCH); |
33b97402 | 649 | #endif |
f0e9217a MD |
650 | scm_add_feature ("debug-extensions"); |
651 | ||
652 | #include "debug.x" | |
653 | } |