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_source, "source");
 132
 133 SCM_DEFINE (scm_procedure_name, "procedure-name", 1, 0, 0,
 134             (SCM proc),
 135             "Return the name of the procedure @var{proc}")
 136 #define FUNC_NAME s_scm_procedure_name
 137 {
 138   SCM_VALIDATE_PROC (1, proc);
 139   while (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc))
 140     proc = SCM_STRUCT_PROCEDURE (proc);
 141   return scm_procedure_property (proc, scm_sym_name);
 142 }
 143 #undef FUNC_NAME
 144
 145 SCM_DEFINE (scm_procedure_source, "procedure-source", 1, 0, 0,
 146             (SCM proc),
 147             "Return the source of the procedure @var{proc}.")
 148 #define FUNC_NAME s_scm_procedure_source
 149 {
 150   SCM src;
 151   SCM_VALIDATE_PROC (1, proc);
 152
 153   do
 154     {
 155       src = scm_procedure_property (proc, scm_sym_source);
 156       if (scm_is_true (src))
 157         return src;
 158
 159       switch (SCM_TYP7 (proc)) {
 160       case scm_tcs_struct:
 161         if (!SCM_STRUCT_APPLICABLE_P (proc)
 162             || SCM_IMP (SCM_STRUCT_PROCEDURE (proc)))
 163           break;
 164         proc = SCM_STRUCT_PROCEDURE (proc);
 165         continue;
 166       default:
 167         break;
 168       }
 169     }
 170   while (0);
 171
 172   return SCM_BOOL_F;
 173 }
 174 #undef FUNC_NAME
 175
 176
 177 \f
 178
 179 #if 0
 180 SCM_REGISTER_PROC (s_reverse_lookup, "reverse-lookup", 2, 0, 0, scm_reverse_lookup);
 181 #endif
 182
 183 SCM
 184 scm_reverse_lookup (SCM env, SCM data)
 185 {
 186   while (scm_is_pair (env) && scm_is_pair (SCM_CAR (env)))
 187     {
 188       SCM names = SCM_CAAR (env);
 189       SCM values = SCM_CDAR (env);
 190       while (scm_is_pair (names))
 191         {
 192           if (scm_is_eq (SCM_CAR (values), data))
 193             return SCM_CAR (names);
 194           names = SCM_CDR (names);
 195           values = SCM_CDR (values);
 196         }
 197       if (!scm_is_null (names) && scm_is_eq (values, data))
 198         return names;
 199       env = SCM_CDR (env);
 200     }
 201   return SCM_BOOL_F;
 202 }
 203
 204 \f
 205
 206 /* Undocumented debugging procedure */
 207 #ifdef GUILE_DEBUG
 208 SCM_DEFINE (scm_debug_hang, "debug-hang", 0, 1, 0,
 209             (SCM obj),
 210             "Go into an endless loop, which can be only terminated with\n"
 211             "a debugger.")
 212 #define FUNC_NAME s_scm_debug_hang
 213 {
 214   int go = 0;
 215   while (!go) ;
 216   return SCM_UNSPECIFIED;
 217 }
 218 #undef FUNC_NAME
 219 #endif
 220
 221 static void
 222 init_stack_limit (void)
 223 {
 224 #ifdef HAVE_GETRLIMIT
 225   struct rlimit lim;
 226   if (getrlimit (RLIMIT_STACK, &lim) == 0)
 227       {
 228         rlim_t bytes = lim.rlim_cur;
 229
 230         /* set our internal stack limit to 80% of the rlimit. */
 231         if (bytes == RLIM_INFINITY)
 232           bytes = lim.rlim_max;
 233
 234         if (bytes != RLIM_INFINITY)
 235           SCM_STACK_LIMIT = bytes * 8 / 10 / sizeof (scm_t_bits);
 236       }
 237   errno = 0;
 238 #endif
 239 }
 240
 241 \f
 242
 243 void
 244 scm_init_debug ()
 245 {
 246   init_stack_limit ();
 247   scm_init_opts (scm_debug_options, scm_debug_opts);
 248
 249   scm_add_feature ("debug-extensions");
 250
 251 #include "libguile/debug.x"
 252 }
 253
 254 /*
 255   Local Variables:
 256   c-file-style: "gnu"
 257   End:
 258 */