guile18/libguile/debug.c

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