libguile/debug.c

   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       const SCM formals = SCM_CLOSURE_FORMALS (proc);
 333       const SCM body = SCM_CLOSURE_BODY (proc);
 334       const SCM src = scm_source_property (body, scm_sym_copy);
 335
 336       if (!SCM_FALSEP (src))
 337         {
 338           return scm_cons2 (scm_sym_lambda, formals, src);
 339         }
 340       else
 341         {
 342           const SCM env = SCM_EXTEND_ENV (formals, SCM_EOL, SCM_ENV (proc));
 343           return scm_cons2 (scm_sym_lambda,
 344                             scm_i_finite_list_copy (formals),
 345                             scm_unmemocopy (body, env));
 346         }
 347     }
 348   case scm_tcs_struct:
 349     if (!SCM_I_OPERATORP (proc))
 350       break;
 351     goto procprop;
 352   case scm_tc7_smob:
 353     if (!SCM_SMOB_DESCRIPTOR (proc).apply)
 354       break;
 355   case scm_tcs_subrs:
 356 #ifdef CCLO
 357   case scm_tc7_cclo:
 358 #endif
 359   procprop:
 360     /* It would indeed be a nice thing if we supplied source even for
 361        built in procedures! */
 362     return scm_procedure_property (proc, scm_sym_source);
 363   case scm_tc7_pws:
 364     {
 365       SCM src = scm_procedure_property (proc, scm_sym_source);
 366       if (!SCM_FALSEP (src))
 367         return src;
 368       proc = SCM_PROCEDURE (proc);
 369       goto again;
 370     }
 371   default:
 372     ;
 373   }
 374   SCM_WRONG_TYPE_ARG (1, proc);
 375   return SCM_BOOL_F; /* not reached */
 376 }
 377 #undef FUNC_NAME
 378
 379 SCM_DEFINE (scm_procedure_environment, "procedure-environment", 1, 0, 0,
 380             (SCM proc),
 381             "Return the environment of the procedure @var{proc}.")
 382 #define FUNC_NAME s_scm_procedure_environment
 383 {
 384   SCM_VALIDATE_NIM (1, proc);
 385   switch (SCM_TYP7 (proc)) {
 386   case scm_tcs_closures:
 387     return SCM_ENV (proc);
 388   case scm_tcs_subrs:
 389 #ifdef CCLO
 390   case scm_tc7_cclo:
 391 #endif
 392     return SCM_EOL;
 393   default:
 394     SCM_WRONG_TYPE_ARG (1, proc);
 395     /* not reached */
 396   }
 397 }
 398 #undef FUNC_NAME
 399
 400 \f
 401
 402 /* Eval in a local environment.  We would like to have the ability to
 403  * evaluate in a specified local environment, but due to the
 404  * memoization this isn't normally possible.  We solve it by copying
 405  * the code before evaluating.  One solution would be to have eval.c
 406  * generate yet another evaluator.  They are not very big actually.
 407  */
 408 SCM_DEFINE (scm_local_eval, "local-eval", 1, 1, 0,
 409             (SCM exp, SCM env),
 410             "Evaluate @var{exp} in its environment.  If @var{env} is supplied,\n"
 411             "it is the environment in which to evaluate @var{exp}.  Otherwise,\n"
 412             "@var{exp} must be a memoized code object (in which case, its environment\n"
 413             "is implicit).")
 414 #define FUNC_NAME s_scm_local_eval
 415 {
 416   if (SCM_UNBNDP (env))
 417   {
 418     SCM_VALIDATE_MEMOIZED (1, exp);
 419     return scm_i_eval_x (SCM_MEMOIZED_EXP (exp), SCM_MEMOIZED_ENV (exp));
 420   }
 421   return scm_i_eval (exp, env);
 422 }
 423 #undef FUNC_NAME
 424
 425 #if 0
 426 SCM_REGISTER_PROC (s_reverse_lookup, "reverse-lookup", 2, 0, 0, scm_reverse_lookup);
 427 #endif
 428
 429 SCM
 430 scm_reverse_lookup (SCM env, SCM data)
 431 {
 432   while (SCM_CONSP (env) && SCM_CONSP (SCM_CAR (env)))
 433     {
 434       SCM names = SCM_CAAR (env);
 435       SCM values = SCM_CDAR (env);
 436       while (SCM_CONSP (names))
 437         {
 438           if (SCM_EQ_P (SCM_CAR (values), data))
 439             return SCM_CAR (names);
 440           names = SCM_CDR (names);
 441           values = SCM_CDR (values);
 442         }
 443       if (!SCM_NULLP (names) && SCM_EQ_P (values, data))
 444         return names;
 445       env = SCM_CDR (env);
 446     }
 447   return SCM_BOOL_F;
 448 }
 449
 450 SCM
 451 scm_start_stack (SCM id, SCM exp, SCM env)
 452 {
 453   SCM answer;
 454   scm_t_debug_frame vframe;
 455   scm_t_debug_info vframe_vect_body;
 456   vframe.prev = scm_last_debug_frame;
 457   vframe.status = SCM_VOIDFRAME;
 458   vframe.vect = &vframe_vect_body;
 459   vframe.vect[0].id = id;
 460   scm_last_debug_frame = &vframe;
 461   answer = scm_i_eval (exp, env);
 462   scm_last_debug_frame = vframe.prev;
 463   return answer;
 464 }
 465
 466 SCM_SYNTAX(s_start_stack, "start-stack", scm_makacro, scm_m_start_stack);
 467
 468 static SCM
 469 scm_m_start_stack (SCM exp, SCM env)
 470 #define FUNC_NAME s_start_stack
 471 {
 472   exp = SCM_CDR (exp);
 473   if (!SCM_CONSP (exp)
 474       || !SCM_CONSP (SCM_CDR (exp))
 475       || !SCM_NULLP (SCM_CDDR (exp)))
 476     SCM_WRONG_NUM_ARGS ();
 477   return scm_start_stack (scm_eval_car (exp, env), SCM_CADR (exp), env);
 478 }
 479 #undef FUNC_NAME
 480
 481
 482 /* {Debug Objects}
 483  *
 484  * The debugging evaluator throws these on frame traps.
 485  */
 486
 487 scm_t_bits scm_tc16_debugobj;
 488
 489 static int
 490 debugobj_print (SCM obj, SCM port, scm_print_state *pstate SCM_UNUSED)
 491 {
 492   scm_puts ("#<debug-object ", port);
 493   scm_intprint ((long) SCM_DEBUGOBJ_FRAME (obj), 16, port);
 494   scm_putc ('>', port);
 495   return 1;
 496 }
 497
 498 SCM_DEFINE (scm_debug_object_p, "debug-object?", 1, 0, 0,
 499             (SCM obj),
 500             "Return @code{#t} if @var{obj} is a debug object.")
 501 #define FUNC_NAME s_scm_debug_object_p
 502 {
 503   return SCM_BOOL(SCM_DEBUGOBJP (obj));
 504 }
 505 #undef FUNC_NAME
 506
 507
 508 SCM
 509 scm_make_debugobj (scm_t_debug_frame *frame)
 510 {
 511   return scm_cell (scm_tc16_debugobj, (scm_t_bits) frame);
 512 }
 513
 514 \f
 515
 516 /* Undocumented debugging procedure */
 517 #ifdef GUILE_DEBUG
 518 SCM_DEFINE (scm_debug_hang, "debug-hang", 0, 1, 0,
 519             (SCM obj),
 520             "Go into an endless loop, which can be only terminated with\n"
 521             "a debugger.")
 522 #define FUNC_NAME s_scm_debug_hang
 523 {
 524   int go = 0;
 525   while (!go) ;
 526   return SCM_UNSPECIFIED;
 527 }
 528 #undef FUNC_NAME
 529 #endif
 530
 531 \f
 532
 533 void
 534 scm_init_debug ()
 535 {
 536   scm_init_opts (scm_debug_options, scm_debug_opts, SCM_N_DEBUG_OPTIONS);
 537
 538   scm_tc16_memoized = scm_make_smob_type ("memoized", 0);
 539   scm_set_smob_mark (scm_tc16_memoized, scm_markcdr);
 540   scm_set_smob_print (scm_tc16_memoized, memoized_print);
 541
 542   scm_tc16_debugobj = scm_make_smob_type ("debug-object", 0);
 543   scm_set_smob_print (scm_tc16_debugobj, debugobj_print);
 544
 545 #ifdef GUILE_DEBUG
 546   scm_c_define ("SCM_IM_AND", SCM_IM_AND);
 547   scm_c_define ("SCM_IM_BEGIN", SCM_IM_BEGIN);
 548   scm_c_define ("SCM_IM_CASE", SCM_IM_CASE);
 549   scm_c_define ("SCM_IM_COND", SCM_IM_COND);
 550   scm_c_define ("SCM_IM_DO", SCM_IM_DO);
 551   scm_c_define ("SCM_IM_IF", SCM_IM_IF);
 552   scm_c_define ("SCM_IM_LAMBDA", SCM_IM_LAMBDA);
 553   scm_c_define ("SCM_IM_LET", SCM_IM_LET);
 554   scm_c_define ("SCM_IM_LETSTAR", SCM_IM_LETSTAR);
 555   scm_c_define ("SCM_IM_LETREC", SCM_IM_LETREC);
 556   scm_c_define ("SCM_IM_OR", SCM_IM_OR);
 557   scm_c_define ("SCM_IM_QUOTE", SCM_IM_QUOTE);
 558   scm_c_define ("SCM_IM_SET_X", SCM_IM_SET_X);
 559   scm_c_define ("SCM_IM_DEFINE", SCM_IM_DEFINE);
 560   scm_c_define ("SCM_IM_APPLY", SCM_IM_APPLY);
 561   scm_c_define ("SCM_IM_CONT", SCM_IM_CONT);
 562   scm_c_define ("SCM_IM_DISPATCH", SCM_IM_DISPATCH);
 563 #endif
 564   scm_add_feature ("debug-extensions");
 565
 566 #include "libguile/debug.x"
 567 }
 568
 569 /*
 570   Local Variables:
 571   c-file-style: "gnu"
 572   End:
 573 */