libguile/debug.c

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