123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233 |
- #ifdef HAVE_CONFIG_H
- # include <config.h>
- #endif
- #ifdef HAVE_GETRLIMIT
- #include <sys/time.h>
- #include <sys/resource.h>
- #endif
- #ifdef __MINGW32__
- # define WIN32_LEAN_AND_MEAN
- # include <windows.h>
- #endif
- #include "libguile/_scm.h"
- #include "libguile/async.h"
- #include "libguile/eval.h"
- #include "libguile/list.h"
- #include "libguile/stackchk.h"
- #include "libguile/throw.h"
- #include "libguile/macros.h"
- #include "libguile/smob.h"
- #include "libguile/struct.h"
- #include "libguile/procprop.h"
- #include "libguile/srcprop.h"
- #include "libguile/alist.h"
- #include "libguile/continuations.h"
- #include "libguile/strports.h"
- #include "libguile/read.h"
- #include "libguile/feature.h"
- #include "libguile/dynwind.h"
- #include "libguile/modules.h"
- #include "libguile/ports.h"
- #include "libguile/root.h"
- #include "libguile/fluids.h"
- #include "libguile/programs.h"
- #include "libguile/memoize.h"
- #include "libguile/vm.h"
- #include "libguile/validate.h"
- #include "libguile/debug.h"
- #include "libguile/private-options.h"
- scm_t_option scm_debug_opts[] = {
- { SCM_OPTION_BOOLEAN, "backwards", 0,
- "Display backtrace in anti-chronological order." },
- { SCM_OPTION_INTEGER, "width", 79, "Maximal width of backtrace." },
- { SCM_OPTION_INTEGER, "depth", 20, "Maximal length of printed backtrace." },
- { SCM_OPTION_BOOLEAN, "backtrace", 1, "Show backtrace on error." },
-
- { SCM_OPTION_INTEGER, "stack", 160000, "Stack size limit (measured in words; 0 = no check)." },
- { SCM_OPTION_SCM, "show-file-name", SCM_BOOL_T_BITS,
- "Show file names and line numbers "
- "in backtraces when not `#f'. A value of `base' "
- "displays only base names, while `#t' displays full names."},
- { SCM_OPTION_BOOLEAN, "warn-deprecated", 0,
- "Warn when deprecated features are used." },
- { 0 },
- };
- SCM_DEFINE (scm_debug_options, "debug-options-interface", 0, 1, 0,
- (SCM setting),
- "Option interface for the debug options. Instead of using\n"
- "this procedure directly, use the procedures @code{debug-enable},\n"
- "@code{debug-disable}, @code{debug-set!} and @code{debug-options}.")
- #define FUNC_NAME s_scm_debug_options
- {
- SCM ans;
- scm_dynwind_begin (0);
- scm_dynwind_critical_section (SCM_BOOL_F);
- ans = scm_options (setting, scm_debug_opts, FUNC_NAME);
- scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
- scm_dynwind_end ();
- return ans;
- }
- #undef FUNC_NAME
- #if 0
- SCM_REGISTER_PROC (s_reverse_lookup, "reverse-lookup", 2, 0, 0, scm_reverse_lookup);
- #endif
- SCM
- scm_reverse_lookup (SCM env, SCM data)
- {
- while (scm_is_pair (env) && scm_is_pair (SCM_CAR (env)))
- {
- SCM names = SCM_CAAR (env);
- SCM values = SCM_CDAR (env);
- while (scm_is_pair (names))
- {
- if (scm_is_eq (SCM_CAR (values), data))
- return SCM_CAR (names);
- names = SCM_CDR (names);
- values = SCM_CDR (values);
- }
- if (!scm_is_null (names) && scm_is_eq (values, data))
- return names;
- env = SCM_CDR (env);
- }
- return SCM_BOOL_F;
- }
- #ifdef GUILE_DEBUG
- SCM_DEFINE (scm_debug_hang, "debug-hang", 0, 1, 0,
- (SCM obj),
- "Go into an endless loop, which can be only terminated with\n"
- "a debugger.")
- #define FUNC_NAME s_scm_debug_hang
- {
- int go = 0;
- while (!go) ;
- return SCM_UNSPECIFIED;
- }
- #undef FUNC_NAME
- #endif
- static SCM local_eval_var;
- static void
- init_local_eval_var (void)
- {
- local_eval_var = scm_c_public_variable ("ice-9 local-eval", "local-eval");
- }
- SCM
- scm_local_eval (SCM exp, SCM env)
- {
- static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
- scm_i_pthread_once (&once, init_local_eval_var);
- return scm_call_2 (scm_variable_ref (local_eval_var), exp, env);
- }
- static void
- init_stack_limit (void)
- {
- #if defined HAVE_GETRLIMIT
- struct rlimit lim;
- if (getrlimit (RLIMIT_STACK, &lim) == 0)
- {
- rlim_t bytes = lim.rlim_cur;
-
- if (bytes == RLIM_INFINITY)
- bytes = lim.rlim_max;
- if (bytes != RLIM_INFINITY)
- SCM_STACK_LIMIT = bytes * 8 / 10 / sizeof (scm_t_bits);
- }
- errno = 0;
- #elif defined __MINGW32__
- MEMORY_BASIC_INFORMATION m;
- uintptr_t bytes;
- if (VirtualQuery ((LPCVOID) &m, &m, sizeof m))
- {
- bytes = (DWORD_PTR) m.BaseAddress + m.RegionSize
- - (DWORD_PTR) m.AllocationBase;
- SCM_STACK_LIMIT = bytes * 8 / 10 / sizeof (scm_t_bits);
- }
- #endif
- }
- void
- scm_init_debug ()
- {
- init_stack_limit ();
- scm_init_opts (scm_debug_options, scm_debug_opts);
- scm_add_feature ("debug-extensions");
- #include "libguile/debug.x"
- }
|