libguile/debug.c

   1 /* Debugging extensions for Guile
   2  * Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, 2008, 2009, 2010, 2011 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 /*
  63  * Debugging options.
  64  */
  65
  66 scm_t_option scm_debug_opts[] = {
  67   { SCM_OPTION_BOOLEAN, "backwards", 0,
  68     "Display backtrace in anti-chronological order." },
  69   { SCM_OPTION_INTEGER, "width", 79, "Maximal width of backtrace." },
  70   { SCM_OPTION_INTEGER, "depth", 20, "Maximal length of printed backtrace." },
  71   { SCM_OPTION_BOOLEAN, "backtrace", 1, "Show backtrace on error." },
  72   /* This default stack limit will be overridden by init_stack_limit(),
  73      if we have getrlimit() and the stack limit is not INFINITY. But it is still
  74      important, as some systems have both the soft and the hard limits set to
  75      INFINITY; in that case we fall back to this value.
  76
  77      The situation is aggravated by certain compilers, which can consume
  78      "beaucoup de stack", as they say in France.
  79
  80      See http://thread.gmane.org/gmane.lisp.guile.devel/8599/focus=8662 for
  81      more discussion. This setting is 640 KB on 32-bit arches (should be enough
  82      for anyone!) or a whoppin' 1280 KB on 64-bit arches.
  83   */
  84   { SCM_OPTION_INTEGER, "stack", 160000, "Stack size limit (measured in words; 0 = no check)." },
  85   { SCM_OPTION_SCM, "show-file-name", SCM_BOOL_T_BITS,
  86     "Show file names and line numbers "
  87     "in backtraces when not `#f'.  A value of `base' "
  88     "displays only base names, while `#t' displays full names."},
  89   { SCM_OPTION_BOOLEAN, "warn-deprecated", 0,
  90     "Warn when deprecated features are used." },
  91   { 0 },
  92 };
  93
  94
  95 /* {Run time control of the debugging evaluator}
  96  */
  97
  98 SCM_DEFINE (scm_debug_options, "debug-options-interface", 0, 1, 0,
  99             (SCM setting),
 100             "Option interface for the debug options. Instead of using\n"
 101             "this procedure directly, use the procedures @code{debug-enable},\n"
 102             "@code{debug-disable}, @code{debug-set!} and @code{debug-options}.")
 103 #define FUNC_NAME s_scm_debug_options
 104 {
 105   SCM ans;
 106
 107   scm_dynwind_begin (0);
 108   scm_dynwind_critical_section (SCM_BOOL_F);
 109
 110   ans = scm_options (setting, scm_debug_opts, FUNC_NAME);
 111   scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
 112
 113   scm_dynwind_end ();
 114   return ans;
 115 }
 116 #undef FUNC_NAME
 117
 118 \f
 119 SCM_SYMBOL (scm_sym_source, "source");
 120
 121 SCM_DEFINE (scm_procedure_name, "procedure-name", 1, 0, 0,
 122             (SCM proc),
 123             "Return the name of the procedure @var{proc}")
 124 #define FUNC_NAME s_scm_procedure_name
 125 {
 126   SCM_VALIDATE_PROC (1, proc);
 127   while (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc))
 128     proc = SCM_STRUCT_PROCEDURE (proc);
 129   return scm_procedure_property (proc, scm_sym_name);
 130 }
 131 #undef FUNC_NAME
 132
 133 SCM_DEFINE (scm_procedure_source, "procedure-source", 1, 0, 0,
 134             (SCM proc),
 135             "Return the source of the procedure @var{proc}.")
 136 #define FUNC_NAME s_scm_procedure_source
 137 {
 138   SCM src;
 139   SCM_VALIDATE_PROC (1, proc);
 140
 141   do
 142     {
 143       src = scm_procedure_property (proc, scm_sym_source);
 144       if (scm_is_true (src))
 145         return src;
 146
 147       switch (SCM_TYP7 (proc)) {
 148       case scm_tcs_struct:
 149         if (!SCM_STRUCT_APPLICABLE_P (proc)
 150             || SCM_IMP (SCM_STRUCT_PROCEDURE (proc)))
 151           break;
 152         proc = SCM_STRUCT_PROCEDURE (proc);
 153         continue;
 154       default:
 155         break;
 156       }
 157     }
 158   while (0);
 159
 160   return SCM_BOOL_F;
 161 }
 162 #undef FUNC_NAME
 163
 164
 165 \f
 166
 167 #if 0
 168 SCM_REGISTER_PROC (s_reverse_lookup, "reverse-lookup", 2, 0, 0, scm_reverse_lookup);
 169 #endif
 170
 171 SCM
 172 scm_reverse_lookup (SCM env, SCM data)
 173 {
 174   while (scm_is_pair (env) && scm_is_pair (SCM_CAR (env)))
 175     {
 176       SCM names = SCM_CAAR (env);
 177       SCM values = SCM_CDAR (env);
 178       while (scm_is_pair (names))
 179         {
 180           if (scm_is_eq (SCM_CAR (values), data))
 181             return SCM_CAR (names);
 182           names = SCM_CDR (names);
 183           values = SCM_CDR (values);
 184         }
 185       if (!scm_is_null (names) && scm_is_eq (values, data))
 186         return names;
 187       env = SCM_CDR (env);
 188     }
 189   return SCM_BOOL_F;
 190 }
 191
 192 \f
 193
 194 /* Undocumented debugging procedure */
 195 #ifdef GUILE_DEBUG
 196 SCM_DEFINE (scm_debug_hang, "debug-hang", 0, 1, 0,
 197             (SCM obj),
 198             "Go into an endless loop, which can be only terminated with\n"
 199             "a debugger.")
 200 #define FUNC_NAME s_scm_debug_hang
 201 {
 202   int go = 0;
 203   while (!go) ;
 204   return SCM_UNSPECIFIED;
 205 }
 206 #undef FUNC_NAME
 207 #endif
 208
 209 static void
 210 init_stack_limit (void)
 211 {
 212 #ifdef HAVE_GETRLIMIT
 213   struct rlimit lim;
 214   if (getrlimit (RLIMIT_STACK, &lim) == 0)
 215       {
 216         rlim_t bytes = lim.rlim_cur;
 217
 218         /* set our internal stack limit to 80% of the rlimit. */
 219         if (bytes == RLIM_INFINITY)
 220           bytes = lim.rlim_max;
 221
 222         if (bytes != RLIM_INFINITY)
 223           SCM_STACK_LIMIT = bytes * 8 / 10 / sizeof (scm_t_bits);
 224       }
 225   errno = 0;
 226 #endif
 227 }
 228
 229 \f
 230
 231 void
 232 scm_init_debug ()
 233 {
 234   init_stack_limit ();
 235   scm_init_opts (scm_debug_options, scm_debug_opts);
 236
 237   scm_add_feature ("debug-extensions");
 238
 239 #include "libguile/debug.x"
 240 }
 241
 242 /*
 243   Local Variables:
 244   c-file-style: "gnu"
 245   End:
 246 */