libguile/debug.c

   1 /* Debugging extensions for Guile
   2  * Copyright (C) 1995, 1996 Mikael Djurfeldt
   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, 675 Mass Ave, Cambridge, MA 02139, USA.
  17  *
  18  * As a special exception, the Free Software Foundation gives permission
  19  * for additional uses of the text contained in its release of GUILE.
  20  *
  21  * The exception is that, if you link the GUILE library with other files
  22  * to produce an executable, this does not by itself cause the
  23  * resulting executable to be covered by the GNU General Public License.
  24  * Your use of that executable is in no way restricted on account of
  25  * linking the GUILE library code into it.
  26  *
  27  * This exception does not however invalidate any other reasons why
  28  * the executable file might be covered by the GNU General Public License.
  29  *
  30  * This exception applies only to the code released by the
  31  * Free Software Foundation under the name GUILE.  If you copy
  32  * code from other Free Software Foundation releases into a copy of
  33  * GUILE, as the General Public License permits, the exception does
  34  * not apply to the code that you add in this way.  To avoid misleading
  35  * anyone as to the status of such modified files, you must delete
  36  * this exception notice from them.
  37  *
  38  * If you write modifications of your own for GUILE, it is your choice
  39  * whether to permit this exception to apply to your modifications.
  40  * If you do not wish that, delete this exception notice.
  41  *
  42  * The author can be reached at djurfeldt@nada.kth.se
  43  * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
  44  */
  45
  46 #include <stdio.h>
  47 #include "_scm.h"
  48 #include "eval.h"
  49 #include "throw.h"
  50 #include "genio.h"
  51 #include "smob.h"
  52 #include "procprop.h"
  53 #include "srcprop.h"
  54 #include "alist.h"
  55 #include "continuations.h"
  56 #include "strports.h"
  57 #include "read.h"
  58 #include "feature.h"
  59
  60 #include "debug.h"
  61 \f
  62
  63 /* {Run time control of the debugging evaluator}
  64  */
  65
  66 SCM_PROC (s_debug_options, "debug-options-interface", 0, 1, 0, scm_debug_options);
  67
  68 SCM
  69 scm_debug_options (setting)
  70      SCM setting;
  71 {
  72   SCM ans;
  73   SCM_DEFER_INTS;
  74   ans = scm_options (setting,
  75                      scm_debug_opts,
  76                      SCM_N_DEBUG_OPTIONS,
  77                      s_debug_options);
  78 #ifndef SCM_RECKLESS
  79   if (!(1 <= SCM_N_FRAMES && SCM_N_FRAMES <= SCM_MAX_FRAME_SIZE))
  80     {
  81       scm_options (ans, scm_debug_opts, SCM_N_DEBUG_OPTIONS, s_debug_options);
  82       scm_out_of_range (s_debug_options, setting);
  83     }
  84 #endif
  85   SCM_RESET_DEBUG_MODE;
  86   scm_debug_eframe_size = 2 * SCM_N_FRAMES;
  87   SCM_ALLOW_INTS
  88   return ans;
  89 }
  90
  91 SCM_PROC (s_evaluator_traps, "evaluator-traps-interface", 0, 1, 0, scm_evaluator_traps);
  92
  93 SCM
  94 scm_evaluator_traps (setting)
  95      SCM setting;
  96 {
  97   SCM ans;
  98   SCM_DEFER_INTS;
  99   ans = scm_options (setting,
 100                      scm_evaluator_trap_table,
 101                      SCM_N_EVALUATOR_TRAPS,
 102                      s_evaluator_traps);
 103   SCM_RESET_DEBUG_MODE;
 104   SCM_ALLOW_INTS
 105   return ans;
 106 }
 107
 108 SCM_PROC (s_single_step, "single-step", 2, 0, 0, scm_single_step);
 109
 110 SCM
 111 scm_single_step (cont, val)
 112      SCM cont;
 113      SCM val;
 114 {
 115   SCM_DEFER_INTS;
 116   SCM_ENTER_FRAME_P = SCM_EXIT_FRAME_P = 1;
 117   SCM_RESET_DEBUG_MODE;
 118   SCM_ALLOW_INTS;
 119   scm_throw (cont, val);
 120   return SCM_BOOL_F; /* never returns */
 121 }
 122
 123 \f
 124 static SCM scm_i_source, scm_i_more;
 125 static SCM scm_i_proc, scm_i_args, scm_i_eval_args;
 126 static SCM scm_i_procname;
 127
 128 /* {Memoized Source}
 129  */
 130
 131 long scm_tc16_memoized;
 132
 133
 134 static int prinmemoized SCM_P ((SCM obj, SCM port, scm_print_state *pstate));
 135
 136 static int
 137 prinmemoized (obj, port, pstate)
 138      SCM obj;
 139      SCM port;
 140      scm_print_state *pstate;
 141 {
 142   int writingp = SCM_WRITINGP (pstate);
 143   scm_gen_puts (scm_regular_string, "#<memoized ", port);
 144   SCM_SET_WRITINGP (pstate, 1);
 145   scm_iprin1 (scm_unmemoize (obj), port, pstate);
 146   SCM_SET_WRITINGP (pstate, writingp);
 147   scm_gen_putc ('>', port);
 148   return 1;
 149 }
 150
 151 static scm_smobfuns memoizedsmob =
 152 {scm_markcdr, scm_free0, prinmemoized, 0};
 153
 154 SCM_PROC (s_memoized_p, "memoized?", 1, 0, 0, scm_memoized_p);
 155
 156 SCM
 157 scm_memoized_p (obj)
 158      SCM obj;
 159 {
 160   return SCM_NIMP (obj) && SCM_MEMOIZEDP (obj) ? SCM_BOOL_T : SCM_BOOL_F;
 161 }
 162
 163
 164 SCM
 165 scm_make_memoized (exp, env)
 166      SCM exp;
 167      SCM env;
 168 {
 169   register SCM z, ans;
 170   SCM_DEFER_INTS;
 171   SCM_NEWCELL (z);
 172   SCM_CAR (z) = exp;
 173   SCM_CDR (z) = env;
 174   SCM_NEWCELL (ans);
 175   SCM_CAR (ans) = scm_tc16_memoized;
 176   SCM_CDR (ans) = z;
 177   SCM_ALLOW_INTS;
 178   return ans;
 179 }
 180
 181 SCM_PROC (s_unmemoize, "unmemoize", 1, 0, 0, scm_unmemoize);
 182
 183 SCM
 184 scm_unmemoize (m)
 185      SCM m;
 186 {
 187   SCM_ASSERT (SCM_MEMOIZEDP (m), m, SCM_ARG1, s_unmemoize);
 188   return scm_unmemocopy (SCM_MEMOEXP (m), SCM_MEMOENV (m));
 189 }
 190
 191 SCM_PROC (s_memoized_environment, "memoized-environment", 1, 0, 0, scm_memoized_environment);
 192
 193 SCM
 194 scm_memoized_environment (m)
 195      SCM m;
 196 {
 197   SCM_ASSERT (SCM_MEMOIZEDP (m), m, SCM_ARG1, s_unmemoize);
 198   return SCM_MEMOENV (m);
 199 }
 200
 201 SCM_PROC (s_procedure_name, "procedure-name", 1, 0, 0, scm_procedure_name);
 202
 203 SCM
 204 scm_procedure_name (proc)
 205      SCM proc;
 206 {
 207   SCM_ASSERT(scm_procedure_p (proc) == SCM_BOOL_T,
 208              proc,
 209              SCM_ARG1,
 210              s_procedure_name);
 211   switch (SCM_TYP7 (proc)) {
 212   case scm_tcs_closures:
 213     {
 214       SCM name = scm_procedure_property (proc, scm_i_name);
 215 #if 0
 216       /* Procedure property scm_i_procname not implemented yet... */
 217       SCM name = scm_source_property (SCM_CAR (SCM_CDR (SCM_CODE (proc))), scm_i_procname);
 218       if (SCM_FALSEP (name))
 219         name = scm_procedure_property (proc, scm_i_name);
 220 #endif
 221       return name;
 222     }
 223   case scm_tcs_subrs:
 224     return SCM_SNAME (proc);
 225   default:
 226     return SCM_BOOL_F;
 227   }
 228 }
 229
 230 SCM_PROC (s_procedure_source, "procedure-source", 1, 0, 0, scm_procedure_source);
 231
 232 SCM
 233 scm_procedure_source (proc)
 234      SCM proc;
 235 {
 236   SCM_ASSERT(SCM_NIMP (proc), proc, SCM_ARG1, s_procedure_source);
 237   switch (SCM_TYP7 (proc)) {
 238   case scm_tcs_closures:
 239     {
 240       SCM src;
 241       src = scm_source_property (SCM_CDR (SCM_CODE (proc)), scm_i_copy);
 242       if (src != SCM_BOOL_F)
 243         return scm_cons2 (scm_i_lambda, SCM_CAR (SCM_CODE (proc)), src);
 244       src = SCM_CODE (proc);
 245       return scm_cons (scm_i_lambda,
 246                        scm_unmemocopy (src,
 247                                        SCM_EXTEND_ENV (SCM_CAR (src),
 248                                                            SCM_EOL,
 249                                                            SCM_ENV (proc))));
 250     }
 251   case scm_tc7_contin:
 252   case scm_tcs_subrs:
 253 #ifdef CCLO
 254   case scm_tc7_cclo:
 255 #endif
 256     /* It would indeed be a nice thing if we supplied source even for
 257        built in procedures! */
 258     return scm_procedure_property (proc, scm_i_source);
 259   default:
 260     scm_wta (proc, (char *) SCM_ARG1, s_procedure_source);
 261     return 0;
 262   }
 263 }
 264
 265 SCM_PROC (s_procedure_environment, "procedure-environment", 1, 0, 0, scm_procedure_environment);
 266
 267 SCM
 268 scm_procedure_environment (proc)
 269      SCM proc;
 270 {
 271   SCM_ASSERT (SCM_NIMP (proc), proc, SCM_ARG1, s_procedure_environment);
 272   switch (SCM_TYP7 (proc)) {
 273   case scm_tcs_closures:
 274     return SCM_ENV (proc);
 275   case scm_tc7_contin:
 276   case scm_tcs_subrs:
 277 #ifdef CCLO
 278   case scm_tc7_cclo:
 279 #endif
 280     return SCM_EOL;
 281   default:
 282     scm_wta (proc, (char *) SCM_ARG1, s_procedure_environment);
 283     return 0;
 284   }
 285 }
 286
 287
 288 /* Eval in a local environment.  We would like to have the ability to
 289  * evaluate in a specified local environment, but due to the memoization
 290  * this isn't normally possible.  We solve it by copying the code before
 291  * evaluating.  Probably the best solution would be to have eval.c generate
 292  * yet another evaluator.  They are not very big actually.
 293  */
 294 SCM_PROC (s_local_eval, "local-eval", 2, 0, 0, scm_local_eval);
 295
 296 SCM
 297 scm_local_eval (exp, env)
 298      SCM exp;
 299      SCM env;
 300 {
 301   return scm_eval_3 (exp, 1, env);
 302 }
 303
 304 /* {Stack Frames}
 305  *
 306  * The stack is a list of stackframes, from root to current.
 307  *
 308  * A stackframe is a list of virtual stackframes, which occur due to
 309  * the evaluators tail recursion.  A virtual stackframe normally
 310  * corresponds to an eval/apply pair, but macros and special forms
 311  * (which are implemented as macros in scm...) only have eval
 312  * information and apply calls leads to apply only frames.
 313  *
 314  * A virtual stackframe is either a property list or the symbol
 315  * ... which marks the location of virtual stackframes which could not
 316  * be stored with the current debug-depth.
 317  *
 318  * Property     Type            Description
 319  *
 320  * These three only present in eval frames:
 321  *
 322  * sexpr        memoized        Source code expression and environment.
 323  * proc         procedure       The procedure being applied.
 324  *                              (Not present if pre-apply state.)
 325  * args         list            The arguments evaluated so far.
 326  * eval-args    boolean         True if evaluation of arguments not finished.
 327  */
 328
 329 /* {Debug Objects}
 330  *
 331  * The debugging evaluator throws these on frame traps.
 332  */
 333
 334 long scm_tc16_debugobj;
 335
 336 #define DEBUGOBJP(x) (scm_tc16_debugobj == SCM_TYP16 (x))
 337 #define DBGFRAME(x) SCM_CDR (x)
 338
 339
 340 static int prindebugobj SCM_P ((SCM obj, SCM port, scm_print_state *pstate));
 341
 342 static int
 343 prindebugobj (obj, port, pstate)
 344      SCM obj;
 345      SCM port;
 346      scm_print_state *pstate;
 347 {
 348   scm_gen_puts (scm_regular_string, "#<debug-object ", port);
 349   scm_intprint (DBGFRAME (obj), 16, port);
 350   scm_gen_putc ('>', port);
 351   return 1;
 352 }
 353
 354 static scm_smobfuns debugobjsmob =
 355 {scm_mark0, scm_free0, prindebugobj, 0};
 356
 357 SCM_PROC (s_debug_object_p, "debug-object?", 1, 0, 0, scm_debug_object_p);
 358
 359 SCM
 360 scm_debug_object_p (obj)
 361      SCM obj;
 362 {
 363   return SCM_NIMP (obj) && DEBUGOBJP (obj) ? SCM_BOOL_T : SCM_BOOL_F;
 364 }
 365
 366
 367 SCM
 368 scm_make_debugobj (frame)
 369      scm_debug_frame *frame;
 370 {
 371   register SCM z;
 372   SCM_DEFER_INTS;
 373   SCM_NEWCELL (z);
 374   SCM_CAR (z) = scm_tc16_debugobj;
 375   DBGFRAME (z) = (SCM) frame;
 376   SCM_ALLOW_INTS;
 377   return z;
 378 }
 379
 380
 381 static SCM _scm_stack_frame_to_plist SCM_P ((scm_debug_frame *frame, long offset));
 382
 383 static SCM
 384 _scm_stack_frame_to_plist (frame, offset)
 385      scm_debug_frame *frame;
 386      long offset;
 387 {
 388   int size;
 389   scm_debug_info *info;
 390   if (SCM_EVALFRAMEP (*frame))
 391     {
 392       size = frame->status & SCM_MAX_FRAME_SIZE;
 393       info = (scm_debug_info *) (*((SCM_STACKITEM **) &frame->vect[size]) + offset);
 394       if ((info - frame->vect) & 1)
 395         {
 396           /* Debug.vect ends with apply info. */
 397           SCM p;
 398           --info;
 399           if (info[1].a.proc == SCM_UNDEFINED)
 400             p = SCM_EOL;
 401           else
 402             p = scm_acons (scm_i_proc,
 403                            info[1].a.proc,
 404                            scm_acons (scm_i_args,
 405                                       info[1].a.args,
 406                                       SCM_ARGS_READY_P (*frame)
 407                                       ? SCM_EOL
 408                                       : scm_acons (scm_i_eval_args,
 409                                                    SCM_BOOL_T,
 410                                                    SCM_EOL)));
 411           return scm_acons (scm_i_source,
 412                             scm_make_memoized (info[0].e.exp, info[0].e.env),
 413                             p);
 414         }
 415       else
 416         /* Debug.vect ends with eval info. */
 417         return scm_acons (scm_i_source,
 418                           scm_make_memoized (info[0].e.exp, info[0].e.env),
 419                           SCM_EOL);
 420     }
 421   else
 422     return scm_acons (scm_i_proc,
 423                       frame->vect[0].a.proc,
 424                       scm_acons (scm_i_args, frame->vect[0].a.args, SCM_EOL));
 425 }
 426
 427 SCM_PROC (s_last_stack_frame, "last-stack-frame", 1, 0, 0, scm_last_stack_frame);
 428
 429 SCM
 430 scm_last_stack_frame (obj)
 431      SCM obj;
 432 {
 433   scm_debug_frame *frame;
 434   long offset = 0;
 435   SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, s_last_stack_frame);
 436   if (scm_tc16_debugobj == SCM_TYP16 (obj))
 437     frame = (scm_debug_frame *) DBGFRAME (obj);
 438   else if (scm_tc7_contin == SCM_TYP7 (obj))
 439     {
 440       frame = SCM_DFRAME (obj);
 441       offset = (SCM_STACKITEM *) (SCM_CHARS (obj) + sizeof (regs)) - SCM_BASE (obj);
 442 #ifndef STACK_GROWS_UP
 443       offset += SCM_LENGTH (obj);
 444 #endif
 445     }
 446   else scm_wta (obj, (char *) SCM_ARG1, s_last_stack_frame);
 447   if (!frame)
 448     return SCM_BOOL_F;
 449   return _scm_stack_frame_to_plist ((scm_debug_frame *) ((SCM_STACKITEM *) frame + offset), offset);
 450 }
 451
 452 /* Make a scheme object of the current evaluation stack.
 453  */
 454
 455 SCM_PROC (s_expr_stack, "expr-stack", 0, 1, 0, scm_expr_stack);
 456
 457 SCM
 458 scm_expr_stack (obj)
 459      SCM obj;
 460 {
 461   SCM frs = SCM_EOL, vfrs, p;
 462   int size;
 463   int max_vfrs = SCM_BACKTRACE_DEPTH;
 464   scm_debug_info *info;
 465   scm_debug_frame *frame;
 466   long offset = 0;
 467   if (SCM_UNBNDP (obj))
 468     frame = scm_last_debug_frame;
 469   else
 470     {
 471       SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, s_expr_stack);
 472       if (scm_tc16_debugobj == SCM_TYP16 (obj))
 473         frame = (scm_debug_frame *) DBGFRAME (obj);
 474       else if (scm_tc7_contin == SCM_TYP7 (obj))
 475         {
 476           frame = SCM_DFRAME (obj);
 477           offset = (SCM_STACKITEM *) (SCM_CHARS (obj) + sizeof (regs)) - SCM_BASE (obj);
 478 #ifndef STACK_GROWS_UP
 479           offset += SCM_LENGTH (obj);
 480 #endif
 481         }
 482       else scm_wta (obj, (char *) SCM_ARG1, s_expr_stack);
 483     }
 484   for (; frame && max_vfrs > 0; frame = frame->prev)
 485     {
 486       frame = (scm_debug_frame *) ((SCM_STACKITEM *) frame + offset);
 487       p = _scm_stack_frame_to_plist (frame, offset);
 488       if (SCM_EVALFRAMEP (*frame))
 489         {
 490           size = frame->status & SCM_MAX_FRAME_SIZE;
 491           info = (scm_debug_info *) (*((SCM_STACKITEM **) &frame->vect[size]) + offset);
 492           vfrs = SCM_EOL;
 493           if ((info - frame->vect) & 1)
 494             --info;
 495           /* Data in the apply part of an eval info frame comes from
 496              previous stack frame if the scm_debug_info vector is overflowed. */
 497           else if (SCM_OVERFLOWP (*frame)
 498                    && !SCM_UNBNDP (info[1].a.proc))
 499             {
 500               vfrs = scm_cons (p, SCM_EOL);
 501               --max_vfrs;
 502               p = scm_acons (scm_i_proc,
 503                              info[1].a.proc,
 504                              scm_acons (scm_i_args, info[1].a.args, SCM_EOL));
 505             }
 506           info -= 2;
 507           vfrs = scm_cons (p, vfrs);
 508           --max_vfrs;
 509           if (SCM_OVERFLOWP (*frame))
 510             vfrs = scm_cons (scm_i_more, vfrs);
 511           while (info >= frame->vect)
 512             {
 513               p = SCM_EOL;
 514               if (!SCM_UNBNDP (info[1].a.proc))
 515                 p = scm_acons (scm_i_proc,
 516                                info[1].a.proc,
 517                                scm_acons (scm_i_args, info[1].a.args, SCM_EOL));
 518               p = scm_acons (scm_i_source,
 519                              scm_make_memoized (info[0].e.exp, info[0].e.env),
 520                              p);
 521               info -= 2;
 522               vfrs = scm_cons (p, vfrs);
 523               --max_vfrs;
 524             }
 525         }
 526       else
 527         {
 528           vfrs = scm_cons (p, SCM_EOL);
 529           --max_vfrs;
 530         }
 531       frs = scm_cons (vfrs, frs);
 532     }
 533   if (max_vfrs <= 0)
 534     frs = scm_cons (scm_i_more, frs);
 535   return frs;
 536 }
 537
 538
 539 \f
 540
 541 void
 542 scm_init_debug ()
 543 {
 544   scm_init_opts (scm_debug_options, scm_debug_opts, SCM_N_DEBUG_OPTIONS);
 545   scm_init_opts (scm_evaluator_traps,
 546                  scm_evaluator_trap_table,
 547                  SCM_N_EVALUATOR_TRAPS);
 548
 549   scm_tc16_memoized = scm_newsmob (&memoizedsmob);
 550   scm_tc16_debugobj = scm_newsmob (&debugobjsmob);
 551
 552   scm_i_procname = SCM_CAR (scm_sysintern ("procname", SCM_UNDEFINED));
 553   scm_i_more = SCM_CAR (scm_sysintern ("...", SCM_UNDEFINED));
 554   scm_i_source = SCM_CAR (scm_sysintern ("source", SCM_UNDEFINED));
 555   scm_i_proc = SCM_CAR (scm_sysintern ("proc", SCM_UNDEFINED));
 556   scm_i_args = SCM_CAR (scm_sysintern ("args", SCM_UNDEFINED));
 557   scm_i_eval_args = SCM_CAR (scm_sysintern ("eval-args", SCM_UNDEFINED));
 558
 559   scm_add_feature ("debug-extensions");
 560
 561 #include "debug.x"
 562 }