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