libguile/debug.c

   1 /* Debugging extensions for Guile
   2  * Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, 2008, 2009, 2010 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/struct.h"
  39 #include "libguile/procprop.h"
  40 #include "libguile/srcprop.h"
  41 #include "libguile/alist.h"
  42 #include "libguile/continuations.h"
  43 #include "libguile/strports.h"
  44 #include "libguile/read.h"
  45 #include "libguile/feature.h"
  46 #include "libguile/dynwind.h"
  47 #include "libguile/modules.h"
  48 #include "libguile/ports.h"
  49 #include "libguile/root.h"
  50 #include "libguile/fluids.h"
  51 #include "libguile/programs.h"
  52 #include "libguile/memoize.h"
  53 #include "libguile/vm.h"
  54
  55 #include "libguile/validate.h"
  56 #include "libguile/debug.h"
  57
  58 #include "libguile/private-options.h"
  59 \f
  60
  61
  62 /* {Run time control of the debugging evaluator}
  63  */
  64
  65 SCM_DEFINE (scm_debug_options, "debug-options-interface", 0, 1, 0,
  66             (SCM setting),
  67             "Option interface for the debug options. Instead of using\n"
  68             "this procedure directly, use the procedures @code{debug-enable},\n"
  69             "@code{debug-disable}, @code{debug-set!} and @code{debug-options}.")
  70 #define FUNC_NAME s_scm_debug_options
  71 {
  72   SCM ans;
  73
  74   scm_dynwind_begin (0);
  75   scm_dynwind_critical_section (SCM_BOOL_F);
  76
  77   ans = scm_options (setting, scm_debug_opts, FUNC_NAME);
  78   if (SCM_N_FRAMES < 1)
  79     {
  80       scm_options (ans, scm_debug_opts, FUNC_NAME);
  81       SCM_OUT_OF_RANGE (1, setting);
  82     }
  83 #ifdef STACK_CHECKING
  84   scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
  85 #endif
  86
  87   scm_dynwind_end ();
  88   return ans;
  89 }
  90 #undef FUNC_NAME
  91
  92
  93 static void
  94 with_traps_before (void *data)
  95 {
  96   int *trap_flag = data;
  97   *trap_flag = SCM_TRAPS_P;
  98   SCM_TRAPS_P = 1;
  99 }
 100
 101 static void
 102 with_traps_after (void *data)
 103 {
 104   int *trap_flag = data;
 105   SCM_TRAPS_P = *trap_flag;
 106 }
 107
 108 static SCM
 109 with_traps_inner (void *data)
 110 {
 111   SCM thunk = SCM_PACK ((scm_t_bits) data);
 112   return scm_call_0 (thunk);
 113 }
 114
 115 SCM_DEFINE (scm_with_traps, "with-traps", 1, 0, 0,
 116             (SCM thunk),
 117             "Call @var{thunk} with traps enabled.")
 118 #define FUNC_NAME s_scm_with_traps
 119 {
 120   int trap_flag;
 121   SCM_VALIDATE_THUNK (1, thunk);
 122   return scm_internal_dynamic_wind (with_traps_before,
 123                                     with_traps_inner,
 124                                     with_traps_after,
 125                                     (void *) SCM_UNPACK (thunk),
 126                                     &trap_flag);
 127 }
 128 #undef FUNC_NAME
 129
 130 \f
 131 SCM_SYMBOL (scm_sym_procname, "procname");
 132 SCM_SYMBOL (scm_sym_dots, "...");
 133 SCM_SYMBOL (scm_sym_source, "source");
 134
 135 SCM_DEFINE (scm_procedure_name, "procedure-name", 1, 0, 0,
 136             (SCM proc),
 137             "Return the name of the procedure @var{proc}")
 138 #define FUNC_NAME s_scm_procedure_name
 139 {
 140   SCM_VALIDATE_PROC (1, proc);
 141   while (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc))
 142     proc = SCM_STRUCT_PROCEDURE (proc);
 143   switch (SCM_TYP7 (proc)) {
 144   case scm_tc7_gsubr:
 145     return SCM_SUBR_NAME (proc);
 146   default:
 147     {
 148       SCM name = scm_procedure_property (proc, scm_sym_name);
 149       if (scm_is_false (name) && SCM_PROGRAM_P (proc))
 150         name = scm_program_name (proc);
 151       return name;
 152     }
 153   }
 154 }
 155 #undef FUNC_NAME
 156
 157 SCM_DEFINE (scm_procedure_source, "procedure-source", 1, 0, 0,
 158             (SCM proc),
 159             "Return the source of the procedure @var{proc}.")
 160 #define FUNC_NAME s_scm_procedure_source
 161 {
 162   SCM src;
 163   SCM_VALIDATE_PROC (1, proc);
 164
 165   do
 166     {
 167       src = scm_procedure_property (proc, scm_sym_source);
 168       if (scm_is_true (src))
 169         return src;
 170
 171       switch (SCM_TYP7 (proc)) {
 172       case scm_tcs_struct:
 173         if (!SCM_STRUCT_APPLICABLE_P (proc)
 174             || SCM_IMP (SCM_STRUCT_PROCEDURE (proc)))
 175           break;
 176         proc = SCM_STRUCT_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 */