libguile/debug.c

   1 /* Debugging extensions for Guile
   2  * Copyright (C) 1995, 1996, 1997 Free Software Foundation
   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, Inc., 59 Temple Place, Suite 330,
  17  * Boston, MA 02111-1307 USA
  18  *
  19  * As a special exception, the Free Software Foundation gives permission
  20  * for additional uses of the text contained in its release of GUILE.
  21  *
  22  * The exception is that, if you link the GUILE library with other files
  23  * to produce an executable, this does not by itself cause the
  24  * resulting executable to be covered by the GNU General Public License.
  25  * Your use of that executable is in no way restricted on account of
  26  * linking the GUILE library code into it.
  27  *
  28  * This exception does not however invalidate any other reasons why
  29  * the executable file might be covered by the GNU General Public License.
  30  *
  31  * This exception applies only to the code released by the
  32  * Free Software Foundation under the name GUILE.  If you copy
  33  * code from other Free Software Foundation releases into a copy of
  34  * GUILE, as the General Public License permits, the exception does
  35  * not apply to the code that you add in this way.  To avoid misleading
  36  * anyone as to the status of such modified files, you must delete
  37  * this exception notice from them.
  38  *
  39  * If you write modifications of your own for GUILE, it is your choice
  40  * whether to permit this exception to apply to your modifications.
  41  * If you do not wish that, delete this exception notice.
  42  *
  43  * The author can be reached at djurfeldt@nada.kth.se
  44  * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN */
  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_call_continuation (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_puts ("#<memoized ", port);
 144   SCM_SET_WRITINGP (pstate, 1);
 145   scm_iprin1 (scm_unmemoize (obj), port, pstate);
 146   SCM_SET_WRITINGP (pstate, writingp);
 147   scm_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 SCM
 164 scm_make_memoized (exp, env)
 165      SCM exp;
 166      SCM env;
 167 {
 168   /* *fixme* Check that env is a valid environment. */
 169   register SCM z, ans;
 170   SCM_DEFER_INTS;
 171   SCM_NEWCELL (z);
 172   SCM_SETCAR (z, exp);
 173   SCM_SETCDR (z, env);
 174   SCM_NEWCELL (ans);
 175   SCM_SETCAR (ans, scm_tc16_memoized);
 176   SCM_SETCDR (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_NIMP (m) && SCM_MEMOIZEDP (m), m, SCM_ARG1, s_unmemoize);
 188   return scm_unmemocopy (SCM_MEMOIZED_EXP (m), SCM_MEMOIZED_ENV (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_NIMP (m) && SCM_MEMOIZEDP (m), m, SCM_ARG1, s_unmemoize);
 198   return SCM_MEMOIZED_ENV (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   case scm_tc7_cclo:
 214     {
 215       SCM name = scm_procedure_property (proc, scm_i_name);
 216 #if 0
 217       /* Source property scm_i_procname not implemented yet... */
 218       SCM name = scm_source_property (SCM_CAR (SCM_CDR (SCM_CODE (proc))), scm_i_procname);
 219       if (SCM_FALSEP (name))
 220         name = scm_procedure_property (proc, scm_i_name);
 221 #endif
 222       if (SCM_FALSEP (name))
 223         name = scm_procedure_property (proc, scm_i_inner_name);
 224       return name;
 225     }
 226   case scm_tcs_subrs:
 227     return SCM_SNAME (proc);
 228   default:
 229     return SCM_BOOL_F;
 230   }
 231 }
 232
 233 SCM_PROC (s_procedure_source, "procedure-source", 1, 0, 0, scm_procedure_source);
 234
 235 SCM
 236 scm_procedure_source (proc)
 237      SCM proc;
 238 {
 239   SCM_ASSERT(SCM_NIMP (proc), proc, SCM_ARG1, s_procedure_source);
 240   switch (SCM_TYP7 (proc)) {
 241   case scm_tcs_closures:
 242     {
 243       SCM src;
 244       src = scm_source_property (SCM_CDR (SCM_CODE (proc)), scm_i_copy);
 245       if (src != SCM_BOOL_F)
 246         return scm_cons2 (scm_i_lambda, SCM_CAR (SCM_CODE (proc)), src);
 247       src = SCM_CODE (proc);
 248       return scm_cons (scm_i_lambda,
 249                        scm_unmemocopy (src,
 250                                        SCM_EXTEND_ENV (SCM_CAR (src),
 251                                                            SCM_EOL,
 252                                                            SCM_ENV (proc))));
 253     }
 254   case scm_tc7_contin:
 255   case scm_tcs_subrs:
 256 #ifdef CCLO
 257   case scm_tc7_cclo:
 258 #endif
 259     /* It would indeed be a nice thing if we supplied source even for
 260        built in procedures! */
 261     return scm_procedure_property (proc, scm_i_source);
 262   default:
 263     scm_wta (proc, (char *) SCM_ARG1, s_procedure_source);
 264     return 0;
 265   }
 266 }
 267
 268 SCM_PROC (s_procedure_environment, "procedure-environment", 1, 0, 0, scm_procedure_environment);
 269
 270 SCM
 271 scm_procedure_environment (proc)
 272      SCM proc;
 273 {
 274   SCM_ASSERT (SCM_NIMP (proc), proc, SCM_ARG1, s_procedure_environment);
 275   switch (SCM_TYP7 (proc)) {
 276   case scm_tcs_closures:
 277     return SCM_ENV (proc);
 278   case scm_tc7_contin:
 279   case scm_tcs_subrs:
 280 #ifdef CCLO
 281   case scm_tc7_cclo:
 282 #endif
 283     return SCM_EOL;
 284   default:
 285     scm_wta (proc, (char *) SCM_ARG1, s_procedure_environment);
 286     return 0;
 287   }
 288 }
 289
 290 \f
 291
 292 /* Eval in a local environment.  We would like to have the ability to
 293  * evaluate in a specified local environment, but due to the
 294  * memoization this isn't normally possible.  We solve it by copying
 295  * the code before evaluating.  One solution would be to have eval.c
 296  * generate yet another evaluator.  They are not very big actually.
 297  */
 298 SCM_PROC (s_local_eval, "local-eval", 1, 1, 0, scm_local_eval);
 299
 300 SCM
 301 scm_local_eval (exp, env)
 302      SCM exp;
 303      SCM env;
 304 {
 305   if (SCM_UNBNDP (env))
 306   {
 307     SCM_ASSERT (SCM_NIMP (exp) && SCM_MEMOIZEDP (exp), exp, SCM_ARG1, s_local_eval);
 308     return scm_eval_3 (SCM_MEMOIZED_EXP (exp), 0, SCM_MEMOIZED_ENV (exp));
 309   }
 310   return scm_eval_3 (exp, 1, env);
 311 }
 312
 313 static char s_start_stack[] = "start-stack";
 314 SCM
 315 scm_m_start_stack (exp, env)
 316      SCM exp;
 317      SCM env;
 318 {
 319   SCM answer;
 320   scm_debug_frame vframe;
 321   scm_debug_info vframe_vect_body;
 322   exp = SCM_CDR (exp);
 323   SCM_ASSERT (SCM_NIMP (exp)
 324               && SCM_ECONSP (exp)
 325               && SCM_NIMP (SCM_CDR (exp))
 326               && SCM_ECONSP (SCM_CDR (exp))
 327               && SCM_NULLP (SCM_CDDR (exp)),
 328               exp,
 329               SCM_WNA,
 330               s_start_stack);
 331   vframe.prev = scm_last_debug_frame;
 332   vframe.status = SCM_VOIDFRAME;
 333   vframe.vect = &vframe_vect_body;
 334   vframe.vect[0].id = scm_eval_car (exp, env);
 335   scm_last_debug_frame = &vframe;
 336   answer = scm_eval_car (SCM_CDR (exp), env);
 337   scm_last_debug_frame = vframe.prev;
 338   return answer;
 339 }
 340
 341 /* {Debug Objects}
 342  *
 343  * The debugging evaluator throws these on frame traps.
 344  */
 345
 346 long scm_tc16_debugobj;
 347
 348 static int prindebugobj SCM_P ((SCM obj, SCM port, scm_print_state *pstate));
 349
 350 static int
 351 prindebugobj (obj, port, pstate)
 352      SCM obj;
 353      SCM port;
 354      scm_print_state *pstate;
 355 {
 356   scm_puts ("#<debug-object ", port);
 357   scm_intprint (SCM_DEBUGOBJ_FRAME (obj), 16, port);
 358   scm_putc ('>', port);
 359   return 1;
 360 }
 361
 362 static scm_smobfuns debugobjsmob =
 363 {scm_mark0, scm_free0, prindebugobj, 0};
 364
 365 SCM_PROC (s_debug_object_p, "debug-object?", 1, 0, 0, scm_debug_object_p);
 366
 367 SCM
 368 scm_debug_object_p (obj)
 369      SCM obj;
 370 {
 371   return SCM_NIMP (obj) && SCM_DEBUGOBJP (obj) ? SCM_BOOL_T : SCM_BOOL_F;
 372 }
 373
 374
 375 SCM
 376 scm_make_debugobj (frame)
 377      scm_debug_frame *frame;
 378 {
 379   register SCM z;
 380   SCM_DEFER_INTS;
 381   SCM_NEWCELL (z);
 382   SCM_SETCAR (z, scm_tc16_debugobj);
 383   SCM_SET_DEBUGOBJ_FRAME (z, (SCM) frame);
 384   SCM_ALLOW_INTS;
 385   return z;
 386 }
 387
 388 \f
 389
 390 /* Undocumented debugging procedure */
 391 #ifdef GUILE_DEBUG
 392 SCM_PROC (s_debug_hang, "debug-hang", 0, 1, 0, scm_debug_hang);
 393
 394 SCM
 395 scm_debug_hang (obj)
 396      SCM obj;
 397 {
 398   int go = 0;
 399   while (!go) ;
 400   return SCM_UNSPECIFIED;
 401 }
 402 #endif
 403
 404 \f
 405
 406 void
 407 scm_init_debug ()
 408 {
 409   scm_init_opts (scm_debug_options, scm_debug_opts, SCM_N_DEBUG_OPTIONS);
 410   scm_init_opts (scm_evaluator_traps,
 411                  scm_evaluator_trap_table,
 412                  SCM_N_EVALUATOR_TRAPS);
 413
 414   scm_tc16_memoized = scm_newsmob (&memoizedsmob);
 415   scm_tc16_debugobj = scm_newsmob (&debugobjsmob);
 416
 417   scm_i_procname = SCM_CAR (scm_sysintern ("procname", SCM_UNDEFINED));
 418   scm_i_more = SCM_CAR (scm_sysintern ("...", SCM_UNDEFINED));
 419   scm_i_source = SCM_CAR (scm_sysintern ("source", SCM_UNDEFINED));
 420   scm_i_proc = SCM_CAR (scm_sysintern ("proc", SCM_UNDEFINED));
 421   scm_i_args = SCM_CAR (scm_sysintern ("args", SCM_UNDEFINED));
 422   scm_i_eval_args = SCM_CAR (scm_sysintern ("eval-args", SCM_UNDEFINED));
 423
 424   scm_make_synt (s_start_stack, scm_makacro, scm_m_start_stack);
 425
 426   scm_add_feature ("debug-extensions");
 427
 428 #include "debug.x"
 429 }