libguile/debug.c

   1  /* Debugging extensions for Guile
   2  * Copyright (C) 1995, 1996, 1997, 1998, 1999 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 "_scm.h"
  52 #include "eval.h"
  53 #include "stackchk.h"
  54 #include "throw.h"
  55 #include "genio.h"
  56 #include "macros.h"
  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"
  65 #include "dynwind.h"
  66 #include "modules.h"
  67
  68 #include "scm_validate.h"
  69 #include "debug.h"
  70 \f
  71
  72 /* {Run time control of the debugging evaluator}
  73  */
  74
  75 GUILE_PROC (scm_debug_options, "debug-options-interface", 0, 1, 0,
  76             (SCM setting),
  77 "")
  78 #define FUNC_NAME s_scm_debug_options
  79 {
  80   SCM ans;
  81   SCM_DEFER_INTS;
  82   ans = scm_options (setting,
  83                      scm_debug_opts,
  84                      SCM_N_DEBUG_OPTIONS,
  85                      FUNC_NAME);
  86 #ifndef SCM_RECKLESS
  87   if (!(1 <= SCM_N_FRAMES && SCM_N_FRAMES <= SCM_MAX_FRAME_SIZE))
  88     {
  89       scm_options (ans, scm_debug_opts, SCM_N_DEBUG_OPTIONS, FUNC_NAME);
  90       scm_out_of_range (FUNC_NAME, setting);
  91     }
  92 #endif
  93   SCM_RESET_DEBUG_MODE;
  94   scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
  95   scm_debug_eframe_size = 2 * SCM_N_FRAMES;
  96   SCM_ALLOW_INTS;
  97   return ans;
  98 }
  99 #undef FUNC_NAME
 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 }
 122
 123 GUILE_PROC (scm_with_traps, "with-traps", 1, 0, 0,
 124             (SCM thunk),
 125 "")
 126 #define FUNC_NAME s_scm_with_traps
 127 {
 128   int trap_flag;
 129   SCM_VALIDATE_THUNK(1,thunk);
 130   return scm_internal_dynamic_wind (with_traps_before,
 131                                     with_traps_inner,
 132                                     with_traps_after,
 133                                     (void *) thunk,
 134                                     &trap_flag);
 135 }
 136 #undef FUNC_NAME
 137
 138 \f
 139 static SCM scm_sym_source, scm_sym_dots;
 140 static SCM scm_sym_procname;
 141
 142 /* {Memoized Source}
 143  */
 144
 145 long scm_tc16_memoized;
 146
 147
 148 static int
 149 prinmemoized (SCM obj,SCM port,scm_print_state *pstate)
 150 {
 151   int writingp = SCM_WRITINGP (pstate);
 152   scm_puts ("#<memoized ", port);
 153   SCM_SET_WRITINGP (pstate, 1);
 154 #ifdef GUILE_DEBUG
 155   scm_iprin1 (SCM_MEMOIZED_EXP (obj), port, pstate);
 156 #else
 157   scm_iprin1 (scm_unmemoize (obj), port, pstate);
 158 #endif
 159   SCM_SET_WRITINGP (pstate, writingp);
 160   scm_putc ('>', port);
 161   return 1;
 162 }
 163
 164 GUILE_PROC (scm_memoized_p, "memoized?", 1, 0, 0,
 165             (SCM obj),
 166 "")
 167 #define FUNC_NAME s_scm_memoized_p
 168 {
 169   return SCM_BOOL(SCM_NIMP (obj) && SCM_MEMOIZEDP (obj));
 170 }
 171 #undef FUNC_NAME
 172
 173 SCM
 174 scm_make_memoized (SCM exp, SCM env)
 175 {
 176   /* *fixme* Check that env is a valid environment. */
 177   register SCM z, ans;
 178   SCM_ENTER_A_SECTION;
 179   SCM_NEWSMOB (z, exp, env);
 180   SCM_NEWSMOB (ans, scm_tc16_memoized, z);
 181   SCM_EXIT_A_SECTION;
 182   return ans;
 183 }
 184
 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
 247  * - constant: SCM_IM_DISPATCH
 248  */
 249
 250 #include "variable.h"
 251 #include "procs.h"
 252
 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
 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
 263     SCM_VALIDATE_VARIABLE(1,var);
 264   if (SCM_UNBNDP (env))
 265     env = scm_top_level_env (SCM_CDR (scm_top_level_lookup_closure_var));
 266   else
 267     SCM_VALIDATE_NULLORCONS(2,env);
 268   return scm_make_memoized (SCM_VARVCELL (var) + 1, env);
 269 }
 270 #undef FUNC_NAME
 271
 272 GUILE_PROC (scm_gloc_p, "gloc?", 1, 0, 0,
 273             (SCM obj),
 274 "")
 275 #define FUNC_NAME s_scm_gloc_p
 276 {
 277   return SCM_BOOL((SCM_NIMP (obj)
 278                    && SCM_MEMOIZEDP (obj)
 279                    && (SCM_MEMOIZED_EXP (obj) & 7) == 1));
 280 }
 281 #undef FUNC_NAME
 282
 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
 287 {
 288   SCM_VALIDATE_INT(1,frame);
 289   SCM_VALIDATE_INT(2,binding)
 290   return (SCM_ILOC00
 291           + SCM_IFRINC * SCM_INUM (frame)
 292           + (SCM_NFALSEP (cdrp) ? SCM_ICDR : 0)
 293           + SCM_IDINC * SCM_INUM (binding));
 294 }
 295 #undef FUNC_NAME
 296
 297 GUILE_PROC (scm_iloc_p, "iloc?", 1, 0, 0,
 298           (SCM obj),
 299 "")
 300 #define FUNC_NAME s_scm_iGUILE_p
 301 {
 302   return SCM_BOOL(SCM_ILOCP (obj));
 303 }
 304 #undef FUNC_NAME
 305
 306 GUILE_PROC (scm_memcons, "memcons", 2, 1, 0,
 307             (SCM car, SCM cdr, SCM env),
 308 "")
 309 #define FUNC_NAME s_scm_memcons
 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)
 315         scm_misc_error (s_memcons,
 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)
 325         scm_misc_error (s_memcons,
 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,
 338                 s_make_iloc);
 339   return scm_make_memoized (scm_cons (car, cdr), env);
 340 }
 341 #undef FUNC_NAME
 342
 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
 347 {
 348   SCM env;
 349   SCM_VALIDATE_MEMOIZED(1,obj);
 350   env = SCM_MEMOIZED_ENV (obj);
 351   obj = SCM_MEMOIZED_EXP (obj);
 352   if (!(SCM_NIMP (obj) && SCM_CAR (obj) == SCM_IM_LAMBDA))
 353     scm_misc_error (s_mem_to_proc,
 354                     "expected lambda expression",
 355                     scm_cons (obj, SCM_EOL));
 356   return scm_closure (SCM_CDR (obj), env);
 357 }
 358 #undef FUNC_NAME
 359
 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
 364 {
 365   SCM_VALIDATE_CLOSURE(1,obj)
 366   return scm_make_memoized (scm_cons (SCM_IM_LAMBDA, SCM_CODE (obj)),
 367                             SCM_ENV (obj));
 368 }
 369 #undef FUNC_NAME
 370
 371 #endif /* GUILE_DEBUG */
 372
 373 GUILE_PROC (scm_unmemoize, "unmemoize", 1, 0, 0,
 374             (SCM m),
 375 "")
 376 #define FUNC_NAME s_scm_unmemoize
 377 {
 378   SCM_VALIDATE_MEMOIZED(1,m);
 379   return scm_unmemocopy (SCM_MEMOIZED_EXP (m), SCM_MEMOIZED_ENV (m));
 380 }
 381 #undef FUNC_NAME
 382
 383 GUILE_PROC (scm_memoized_environment, "memoized-environment", 1, 0, 0,
 384             (SCM m),
 385 "")
 386 #define FUNC_NAME s_scm_memoized_environment
 387 {
 388   SCM_VALIDATE_MEMOIZED(1,m);
 389   return SCM_MEMOIZED_ENV (m);
 390 }
 391 #undef FUNC_NAME
 392
 393 GUILE_PROC (scm_procedure_name, "procedure-name", 1, 0, 0,
 394             (SCM proc),
 395 "")
 396 #define FUNC_NAME s_scm_procedure_name
 397 {
 398   SCM_VALIDATE_PROC(1,proc);
 399   switch (SCM_TYP7 (proc)) {
 400   case scm_tcs_subrs:
 401     return SCM_SNAME (proc);
 402   default:
 403     {
 404       SCM name = scm_procedure_property (proc, scm_sym_name);
 405 #if 0
 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);
 408       if (SCM_FALSEP (name))
 409         name = scm_procedure_property (proc, scm_sym_name);
 410 #endif
 411       if (SCM_FALSEP (name) && SCM_CLOSUREP (proc))
 412         name = scm_reverse_lookup (SCM_ENV (proc), proc);
 413       return name;
 414     }
 415   }
 416 }
 417 #undef FUNC_NAME
 418
 419 GUILE_PROC (scm_procedure_source, "procedure-source", 1, 0, 0,
 420             (SCM proc),
 421 "")
 422 #define FUNC_NAME s_scm_procedure_source
 423 {
 424   SCM_VALIDATE_NIMP(1,proc);
 425   switch (SCM_TYP7 (proc)) {
 426   case scm_tcs_closures:
 427     {
 428       SCM src;
 429       src = scm_source_property (SCM_CDR (SCM_CODE (proc)), scm_sym_copy);
 430       if (src != SCM_BOOL_F)
 431         return scm_cons2 (scm_sym_lambda, SCM_CAR (SCM_CODE (proc)), src);
 432       src = SCM_CODE (proc);
 433       return scm_cons (scm_sym_lambda,
 434                        scm_unmemocopy (src,
 435                                        SCM_EXTEND_ENV (SCM_CAR (src),
 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! */
 446     return scm_procedure_property (proc, scm_sym_source);
 447   default:
 448     SCM_WTA(1,proc);
 449     return 0;
 450   }
 451 }
 452 #undef FUNC_NAME
 453
 454 GUILE_PROC (scm_procedure_environment, "procedure-environment", 1, 0, 0,
 455             (SCM proc),
 456 "")
 457 #define FUNC_NAME s_scm_procedure_environment
 458 {
 459   SCM_VALIDATE_NIMP(1,proc);
 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:
 470     SCM_WTA(1,proc);
 471     return 0;
 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 GUILE_PROC (scm_local_eval, "local-eval", 1, 1, 0,
 485             (SCM exp, SCM env),
 486 "")
 487 #define FUNC_NAME s_scm_local_eval
 488 {
 489   if (SCM_UNBNDP (env))
 490   {
 491     SCM_VALIDATE_MEMOIZED(1,exp);
 492     return scm_eval_3 (SCM_MEMOIZED_EXP (exp), 0, SCM_MEMOIZED_ENV (exp));
 493   }
 494   return scm_eval_3 (exp, 1, env);
 495 }
 496 #undef FUNC_NAME
 497
 498 #if 0
 499 SCM_REGISTER_PROC (s_reverse_lookup, "reverse-lookup", 2, 0, 0, scm_reverse_lookup);
 500 #endif
 501
 502 SCM
 503 scm_reverse_lookup (SCM env, SCM data)
 504 {
 505   SCM names, values;
 506   while (SCM_NIMP (env) && SCM_CONSP (SCM_CAR (env)))
 507     {
 508       names = SCM_CAAR (env);
 509       values = SCM_CDAR (env);
 510       while (SCM_NIMP (names) && SCM_CONSP (names))
 511         {
 512           if (SCM_CAR (values) == data)
 513             return SCM_CAR (names);
 514           names = SCM_CDR (names);
 515           values = SCM_CDR (values);
 516         }
 517       if (names != SCM_EOL && values == data)
 518         return names;
 519       env = SCM_CDR (env);
 520     }
 521   return SCM_BOOL_F;
 522 }
 523
 524 SCM
 525 scm_start_stack (id, exp, env)
 526      SCM id;
 527      SCM exp;
 528      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_eval_3 (exp, 1, 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 (exp, env)
 547      SCM exp;
 548      SCM env;
 549 {
 550   exp = SCM_CDR (exp);
 551   SCM_ASSERT (SCM_NIMP (exp)
 552               && SCM_ECONSP (exp)
 553               && SCM_NIMP (SCM_CDR (exp))
 554               && SCM_ECONSP (SCM_CDR (exp))
 555               && SCM_NULLP (SCM_CDDR (exp)),
 556               exp,
 557               SCM_WNA,
 558               s_start_stack);
 559   return scm_start_stack (scm_eval_car (exp, env), SCM_CADR (exp), env);
 560 }
 561
 562 /* {Debug Objects}
 563  *
 564  * The debugging evaluator throws these on frame traps.
 565  */
 566
 567 long scm_tc16_debugobj;
 568
 569 static int
 570 prindebugobj (SCM obj,SCM port,scm_print_state *pstate)
 571 {
 572   scm_puts ("#<debug-object ", port);
 573   scm_intprint (SCM_DEBUGOBJ_FRAME (obj), 16, port);
 574   scm_putc ('>', port);
 575   return 1;
 576 }
 577
 578 GUILE_PROC (scm_debug_object_p, "debug-object?", 1, 0, 0,
 579             (SCM obj),
 580 "")
 581 #define FUNC_NAME s_scm_debug_object_p
 582 {
 583   return SCM_BOOL(SCM_NIMP (obj) && SCM_DEBUGOBJP (obj));
 584 }
 585 #undef FUNC_NAME
 586
 587
 588 SCM
 589 scm_make_debugobj (scm_debug_frame *frame)
 590 {
 591   register SCM z;
 592   SCM_NEWCELL (z);
 593   SCM_ENTER_A_SECTION;
 594   SCM_SET_DEBUGOBJ_FRAME (z, (SCM) frame);
 595   SCM_SETCAR (z, scm_tc16_debugobj);
 596   SCM_EXIT_A_SECTION;
 597   return z;
 598 }
 599
 600 \f
 601
 602 /* Undocumented debugging procedure */
 603 #ifdef GUILE_DEBUG
 604 GUILE_PROC (scm_debug_hang, "debug-hang", 0, 1, 0,
 605             (SCM obj),
 606 "")
 607 #define FUNC_NAME s_scm_debug_hang
 608 {
 609   int go = 0;
 610   while (!go) ;
 611   return SCM_UNSPECIFIED;
 612 }
 613 #undef FUNC_NAME
 614 #endif
 615
 616 \f
 617
 618 void
 619 scm_init_debug ()
 620 {
 621   scm_init_opts (scm_debug_options, scm_debug_opts, SCM_N_DEBUG_OPTIONS);
 622
 623   scm_tc16_memoized = scm_make_smob_type_mfpe ("memoized", 0,
 624                                               scm_markcdr, NULL, prinmemoized, NULL);
 625
 626   scm_tc16_debugobj = scm_make_smob_type_mfpe ("debug-object", 0,
 627                                               NULL, NULL, prindebugobj, NULL);
 628
 629   scm_sym_procname = SCM_CAR (scm_sysintern ("procname", SCM_UNDEFINED));
 630   scm_sym_dots = SCM_CAR (scm_sysintern ("...", SCM_UNDEFINED));
 631   scm_sym_source = SCM_CAR (scm_sysintern ("source", SCM_UNDEFINED));
 632
 633 #ifdef GUILE_DEBUG
 634   scm_sysintern ("SCM_IM_AND", SCM_IM_AND);
 635   scm_sysintern ("SCM_IM_BEGIN", SCM_IM_BEGIN);
 636   scm_sysintern ("SCM_IM_CASE", SCM_IM_CASE);
 637   scm_sysintern ("SCM_IM_COND", SCM_IM_COND);
 638   scm_sysintern ("SCM_IM_DO", SCM_IM_DO);
 639   scm_sysintern ("SCM_IM_IF", SCM_IM_IF);
 640   scm_sysintern ("SCM_IM_LAMBDA", SCM_IM_LAMBDA);
 641   scm_sysintern ("SCM_IM_LET", SCM_IM_LET);
 642   scm_sysintern ("SCM_IM_LETSTAR", SCM_IM_LETSTAR);
 643   scm_sysintern ("SCM_IM_LETREC", SCM_IM_LETREC);
 644   scm_sysintern ("SCM_IM_OR", SCM_IM_OR);
 645   scm_sysintern ("SCM_IM_QUOTE", SCM_IM_QUOTE);
 646   scm_sysintern ("SCM_IM_SET_X", SCM_IM_SET_X);
 647   scm_sysintern ("SCM_IM_DEFINE", SCM_IM_DEFINE);
 648   scm_sysintern ("SCM_IM_APPLY", SCM_IM_APPLY);
 649   scm_sysintern ("SCM_IM_CONT", SCM_IM_CONT);
 650   scm_sysintern ("SCM_IM_DISPATCH", SCM_IM_DISPATCH);
 651 #endif
 652   scm_add_feature ("debug-extensions");
 653
 654 #include "debug.x"
 655 }