libguile/debug.c

   1 /* Debugging extensions for Guile
   2  * Copyright (C) 1995,1996,1997,1998,1999,2000,2001 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   SCM_VALIDATE_VARIABLE (1,var);
 264   if (SCM_UNBNDP (env))
 265     env = scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE);
 266   else
 267     SCM_VALIDATE_NULLORCONS (2,env);
 268   return scm_make_memoized (SCM_UNPACK (var) + scm_tc3_cons_gloc, env);
 269 }
 270 #undef FUNC_NAME
 271
 272 SCM_DEFINE (scm_gloc_p, "gloc?", 1, 0, 0,
 273             (SCM obj),
 274             "Return @code{#t} if @var{obj} is a gloc.")
 275 #define FUNC_NAME s_scm_gloc_p
 276 {
 277   return
 278     SCM_BOOL (SCM_MEMOIZEDP (obj)
 279               && ((SCM_UNPACK(SCM_MEMOIZED_EXP(obj))&7) == scm_tc3_cons_gloc));
 280 }
 281 #undef FUNC_NAME
 282
 283 SCM_DEFINE (scm_make_iloc, "make-iloc", 3, 0, 0,
 284             (SCM frame, SCM binding, SCM cdrp),
 285             "Return a new iloc with frame offset @var{frame}, binding\n"
 286             "offset @var{binding} and the cdr flag @var{cdrp}.")
 287 #define FUNC_NAME s_scm_make_iloc
 288 {
 289   SCM_VALIDATE_INUM (1,frame);
 290   SCM_VALIDATE_INUM (2,binding);
 291   return (SCM_ILOC00
 292           + SCM_IFRINC * SCM_INUM (frame)
 293           + (SCM_NFALSEP (cdrp) ? SCM_ICDR : 0)
 294           + SCM_IDINC * SCM_INUM (binding));
 295 }
 296 #undef FUNC_NAME
 297
 298 SCM_DEFINE (scm_iloc_p, "iloc?", 1, 0, 0,
 299           (SCM obj),
 300             "Return @code{#t} if @var{obj} is an iloc.")
 301 #define FUNC_NAME s_scm_iloc_p
 302 {
 303   return SCM_BOOL(SCM_ILOCP (obj));
 304 }
 305 #undef FUNC_NAME
 306
 307 SCM_DEFINE (scm_memcons, "memcons", 2, 1, 0,
 308             (SCM car, SCM cdr, SCM env),
 309             "Return a new memoized cons cell with @var{car} and @var{cdr}\n"
 310             "as members and @var{env} as the environment.")
 311 #define FUNC_NAME s_scm_memcons
 312 {
 313   if (SCM_MEMOIZEDP (car))
 314     {
 315       /*fixme* environments may be two different but equal top-level envs */
 316       if (!SCM_UNBNDP (env) && SCM_MEMOIZED_ENV (car) != env)
 317         SCM_MISC_ERROR ("environment mismatch arg1 <-> arg3",
 318                         scm_cons2 (car, env, SCM_EOL));
 319       else
 320         env = SCM_MEMOIZED_ENV (car);
 321       car = SCM_MEMOIZED_EXP (car);
 322     }
 323   if (SCM_MEMOIZEDP (cdr))
 324     {
 325       if (!SCM_UNBNDP (env) && SCM_MEMOIZED_ENV (cdr) != env)
 326         SCM_MISC_ERROR ("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_TOP_LEVEL_LOOKUP_CLOSURE);
 334   else
 335     SCM_VALIDATE_NULLORCONS (3,env);
 336   return scm_make_memoized (scm_cons (car, cdr), env);
 337 }
 338 #undef FUNC_NAME
 339
 340 SCM_DEFINE (scm_mem_to_proc, "mem->proc", 1, 0, 0,
 341             (SCM obj),
 342             "Convert a memoized object (which must be a lambda expression)\n"
 343             "to a procedure.")
 344 #define FUNC_NAME s_scm_mem_to_proc
 345 {
 346   SCM env;
 347   SCM_VALIDATE_MEMOIZED (1,obj);
 348   env = SCM_MEMOIZED_ENV (obj);
 349   obj = SCM_MEMOIZED_EXP (obj);
 350   if (!(SCM_NIMP (obj) && SCM_CAR (obj) == SCM_IM_LAMBDA))
 351     SCM_MISC_ERROR ("expected lambda expression",
 352                     scm_cons (obj, SCM_EOL));
 353   return scm_closure (SCM_CDR (obj), env);
 354 }
 355 #undef FUNC_NAME
 356
 357 SCM_DEFINE (scm_proc_to_mem, "proc->mem", 1, 0, 0,
 358             (SCM obj),
 359             "Convert a procedure to a memoized object.")
 360 #define FUNC_NAME s_scm_proc_to_mem
 361 {
 362   SCM_VALIDATE_CLOSURE (1, obj);
 363   return scm_make_memoized (scm_cons (SCM_IM_LAMBDA, SCM_CODE (obj)),
 364                             SCM_ENV (obj));
 365 }
 366 #undef FUNC_NAME
 367
 368 #endif /* GUILE_DEBUG */
 369
 370 SCM_DEFINE (scm_unmemoize, "unmemoize", 1, 0, 0,
 371             (SCM m),
 372             "Unmemoize the memoized expression @var{m},")
 373 #define FUNC_NAME s_scm_unmemoize
 374 {
 375   SCM_VALIDATE_MEMOIZED (1,m);
 376   return scm_unmemocopy (SCM_MEMOIZED_EXP (m), SCM_MEMOIZED_ENV (m));
 377 }
 378 #undef FUNC_NAME
 379
 380 SCM_DEFINE (scm_memoized_environment, "memoized-environment", 1, 0, 0,
 381             (SCM m),
 382             "Return the environment of the memoized expression @var{m}.")
 383 #define FUNC_NAME s_scm_memoized_environment
 384 {
 385   SCM_VALIDATE_MEMOIZED (1,m);
 386   return SCM_MEMOIZED_ENV (m);
 387 }
 388 #undef FUNC_NAME
 389
 390 SCM_DEFINE (scm_procedure_name, "procedure-name", 1, 0, 0,
 391             (SCM proc),
 392             "Return the name of the procedure @var{proc}")
 393 #define FUNC_NAME s_scm_procedure_name
 394 {
 395   SCM_VALIDATE_PROC (1,proc);
 396   switch (SCM_TYP7 (proc)) {
 397   case scm_tcs_subrs:
 398     return SCM_SNAME (proc);
 399   default:
 400     {
 401       SCM name = scm_procedure_property (proc, scm_sym_name);
 402 #if 0
 403       /* Source property scm_sym_procname not implemented yet... */
 404       SCM name = scm_source_property (SCM_CAR (SCM_CDR (SCM_CODE (proc))), scm_sym_procname);
 405       if (SCM_FALSEP (name))
 406         name = scm_procedure_property (proc, scm_sym_name);
 407 #endif
 408       if (SCM_FALSEP (name) && SCM_CLOSUREP (proc))
 409         name = scm_reverse_lookup (SCM_ENV (proc), proc);
 410       return name;
 411     }
 412   }
 413 }
 414 #undef FUNC_NAME
 415
 416 SCM_DEFINE (scm_procedure_source, "procedure-source", 1, 0, 0,
 417             (SCM proc),
 418             "Return the source of the procedure @var{proc}.")
 419 #define FUNC_NAME s_scm_procedure_source
 420 {
 421   SCM_VALIDATE_NIM (1,proc);
 422   switch (SCM_TYP7 (proc)) {
 423   case scm_tcs_closures:
 424     {
 425       SCM formals = SCM_CLOSURE_FORMALS (proc);
 426       SCM src = scm_source_property (SCM_CDR (SCM_CODE (proc)), scm_sym_copy);
 427       if (!SCM_FALSEP (src))
 428         return scm_cons2 (scm_sym_lambda, formals, src);
 429       return scm_cons (scm_sym_lambda,
 430                        scm_unmemocopy (SCM_CODE (proc),
 431                                        SCM_EXTEND_ENV (formals,
 432                                                        SCM_EOL,
 433                                                        SCM_ENV (proc))));
 434     }
 435   case scm_tcs_subrs:
 436 #ifdef CCLO
 437   case scm_tc7_cclo:
 438 #endif
 439     /* It would indeed be a nice thing if we supplied source even for
 440        built in procedures! */
 441     return scm_procedure_property (proc, scm_sym_source);
 442   default:
 443     SCM_WRONG_TYPE_ARG (1, proc);
 444     /* not reached */
 445   }
 446 }
 447 #undef FUNC_NAME
 448
 449 SCM_DEFINE (scm_procedure_environment, "procedure-environment", 1, 0, 0,
 450             (SCM proc),
 451             "Return the environment of the procedure @var{proc}.")
 452 #define FUNC_NAME s_scm_procedure_environment
 453 {
 454   SCM_VALIDATE_NIM (1,proc);
 455   switch (SCM_TYP7 (proc)) {
 456   case scm_tcs_closures:
 457     return SCM_ENV (proc);
 458   case scm_tcs_subrs:
 459 #ifdef CCLO
 460   case scm_tc7_cclo:
 461 #endif
 462     return SCM_EOL;
 463   default:
 464     SCM_WRONG_TYPE_ARG (1, proc);
 465     /* not reached */
 466   }
 467 }
 468 #undef FUNC_NAME
 469
 470 \f
 471
 472 /* Eval in a local environment.  We would like to have the ability to
 473  * evaluate in a specified local environment, but due to the
 474  * memoization this isn't normally possible.  We solve it by copying
 475  * the code before evaluating.  One solution would be to have eval.c
 476  * generate yet another evaluator.  They are not very big actually.
 477  */
 478 SCM_DEFINE (scm_local_eval, "local-eval", 1, 1, 0,
 479             (SCM exp, SCM env),
 480             "Evaluate @var{exp} in its environment.  If @var{env} is supplied,\n"
 481             "it is the environment in which to evaluate @var{exp}.  Otherwise,\n"
 482             "@var{exp} must be a memoized code object (in which case, its environment\n"
 483             "is implicit).")
 484 #define FUNC_NAME s_scm_local_eval
 485 {
 486   if (SCM_UNBNDP (env))
 487   {
 488     SCM_VALIDATE_MEMOIZED (1, exp);
 489     return scm_i_eval_x (SCM_MEMOIZED_EXP (exp), SCM_MEMOIZED_ENV (exp));
 490   }
 491   return scm_i_eval (exp, env);
 492 }
 493 #undef FUNC_NAME
 494
 495 #if 0
 496 SCM_REGISTER_PROC (s_reverse_lookup, "reverse-lookup", 2, 0, 0, scm_reverse_lookup);
 497 #endif
 498
 499 SCM
 500 scm_reverse_lookup (SCM env, SCM data)
 501 {
 502   while (SCM_CONSP (env) && SCM_CONSP (SCM_CAR (env)))
 503     {
 504       SCM names = SCM_CAAR (env);
 505       SCM values = SCM_CDAR (env);
 506       while (SCM_CONSP (names))
 507         {
 508           if (SCM_EQ_P (SCM_CAR (values), data))
 509             return SCM_CAR (names);
 510           names = SCM_CDR (names);
 511           values = SCM_CDR (values);
 512         }
 513       if (!SCM_NULLP (names) && SCM_EQ_P (values, data))
 514         return names;
 515       env = SCM_CDR (env);
 516     }
 517   return SCM_BOOL_F;
 518 }
 519
 520 SCM
 521 scm_start_stack (SCM id, SCM exp, SCM env)
 522 {
 523   SCM answer;
 524   scm_debug_frame_t vframe;
 525   scm_debug_info_t vframe_vect_body;
 526   vframe.prev = scm_last_debug_frame;
 527   vframe.status = SCM_VOIDFRAME;
 528   vframe.vect = &vframe_vect_body;
 529   vframe.vect[0].id = id;
 530   scm_last_debug_frame = &vframe;
 531   answer = scm_i_eval (exp, env);
 532   scm_last_debug_frame = vframe.prev;
 533   return answer;
 534 }
 535
 536 SCM_SYNTAX(s_start_stack, "start-stack", scm_makacro, scm_m_start_stack);
 537
 538 static SCM
 539 scm_m_start_stack (SCM exp, SCM env)
 540 #define FUNC_NAME s_start_stack
 541 {
 542   exp = SCM_CDR (exp);
 543   if (!SCM_ECONSP (exp)
 544       || !SCM_ECONSP (SCM_CDR (exp))
 545       || !SCM_NULLP (SCM_CDDR (exp)))
 546     SCM_WRONG_NUM_ARGS ();
 547   return scm_start_stack (scm_eval_car (exp, env), SCM_CADR (exp), env);
 548 }
 549 #undef FUNC_NAME
 550
 551
 552 /* {Debug Objects}
 553  *
 554  * The debugging evaluator throws these on frame traps.
 555  */
 556
 557 scm_bits_t scm_tc16_debugobj;
 558
 559 static int
 560 debugobj_print (SCM obj, SCM port, scm_print_state *pstate)
 561 {
 562   scm_puts ("#<debug-object ", port);
 563   scm_intprint ((int) SCM_DEBUGOBJ_FRAME (obj), 16, port);
 564   scm_putc ('>', port);
 565   return 1;
 566 }
 567
 568 SCM_DEFINE (scm_debug_object_p, "debug-object?", 1, 0, 0,
 569             (SCM obj),
 570             "Return @code{#t} if @var{obj} is a debug object.")
 571 #define FUNC_NAME s_scm_debug_object_p
 572 {
 573   return SCM_BOOL(SCM_DEBUGOBJP (obj));
 574 }
 575 #undef FUNC_NAME
 576
 577
 578 SCM
 579 scm_make_debugobj (scm_debug_frame_t *frame)
 580 {
 581   register SCM z;
 582   SCM_NEWCELL (z);
 583   SCM_ENTER_A_SECTION;
 584   SCM_SET_DEBUGOBJ_FRAME (z, frame);
 585   SCM_SET_CELL_TYPE (z, scm_tc16_debugobj);
 586   SCM_EXIT_A_SECTION;
 587   return z;
 588 }
 589
 590 \f
 591
 592 /* Undocumented debugging procedure */
 593 #ifdef GUILE_DEBUG
 594 SCM_DEFINE (scm_debug_hang, "debug-hang", 0, 1, 0,
 595             (SCM obj),
 596             "Go into an endless loop, which can be only terminated with\n"
 597             "a debugger.")
 598 #define FUNC_NAME s_scm_debug_hang
 599 {
 600   int go = 0;
 601   while (!go) ;
 602   return SCM_UNSPECIFIED;
 603 }
 604 #undef FUNC_NAME
 605 #endif
 606
 607 \f
 608
 609 void
 610 scm_init_debug ()
 611 {
 612   scm_init_opts (scm_debug_options, scm_debug_opts, SCM_N_DEBUG_OPTIONS);
 613
 614   scm_tc16_memoized = scm_make_smob_type ("memoized", 0);
 615   scm_set_smob_mark (scm_tc16_memoized, scm_markcdr);
 616   scm_set_smob_print (scm_tc16_memoized, memoized_print);
 617
 618   scm_tc16_debugobj = scm_make_smob_type ("debug-object", 0);
 619   scm_set_smob_print (scm_tc16_debugobj, debugobj_print);
 620
 621 #ifdef GUILE_DEBUG
 622   scm_c_define ("SCM_IM_AND", SCM_IM_AND);
 623   scm_c_define ("SCM_IM_BEGIN", SCM_IM_BEGIN);
 624   scm_c_define ("SCM_IM_CASE", SCM_IM_CASE);
 625   scm_c_define ("SCM_IM_COND", SCM_IM_COND);
 626   scm_c_define ("SCM_IM_DO", SCM_IM_DO);
 627   scm_c_define ("SCM_IM_IF", SCM_IM_IF);
 628   scm_c_define ("SCM_IM_LAMBDA", SCM_IM_LAMBDA);
 629   scm_c_define ("SCM_IM_LET", SCM_IM_LET);
 630   scm_c_define ("SCM_IM_LETSTAR", SCM_IM_LETSTAR);
 631   scm_c_define ("SCM_IM_LETREC", SCM_IM_LETREC);
 632   scm_c_define ("SCM_IM_OR", SCM_IM_OR);
 633   scm_c_define ("SCM_IM_QUOTE", SCM_IM_QUOTE);
 634   scm_c_define ("SCM_IM_SET_X", SCM_IM_SET_X);
 635   scm_c_define ("SCM_IM_DEFINE", SCM_IM_DEFINE);
 636   scm_c_define ("SCM_IM_APPLY", SCM_IM_APPLY);
 637   scm_c_define ("SCM_IM_CONT", SCM_IM_CONT);
 638   scm_c_define ("SCM_IM_DISPATCH", SCM_IM_DISPATCH);
 639 #endif
 640   scm_add_feature ("debug-extensions");
 641
 642 #ifndef SCM_MAGIC_SNARFER
 643 #include "libguile/debug.x"
 644 #endif
 645 }
 646
 647 /*
 648   Local Variables:
 649   c-file-style: "gnu"
 650   End:
 651 */