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