libguile/stackchk.c

   1 /*      Copyright (C) 1995,1996,1997, 2000, 2001, 2006, 2008, 2010 Free Software Foundation, Inc.
   2  *
   3  * This library is free software; you can redistribute it and/or
   4  * modify it under the terms of the GNU Lesser General Public License
   5  * as published by the Free Software Foundation; either version 3 of
   6  * the License, or (at your option) any later version.
   7  *
   8  * This library is distributed in the hope that it will be useful, but
   9  * WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11  * Lesser General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU Lesser General Public
  14  * License along with this library; if not, write to the Free Software
  15  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  16  * 02110-1301 USA
  17  */
  18
  19
  20 \f
  21 #ifdef HAVE_CONFIG_H
  22 # include <config.h>
  23 #endif
  24
  25 #include "libguile/_scm.h"
  26 #include "libguile/ports.h"
  27 #include "libguile/root.h"
  28 #include "libguile/threads.h"
  29 #include "libguile/dynwind.h"
  30
  31 #include "libguile/stackchk.h"
  32 \f
  33
  34 /* {Stack Checking}
  35  */
  36
  37 #ifdef STACK_CHECKING
  38 int scm_stack_checking_enabled_p;
  39
  40 SCM_SYMBOL (scm_stack_overflow_key, "stack-overflow");
  41
  42 static void
  43 reset_scm_stack_checking_enabled_p (void *arg)
  44 {
  45   scm_stack_checking_enabled_p = (int)(scm_t_bits)arg;
  46 }
  47
  48 void
  49 scm_report_stack_overflow ()
  50 {
  51   scm_dynwind_begin (0); /* non-rewindable frame */
  52   scm_dynwind_unwind_handler (reset_scm_stack_checking_enabled_p,
  53                               (void*)(scm_t_bits)scm_stack_checking_enabled_p,
  54                               SCM_F_WIND_EXPLICITLY);
  55
  56   scm_stack_checking_enabled_p = 0;
  57
  58   scm_error (scm_stack_overflow_key,
  59              NULL,
  60              "Stack overflow",
  61              SCM_BOOL_F,
  62              SCM_BOOL_F);
  63
  64   /* not reached */
  65   scm_dynwind_end ();
  66 }
  67
  68 #endif
  69
  70 long
  71 scm_stack_size (SCM_STACKITEM *start)
  72 {
  73   SCM_STACKITEM stack;
  74 #if SCM_STACK_GROWS_UP
  75   return &stack - start;
  76 #else
  77   return start - &stack;
  78 #endif /* SCM_STACK_GROWS_UP */
  79 }
  80
  81
  82 void
  83 scm_stack_report ()
  84 {
  85   SCM port = scm_current_error_port ();
  86   SCM_STACKITEM stack;
  87   scm_i_thread *thread = SCM_I_CURRENT_THREAD;
  88
  89   scm_uintprint ((scm_stack_size (thread->continuation_base)
  90                   * sizeof (SCM_STACKITEM)),
  91                  16, port);
  92   scm_puts (" of stack: 0x", port);
  93   scm_uintprint ((scm_t_bits) thread->continuation_base, 16, port);
  94   scm_puts (" - 0x", port);
  95   scm_uintprint ((scm_t_bits) &stack, 16, port);
  96   scm_puts ("\n", port);
  97 }
  98
  99
 100 SCM_DEFINE (scm_sys_get_stack_size, "%get-stack-size", 0, 0, 0,
 101             (),
 102             "Return the current thread's C stack size (in Scheme objects).")
 103 #define FUNC_NAME s_scm_sys_get_stack_size
 104 {
 105   return scm_from_long (scm_stack_size (SCM_I_CURRENT_THREAD->base));
 106 }
 107 #undef FUNC_NAME
 108
 109
 110 void
 111 scm_init_stackchk ()
 112 {
 113 #include "libguile/stackchk.x"
 114 }
 115
 116 /*
 117   Local Variables:
 118   c-file-style: "gnu"
 119   End:
 120 */