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/async.h"
  23 #include "libguile/eval.h"
  24 #include "libguile/list.h"
  25 #include "libguile/stackchk.h"
  26 #include "libguile/throw.h"
  27 #include "libguile/macros.h"
  28 #include "libguile/smob.h"
  29 #include "libguile/procprop.h"
  30 #include "libguile/srcprop.h"
  31 #include "libguile/alist.h"
  32 #include "libguile/continuations.h"
  33 #include "libguile/strports.h"
  34 #include "libguile/read.h"
  35 #include "libguile/feature.h"
  36 #include "libguile/dynwind.h"
  37 #include "libguile/modules.h"
  38 #include "libguile/ports.h"
  39 #include "libguile/root.h"
  40 #include "libguile/fluids.h"
  41 #include "libguile/objects.h"
  42
  43 #include "libguile/validate.h"
  44 #include "libguile/debug.h"
  45 \f
  46
  47 /* {Run time control of the debugging evaluator}
  48  */
  49
  50 SCM_DEFINE (scm_debug_options, "debug-options-interface", 0, 1, 0,
  51             (SCM setting),
  52             "Option interface for the debug options. Instead of using\n"
  53             "this procedure directly, use the procedures @code{debug-enable},\n"
  54             "@code{debug-disable}, @code{debug-set!} and @code{debug-options}.")
  55 #define FUNC_NAME s_scm_debug_options
  56 {
  57   SCM ans;
  58
  59   scm_frame_begin (0);
  60   scm_frame_critical_section (SCM_BOOL_F);
  61
  62   ans = scm_options (setting, scm_debug_opts, SCM_N_DEBUG_OPTIONS, FUNC_NAME);
  63   if (!(1 <= SCM_N_FRAMES && SCM_N_FRAMES <= SCM_MAX_FRAME_SIZE))
  64     {
  65       scm_options (ans, scm_debug_opts, SCM_N_DEBUG_OPTIONS, FUNC_NAME);
  66       SCM_OUT_OF_RANGE (1, setting);
  67     }
  68   SCM_RESET_DEBUG_MODE;
  69   scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
  70   scm_debug_eframe_size = 2 * SCM_N_FRAMES;
  71
  72   scm_frame_end ();
  73   return ans;
  74 }
  75 #undef FUNC_NAME
  76
  77 static void
  78 with_traps_before (void *data)
  79 {
  80   int *trap_flag = data;
  81   *trap_flag = SCM_TRAPS_P;
  82   SCM_TRAPS_P = 1;
  83 }
  84
  85 static void
  86 with_traps_after (void *data)
  87 {
  88   int *trap_flag = data;
  89   SCM_TRAPS_P = *trap_flag;
  90 }
  91
  92 static SCM
  93 with_traps_inner (void *data)
  94 {
  95   SCM thunk = SCM_PACK ((scm_t_bits) data);
  96   return scm_call_0 (thunk);
  97 }
  98
  99 SCM_DEFINE (scm_with_traps, "with-traps", 1, 0, 0,
 100             (SCM thunk),
 101             "Call @var{thunk} with traps enabled.")
 102 #define FUNC_NAME s_scm_with_traps
 103 {
 104   int trap_flag;
 105   SCM_VALIDATE_THUNK (1, thunk);
 106   return scm_internal_dynamic_wind (with_traps_before,
 107                                     with_traps_inner,
 108                                     with_traps_after,
 109                                     (void *) SCM_UNPACK (thunk),
 110                                     &trap_flag);
 111 }
 112 #undef FUNC_NAME
 113
 114 \f
 115
 116 SCM_SYMBOL (scm_sym_procname, "procname");
 117 SCM_SYMBOL (scm_sym_dots, "...");
 118 SCM_SYMBOL (scm_sym_source, "source");
 119
 120 /* {Memoized Source}
 121  */
 122
 123 scm_t_bits scm_tc16_memoized;
 124
 125 static int
 126 memoized_print (SCM obj, SCM port, scm_print_state *pstate)
 127 {
 128   int writingp = SCM_WRITINGP (pstate);
 129   scm_puts ("#<memoized ", port);
 130   SCM_SET_WRITINGP (pstate, 1);
 131   scm_iprin1 (SCM_MEMOIZED_EXP (obj), port, pstate);
 132   SCM_SET_WRITINGP (pstate, writingp);
 133   scm_putc ('>', port);
 134   return 1;
 135 }
 136
 137 SCM_DEFINE (scm_memoized_p, "memoized?", 1, 0, 0,
 138             (SCM obj),
 139             "Return @code{#t} if @var{obj} is memoized.")
 140 #define FUNC_NAME s_scm_memoized_p
 141 {
 142   return scm_from_bool(SCM_MEMOIZEDP (obj));
 143 }
 144 #undef FUNC_NAME
 145
 146 SCM
 147 scm_make_memoized (SCM exp, SCM env)
 148 {
 149   /* *fixme* Check that env is a valid environment. */
 150   SCM_RETURN_NEWSMOB (scm_tc16_memoized, SCM_UNPACK (scm_cons (exp, env)));
 151 }
 152
 153 #ifdef GUILE_DEBUG
 154 /*
 155  * Some primitives for construction of memoized code
 156  *
 157  * - procedure: memcons CAR CDR [ENV]
 158  *
 159  *     Construct a pair, encapsulated in a memoized object.
 160  *
 161  *     The CAR and CDR can be either normal or memoized.  If ENV isn't
 162  *     specified, the top-level environment of the current module will
 163  *     be assumed.  All environments must match.
 164  *
 165  * - procedure: make-iloc FRAME BINDING CDRP
 166  *
 167  *     Return an iloc referring to frame no. FRAME, binding
 168  *     no. BINDING.  If CDRP is non-#f, the iloc is referring to a
 169  *     frame consisting of a single pair, with the value stored in the
 170  *     CDR.
 171  *
 172  * - procedure: iloc? OBJECT
 173  *
 174  *     Return #t if OBJECT is an iloc.
 175  *
 176  * - procedure: mem->proc MEMOIZED
 177  *
 178  *     Construct a closure from the memoized lambda expression MEMOIZED
 179  *
 180  *     WARNING! The code is not copied!
 181  *
 182  * - procedure: proc->mem CLOSURE
 183  *
 184  *     Turn the closure CLOSURE into a memoized object.
 185  *
 186  *     WARNING! The code is not copied!
 187  *
 188  * - constant: SCM_IM_AND
 189  * - constant: SCM_IM_BEGIN
 190  * - constant: SCM_IM_CASE
 191  * - constant: SCM_IM_COND
 192  * - constant: SCM_IM_DO
 193  * - constant: SCM_IM_IF
 194  * - constant: SCM_IM_LAMBDA
 195  * - constant: SCM_IM_LET
 196  * - constant: SCM_IM_LETSTAR
 197  * - constant: SCM_IM_LETREC
 198  * - constant: SCM_IM_OR
 199  * - constant: SCM_IM_QUOTE
 200  * - constant: SCM_IM_SET
 201  * - constant: SCM_IM_DEFINE
 202  * - constant: SCM_IM_APPLY
 203  * - constant: SCM_IM_CONT
 204  * - constant: SCM_IM_DISPATCH
 205  */
 206
 207 #include "libguile/variable.h"
 208 #include "libguile/procs.h"
 209
 210 SCM_DEFINE (scm_memcons, "memcons", 2, 1, 0,
 211             (SCM car, SCM cdr, SCM env),
 212             "Return a new memoized cons cell with @var{car} and @var{cdr}\n"
 213             "as members and @var{env} as the environment.")
 214 #define FUNC_NAME s_scm_memcons
 215 {
 216   if (SCM_MEMOIZEDP (car))
 217     {
 218       /*fixme* environments may be two different but equal top-level envs */
 219       if (!SCM_UNBNDP (env) && SCM_MEMOIZED_ENV (car) != env)
 220         SCM_MISC_ERROR ("environment mismatch arg1 <-> arg3",
 221                         scm_list_2 (car, env));
 222       else
 223         env = SCM_MEMOIZED_ENV (car);
 224       car = SCM_MEMOIZED_EXP (car);
 225     }
 226   if (SCM_MEMOIZEDP (cdr))
 227     {
 228       if (!SCM_UNBNDP (env) && SCM_MEMOIZED_ENV (cdr) != env)
 229         SCM_MISC_ERROR ("environment mismatch arg2 <-> arg3",
 230                         scm_list_2 (cdr, env));
 231       else
 232         env = SCM_MEMOIZED_ENV (cdr);
 233       cdr = SCM_MEMOIZED_EXP (cdr);
 234     }
 235   if (SCM_UNBNDP (env))
 236     env = scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE);
 237   else
 238     SCM_VALIDATE_NULLORCONS (3, env);
 239   return scm_make_memoized (scm_cons (car, cdr), env);
 240 }
 241 #undef FUNC_NAME
 242
 243 SCM_DEFINE (scm_mem_to_proc, "mem->proc", 1, 0, 0,
 244             (SCM obj),
 245             "Convert a memoized object (which must represent a body)\n"
 246             "to a procedure.")
 247 #define FUNC_NAME s_scm_mem_to_proc
 248 {
 249   SCM env;
 250   SCM_VALIDATE_MEMOIZED (1, obj);
 251   env = SCM_MEMOIZED_ENV (obj);
 252   obj = SCM_MEMOIZED_EXP (obj);
 253   return scm_closure (obj, env);
 254 }
 255 #undef FUNC_NAME
 256
 257 SCM_DEFINE (scm_proc_to_mem, "proc->mem", 1, 0, 0,
 258             (SCM obj),
 259             "Convert a procedure to a memoized object.")
 260 #define FUNC_NAME s_scm_proc_to_mem
 261 {
 262   SCM_VALIDATE_CLOSURE (1, obj);
 263   return scm_make_memoized (SCM_CODE (obj), SCM_ENV (obj));
 264 }
 265 #undef FUNC_NAME
 266
 267 #endif /* GUILE_DEBUG */
 268
 269 SCM_DEFINE (scm_i_unmemoize_expr, "unmemoize-expr", 1, 0, 0,
 270             (SCM m),
 271             "Unmemoize the memoized expression @var{m},")
 272 #define FUNC_NAME s_scm_i_unmemoize_expr
 273 {
 274   SCM_VALIDATE_MEMOIZED (1, m);
 275   return scm_i_unmemocopy_expr (SCM_MEMOIZED_EXP (m), SCM_MEMOIZED_ENV (m));
 276 }
 277 #undef FUNC_NAME
 278
 279 SCM_DEFINE (scm_memoized_environment, "memoized-environment", 1, 0, 0,
 280             (SCM m),
 281             "Return the environment of the memoized expression @var{m}.")
 282 #define FUNC_NAME s_scm_memoized_environment
 283 {
 284   SCM_VALIDATE_MEMOIZED (1, m);
 285   return SCM_MEMOIZED_ENV (m);
 286 }
 287 #undef FUNC_NAME
 288
 289 SCM_DEFINE (scm_procedure_name, "procedure-name", 1, 0, 0,
 290             (SCM proc),
 291             "Return the name of the procedure @var{proc}")
 292 #define FUNC_NAME s_scm_procedure_name
 293 {
 294   SCM_VALIDATE_PROC (1, proc);
 295   switch (SCM_TYP7 (proc)) {
 296   case scm_tcs_subrs:
 297     return SCM_SNAME (proc);
 298   default:
 299     {
 300       SCM name = scm_procedure_property (proc, scm_sym_name);
 301 #if 0
 302       /* Source property scm_sym_procname not implemented yet... */
 303       SCM name = scm_source_property (SCM_CAR (SCM_CLOSURE_BODY (proc)), scm_sym_procname);
 304       if (scm_is_false (name))
 305         name = scm_procedure_property (proc, scm_sym_name);
 306 #endif
 307       if (scm_is_false (name) && SCM_CLOSUREP (proc))
 308         name = scm_reverse_lookup (SCM_ENV (proc), proc);
 309       return name;
 310     }
 311   }
 312 }
 313 #undef FUNC_NAME
 314
 315 SCM_DEFINE (scm_procedure_source, "procedure-source", 1, 0, 0,
 316             (SCM proc),
 317             "Return the source of the procedure @var{proc}.")
 318 #define FUNC_NAME s_scm_procedure_source
 319 {
 320   SCM_VALIDATE_NIM (1, proc);
 321  again:
 322   switch (SCM_TYP7 (proc)) {
 323   case scm_tcs_closures:
 324     {
 325       const SCM formals = SCM_CLOSURE_FORMALS (proc);
 326       const SCM body = SCM_CLOSURE_BODY (proc);
 327       const SCM src = scm_source_property (body, scm_sym_copy);
 328
 329       if (scm_is_true (src))
 330         {
 331           return scm_cons2 (scm_sym_lambda, formals, src);
 332         }
 333       else
 334         {
 335           const SCM env = SCM_EXTEND_ENV (formals, SCM_EOL, SCM_ENV (proc));
 336           return scm_cons2 (scm_sym_lambda,
 337                             scm_i_finite_list_copy (formals),
 338                             scm_i_unmemocopy_body (body, env));
 339         }
 340     }
 341   case scm_tcs_struct:
 342     if (!SCM_I_OPERATORP (proc))
 343       break;
 344     goto procprop;
 345   case scm_tc7_smob:
 346     if (!SCM_SMOB_DESCRIPTOR (proc).apply)
 347       break;
 348   case scm_tcs_subrs:
 349 #ifdef CCLO
 350   case scm_tc7_cclo:
 351 #endif
 352   procprop:
 353     /* It would indeed be a nice thing if we supplied source even for
 354        built in procedures! */
 355     return scm_procedure_property (proc, scm_sym_source);
 356   case scm_tc7_pws:
 357     {
 358       SCM src = scm_procedure_property (proc, scm_sym_source);
 359       if (scm_is_true (src))
 360         return src;
 361       proc = SCM_PROCEDURE (proc);
 362       goto again;
 363     }
 364   default:
 365     ;
 366   }
 367   SCM_WRONG_TYPE_ARG (1, proc);
 368   return SCM_BOOL_F; /* not reached */
 369 }
 370 #undef FUNC_NAME
 371
 372 SCM_DEFINE (scm_procedure_environment, "procedure-environment", 1, 0, 0,
 373             (SCM proc),
 374             "Return the environment of the procedure @var{proc}.")
 375 #define FUNC_NAME s_scm_procedure_environment
 376 {
 377   SCM_VALIDATE_NIM (1, proc);
 378   switch (SCM_TYP7 (proc)) {
 379   case scm_tcs_closures:
 380     return SCM_ENV (proc);
 381   case scm_tcs_subrs:
 382 #ifdef CCLO
 383   case scm_tc7_cclo:
 384 #endif
 385     return SCM_EOL;
 386   default:
 387     SCM_WRONG_TYPE_ARG (1, proc);
 388     /* not reached */
 389   }
 390 }
 391 #undef FUNC_NAME
 392
 393 \f
 394
 395 /* Eval in a local environment.  We would like to have the ability to
 396  * evaluate in a specified local environment, but due to the
 397  * memoization this isn't normally possible.  We solve it by copying
 398  * the code before evaluating.  One solution would be to have eval.c
 399  * generate yet another evaluator.  They are not very big actually.
 400  */
 401 SCM_DEFINE (scm_local_eval, "local-eval", 1, 1, 0,
 402             (SCM exp, SCM env),
 403             "Evaluate @var{exp} in its environment.  If @var{env} is supplied,\n"
 404             "it is the environment in which to evaluate @var{exp}.  Otherwise,\n"
 405             "@var{exp} must be a memoized code object (in which case, its environment\n"
 406             "is implicit).")
 407 #define FUNC_NAME s_scm_local_eval
 408 {
 409   if (SCM_UNBNDP (env))
 410   {
 411     SCM_VALIDATE_MEMOIZED (1, exp);
 412     return scm_i_eval_x (SCM_MEMOIZED_EXP (exp), SCM_MEMOIZED_ENV (exp));
 413   }
 414   return scm_i_eval (exp, env);
 415 }
 416 #undef FUNC_NAME
 417
 418 #if 0
 419 SCM_REGISTER_PROC (s_reverse_lookup, "reverse-lookup", 2, 0, 0, scm_reverse_lookup);
 420 #endif
 421
 422 SCM
 423 scm_reverse_lookup (SCM env, SCM data)
 424 {
 425   while (scm_is_pair (env) && scm_is_pair (SCM_CAR (env)))
 426     {
 427       SCM names = SCM_CAAR (env);
 428       SCM values = SCM_CDAR (env);
 429       while (scm_is_pair (names))
 430         {
 431           if (scm_is_eq (SCM_CAR (values), data))
 432             return SCM_CAR (names);
 433           names = SCM_CDR (names);
 434           values = SCM_CDR (values);
 435         }
 436       if (!scm_is_null (names) && scm_is_eq (values, data))
 437         return names;
 438       env = SCM_CDR (env);
 439     }
 440   return SCM_BOOL_F;
 441 }
 442
 443 SCM
 444 scm_start_stack (SCM id, SCM exp, SCM env)
 445 {
 446   SCM answer;
 447   scm_t_debug_frame vframe;
 448   scm_t_debug_info vframe_vect_body;
 449   vframe.prev = scm_i_last_debug_frame ();
 450   vframe.status = SCM_VOIDFRAME;
 451   vframe.vect = &vframe_vect_body;
 452   vframe.vect[0].id = id;
 453   scm_i_set_last_debug_frame (&vframe);
 454   answer = scm_i_eval (exp, env);
 455   scm_i_set_last_debug_frame (vframe.prev);
 456   return answer;
 457 }
 458
 459 SCM_SYNTAX(s_start_stack, "start-stack", scm_makacro, scm_m_start_stack);
 460
 461 static SCM
 462 scm_m_start_stack (SCM exp, SCM env)
 463 #define FUNC_NAME s_start_stack
 464 {
 465   exp = SCM_CDR (exp);
 466   if (!scm_is_pair (exp)
 467       || !scm_is_pair (SCM_CDR (exp))
 468       || !scm_is_null (SCM_CDDR (exp)))
 469     SCM_WRONG_NUM_ARGS ();
 470   return scm_start_stack (scm_eval_car (exp, env), SCM_CADR (exp), env);
 471 }
 472 #undef FUNC_NAME
 473
 474
 475 /* {Debug Objects}
 476  *
 477  * The debugging evaluator throws these on frame traps.
 478  */
 479
 480 scm_t_bits scm_tc16_debugobj;
 481
 482 static int
 483 debugobj_print (SCM obj, SCM port, scm_print_state *pstate SCM_UNUSED)
 484 {
 485   scm_puts ("#<debug-object ", port);
 486   scm_intprint ((long) SCM_DEBUGOBJ_FRAME (obj), 16, port);
 487   scm_putc ('>', port);
 488   return 1;
 489 }
 490
 491 SCM_DEFINE (scm_debug_object_p, "debug-object?", 1, 0, 0,
 492             (SCM obj),
 493             "Return @code{#t} if @var{obj} is a debug object.")
 494 #define FUNC_NAME s_scm_debug_object_p
 495 {
 496   return scm_from_bool(SCM_DEBUGOBJP (obj));
 497 }
 498 #undef FUNC_NAME
 499
 500
 501 SCM
 502 scm_make_debugobj (scm_t_debug_frame *frame)
 503 {
 504   return scm_cell (scm_tc16_debugobj, (scm_t_bits) frame);
 505 }
 506
 507 \f
 508
 509 /* Undocumented debugging procedure */
 510 #ifdef GUILE_DEBUG
 511 SCM_DEFINE (scm_debug_hang, "debug-hang", 0, 1, 0,
 512             (SCM obj),
 513             "Go into an endless loop, which can be only terminated with\n"
 514             "a debugger.")
 515 #define FUNC_NAME s_scm_debug_hang
 516 {
 517   int go = 0;
 518   while (!go) ;
 519   return SCM_UNSPECIFIED;
 520 }
 521 #undef FUNC_NAME
 522 #endif
 523
 524 \f
 525
 526 void
 527 scm_init_debug ()
 528 {
 529   scm_init_opts (scm_debug_options, scm_debug_opts, SCM_N_DEBUG_OPTIONS);
 530
 531   scm_tc16_memoized = scm_make_smob_type ("memoized", 0);
 532   scm_set_smob_mark (scm_tc16_memoized, scm_markcdr);
 533   scm_set_smob_print (scm_tc16_memoized, memoized_print);
 534
 535   scm_tc16_debugobj = scm_make_smob_type ("debug-object", 0);
 536   scm_set_smob_print (scm_tc16_debugobj, debugobj_print);
 537
 538 #ifdef GUILE_DEBUG
 539   scm_c_define ("SCM_IM_AND", SCM_IM_AND);
 540   scm_c_define ("SCM_IM_BEGIN", SCM_IM_BEGIN);
 541   scm_c_define ("SCM_IM_CASE", SCM_IM_CASE);
 542   scm_c_define ("SCM_IM_COND", SCM_IM_COND);
 543   scm_c_define ("SCM_IM_DO", SCM_IM_DO);
 544   scm_c_define ("SCM_IM_IF", SCM_IM_IF);
 545   scm_c_define ("SCM_IM_LAMBDA", SCM_IM_LAMBDA);
 546   scm_c_define ("SCM_IM_LET", SCM_IM_LET);
 547   scm_c_define ("SCM_IM_LETSTAR", SCM_IM_LETSTAR);
 548   scm_c_define ("SCM_IM_LETREC", SCM_IM_LETREC);
 549   scm_c_define ("SCM_IM_OR", SCM_IM_OR);
 550   scm_c_define ("SCM_IM_QUOTE", SCM_IM_QUOTE);
 551   scm_c_define ("SCM_IM_SET_X", SCM_IM_SET_X);
 552   scm_c_define ("SCM_IM_DEFINE", SCM_IM_DEFINE);
 553   scm_c_define ("SCM_IM_APPLY", SCM_IM_APPLY);
 554   scm_c_define ("SCM_IM_CONT", SCM_IM_CONT);
 555   scm_c_define ("SCM_IM_DISPATCH", SCM_IM_DISPATCH);
 556 #endif
 557   scm_add_feature ("debug-extensions");
 558
 559 #include "libguile/debug.x"
 560 }
 561
 562 /*
 563   Local Variables:
 564   c-file-style: "gnu"
 565   End:
 566 */