libguile/debug.c

   1 /* Debugging extensions for Guile
   2  * Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, 2008, 2009 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 License
   6  * as published by the Free Software Foundation; either version 3 of
   7  * the License, or (at your option) any later version.
   8  *
   9  * This library is distributed in the hope that it will be useful, but
  10  * 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
  17  * 02110-1301 USA
  18  */
  19
  20
  21 #ifdef HAVE_CONFIG_H
  22 # include <config.h>
  23 #endif
  24
  25 #ifdef HAVE_GETRLIMIT
  26 #include <sys/time.h>
  27 #include <sys/resource.h>
  28 #endif
  29
  30 #include "libguile/_scm.h"
  31 #include "libguile/async.h"
  32 #include "libguile/eval.h"
  33 #include "libguile/list.h"
  34 #include "libguile/stackchk.h"
  35 #include "libguile/throw.h"
  36 #include "libguile/macros.h"
  37 #include "libguile/smob.h"
  38 #include "libguile/procprop.h"
  39 #include "libguile/srcprop.h"
  40 #include "libguile/alist.h"
  41 #include "libguile/continuations.h"
  42 #include "libguile/strports.h"
  43 #include "libguile/read.h"
  44 #include "libguile/feature.h"
  45 #include "libguile/dynwind.h"
  46 #include "libguile/modules.h"
  47 #include "libguile/ports.h"
  48 #include "libguile/root.h"
  49 #include "libguile/fluids.h"
  50 #include "libguile/programs.h"
  51 #include "libguile/memoize.h"
  52 #include "libguile/vm.h"
  53
  54 #include "libguile/validate.h"
  55 #include "libguile/debug.h"
  56
  57 #include "libguile/private-options.h"
  58 \f
  59
  60
  61 /* {Run time control of the debugging evaluator}
  62  */
  63
  64 SCM_DEFINE (scm_debug_options, "debug-options-interface", 0, 1, 0,
  65             (SCM setting),
  66             "Option interface for the debug options. Instead of using\n"
  67             "this procedure directly, use the procedures @code{debug-enable},\n"
  68             "@code{debug-disable}, @code{debug-set!} and @code{debug-options}.")
  69 #define FUNC_NAME s_scm_debug_options
  70 {
  71   SCM ans;
  72
  73   scm_dynwind_begin (0);
  74   scm_dynwind_critical_section (SCM_BOOL_F);
  75
  76   ans = scm_options (setting, scm_debug_opts, FUNC_NAME);
  77   if (SCM_N_FRAMES < 1)
  78     {
  79       scm_options (ans, scm_debug_opts, FUNC_NAME);
  80       SCM_OUT_OF_RANGE (1, setting);
  81     }
  82 #ifdef STACK_CHECKING
  83   scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
  84 #endif
  85
  86   scm_dynwind_end ();
  87   return ans;
  88 }
  89 #undef FUNC_NAME
  90
  91
  92 static void
  93 with_traps_before (void *data)
  94 {
  95   int *trap_flag = data;
  96   *trap_flag = SCM_TRAPS_P;
  97   SCM_TRAPS_P = 1;
  98 }
  99
 100 static void
 101 with_traps_after (void *data)
 102 {
 103   int *trap_flag = data;
 104   SCM_TRAPS_P = *trap_flag;
 105 }
 106
 107 static SCM
 108 with_traps_inner (void *data)
 109 {
 110   SCM thunk = SCM_PACK ((scm_t_bits) data);
 111   return scm_call_0 (thunk);
 112 }
 113
 114 SCM_DEFINE (scm_with_traps, "with-traps", 1, 0, 0,
 115             (SCM thunk),
 116             "Call @var{thunk} with traps enabled.")
 117 #define FUNC_NAME s_scm_with_traps
 118 {
 119   int trap_flag;
 120   SCM_VALIDATE_THUNK (1, thunk);
 121   return scm_internal_dynamic_wind (with_traps_before,
 122                                     with_traps_inner,
 123                                     with_traps_after,
 124                                     (void *) SCM_UNPACK (thunk),
 125                                     &trap_flag);
 126 }
 127 #undef FUNC_NAME
 128
 129 \f
 130 SCM_SYMBOL (scm_sym_procname, "procname");
 131 SCM_SYMBOL (scm_sym_dots, "...");
 132 SCM_SYMBOL (scm_sym_source, "source");
 133
 134 SCM_DEFINE (scm_procedure_name, "procedure-name", 1, 0, 0,
 135             (SCM proc),
 136             "Return the name of the procedure @var{proc}")
 137 #define FUNC_NAME s_scm_procedure_name
 138 {
 139   SCM_VALIDATE_PROC (1, proc);
 140   switch (SCM_TYP7 (proc)) {
 141   case scm_tc7_gsubr:
 142     return SCM_SUBR_NAME (proc);
 143   default:
 144     {
 145       SCM name = scm_procedure_property (proc, scm_sym_name);
 146       if (scm_is_false (name) && SCM_PROGRAM_P (proc))
 147         name = scm_program_name (proc);
 148       return name;
 149     }
 150   }
 151 }
 152 #undef FUNC_NAME
 153
 154 SCM_DEFINE (scm_procedure_source, "procedure-source", 1, 0, 0,
 155             (SCM proc),
 156             "Return the source of the procedure @var{proc}.")
 157 #define FUNC_NAME s_scm_procedure_source
 158 {
 159   SCM src;
 160   SCM_VALIDATE_PROC (1, proc);
 161
 162   do
 163     {
 164       src = scm_procedure_property (proc, scm_sym_source);
 165       if (scm_is_true (src))
 166         return src;
 167
 168       switch (SCM_TYP7 (proc)) {
 169       case scm_tcs_struct:
 170         if (!SCM_STRUCT_APPLICABLE_P (proc)
 171             || SCM_IMP (SCM_STRUCT_PROCEDURE (proc)))
 172           break;
 173         proc = SCM_STRUCT_PROCEDURE (proc);
 174         continue;
 175       case scm_tc7_pws:
 176         proc = SCM_PROCEDURE (proc);
 177         continue;
 178       default:
 179         break;
 180       }
 181     }
 182   while (0);
 183
 184   return SCM_BOOL_F;
 185 }
 186 #undef FUNC_NAME
 187
 188
 189 \f
 190
 191 #if 0
 192 SCM_REGISTER_PROC (s_reverse_lookup, "reverse-lookup", 2, 0, 0, scm_reverse_lookup);
 193 #endif
 194
 195 SCM
 196 scm_reverse_lookup (SCM env, SCM data)
 197 {
 198   while (scm_is_pair (env) && scm_is_pair (SCM_CAR (env)))
 199     {
 200       SCM names = SCM_CAAR (env);
 201       SCM values = SCM_CDAR (env);
 202       while (scm_is_pair (names))
 203         {
 204           if (scm_is_eq (SCM_CAR (values), data))
 205             return SCM_CAR (names);
 206           names = SCM_CDR (names);
 207           values = SCM_CDR (values);
 208         }
 209       if (!scm_is_null (names) && scm_is_eq (values, data))
 210         return names;
 211       env = SCM_CDR (env);
 212     }
 213   return SCM_BOOL_F;
 214 }
 215
 216 SCM_DEFINE (scm_sys_start_stack, "%start-stack", 2, 0, 0,
 217             (SCM id, SCM thunk),
 218             "Call @var{thunk} on an evaluator stack tagged with @var{id}.")
 219 #define FUNC_NAME s_scm_sys_start_stack
 220 {
 221   return scm_vm_call_with_new_stack (scm_the_vm (), thunk, id);
 222 }
 223 #undef FUNC_NAME
 224
 225 \f
 226
 227 /* Undocumented debugging procedure */
 228 #ifdef GUILE_DEBUG
 229 SCM_DEFINE (scm_debug_hang, "debug-hang", 0, 1, 0,
 230             (SCM obj),
 231             "Go into an endless loop, which can be only terminated with\n"
 232             "a debugger.")
 233 #define FUNC_NAME s_scm_debug_hang
 234 {
 235   int go = 0;
 236   while (!go) ;
 237   return SCM_UNSPECIFIED;
 238 }
 239 #undef FUNC_NAME
 240 #endif
 241
 242 static void
 243 init_stack_limit (void)
 244 {
 245 #ifdef HAVE_GETRLIMIT
 246   struct rlimit lim;
 247   if (getrlimit (RLIMIT_STACK, &lim) == 0)
 248       {
 249         rlim_t bytes = lim.rlim_cur;
 250
 251         /* set our internal stack limit to 80% of the rlimit. */
 252         if (bytes == RLIM_INFINITY)
 253           bytes = lim.rlim_max;
 254
 255         if (bytes != RLIM_INFINITY)
 256           SCM_STACK_LIMIT = bytes * 8 / 10 / sizeof (scm_t_bits);
 257       }
 258   errno = 0;
 259 #endif
 260 }
 261
 262 \f
 263
 264 void
 265 scm_init_debug ()
 266 {
 267   init_stack_limit ();
 268   scm_init_opts (scm_debug_options, scm_debug_opts);
 269
 270   scm_add_feature ("debug-extensions");
 271
 272 #include "libguile/debug.x"
 273 }
 274
 275 /*
 276   Local Variables:
 277   c-file-style: "gnu"
 278   End:
 279 */