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