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