git.chise.org Git - chise/xemacs-chise.git.1/blob - src/backtrace.h

   1 /* The lisp stack.
   2    Copyright (C) 1985, 1986, 1987, 1992, 1993 Free Software Foundation, Inc.
   3
   4 This file is part of XEmacs.
   5
   6 XEmacs is free software; you can redistribute it and/or modify it
   7 under the terms of the GNU General Public License as published by the
   8 Free Software Foundation; either version 2, or (at your option) any
   9 later version.
  10
  11 XEmacs is distributed in the hope that it will be useful, but WITHOUT
  12 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  13 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  14 for more details.
  15
  16 You should have received a copy of the GNU General Public License
  17 along with XEmacs; see the file COPYING.  If not, write to
  18 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  19 Boston, MA 02111-1307, USA.  */
  20
  21 /* Synched up with: FSF 19.30.  Contained redundantly in various C files
  22    in FSFmacs. */
  23
  24 /* Authorship:
  25
  26    FSF: Original version; a long time ago.
  27    XEmacs: split out of some C files. (For some obscure reason, a header
  28            file couldn't be used in FSF Emacs, but XEmacs doesn't have
  29            that problem.)
  30    Mly (probably) or JWZ: Some changes.
  31  */
  32
  33 #ifndef INCLUDED_backtrace_h_
  34 #define INCLUDED_backtrace_h_
  35
  36 #include <setjmp.h>
  37
  38 /* These definitions are used in eval.c and alloc.c */
  39
  40 struct backtrace
  41   {
  42     struct backtrace *next;
  43     Lisp_Object *function;
  44     Lisp_Object *args;          /* Points to vector of args. */
  45     int nargs;                  /* Length of vector.
  46                                    If nargs is UNEVALLED, args points to
  47                                    slot holding list of unevalled args */
  48     int pdlcount;               /* specpdl_depth () when invoked */
  49     char evalargs;
  50     /* Nonzero means call value of debugger when done with this operation. */
  51     char debug_on_exit;
  52   };
  53
  54 /* This structure helps implement the `catch' and `throw' control
  55    structure.  A struct catchtag contains all the information needed
  56    to restore the state of the interpreter after a non-local jump.
  57
  58    Handlers for error conditions (represented by `struct handler'
  59    structures) just point to a catch tag to do the cleanup required
  60    for their jumps.
  61
  62    catchtag structures are chained together in the C calling stack;
  63    the `next' member points to the next outer catchtag.
  64
  65    A call like (throw TAG VAL) searches for a catchtag whose `tag'
  66    member is TAG, and then unbinds to it.  The `val' member is used to
  67    hold VAL while the stack is unwound; `val' is returned as the value
  68    of the catch form.
  69
  70    All the other members are concerned with restoring the interpreter
  71    state.  */
  72
  73 struct catchtag
  74   {
  75     Lisp_Object tag;
  76     Lisp_Object val;
  77     struct catchtag *next;
  78     struct gcpro *gcpro;
  79     JMP_BUF jmp;
  80     struct backtrace *backlist;
  81 #if 0 /* FSFmacs */
  82     /* #### */
  83     struct handler *handlerlist;
  84 #endif
  85     int lisp_eval_depth;
  86     int pdlcount;
  87 #if 0 /* FSFmacs */
  88     /* This is the equivalent of async_timer_suppress_count.
  89        We probably don't have to bother with this. */
  90     int poll_suppress_count;
  91 #endif
  92   };
  93
  94 /* Dynamic-binding-o-rama */
  95
  96 /* Structure for recording Lisp call stack for backtrace purposes.  */
  97
  98 /* The special binding stack holds the outer values of variables while
  99    they are bound by a function application or a let form, stores the
 100    code to be executed for Lisp unwind-protect forms, and stores the C
 101    functions to be called for record_unwind_protect.
 102
 103    If func is non-zero, undoing this binding applies func to old_value;
 104       This implements record_unwind_protect.
 105    If func is zero and symbol is nil, undoing this binding evaluates
 106       the list of forms in old_value; this implements Lisp's unwind-protect
 107       form.
 108    Otherwise, undoing this binding stores old_value as symbol's value; this
 109       undoes the bindings made by a let form or function call.  */
 110
 111 struct specbinding
 112   {
 113     Lisp_Object symbol;
 114     Lisp_Object old_value;
 115     Lisp_Object (*func) (Lisp_Object); /* for unwind-protect */
 116   };
 117
 118 #if 0 /* FSFmacs */
 119 /* #### */
 120 /* Everything needed to describe an active condition case.  */
 121 struct handler
 122   {
 123     /* The handler clauses and variable from the condition-case form.  */
 124     Lisp_Object handler;
 125     Lisp_Object var;
 126     /* Fsignal stores here the condition-case clause that applies,
 127        and Fcondition_case thus knows which clause to run.  */
 128     Lisp_Object chosen_clause;
 129
 130     /* Used to effect the longjmp() out to the handler.  */
 131     struct catchtag *tag;
 132
 133     /* The next enclosing handler.  */
 134     struct handler *next;
 135   };
 136
 137 extern struct handler *handlerlist;
 138
 139 #endif
 140
 141 /* These are extern because GC needs to mark them */
 142 extern struct specbinding *specpdl;
 143 extern struct specbinding *specpdl_ptr;
 144 extern struct catchtag *catchlist;
 145 extern struct backtrace *backtrace_list;
 146
 147 /* Most callers should simply use specbind() and unbind_to(), but if
 148    speed is REALLY IMPORTANT, you can use the faster macros below */
 149 void specbind_magic (Lisp_Object, Lisp_Object);
 150 void grow_specpdl (size_t reserved);
 151 void unbind_to_hairy (int);
 152 extern int specpdl_size;
 153
 154 /* Inline version of specbind().
 155    Use this instead of specbind() if speed is sufficiently important
 156    to save the overhead of even a single function call. */
 157 #define SPECBIND(symbol_object, value_object) do {                      \
 158   Lisp_Object SB_symbol = (symbol_object);                              \
 159   Lisp_Object SB_newval = (value_object);                               \
 160   Lisp_Object SB_oldval;                                                \
 161   Lisp_Symbol *SB_sym;                                                  \
 162                                                                         \
 163   SPECPDL_RESERVE (1);                                                  \
 164                                                                         \
 165   CHECK_SYMBOL (SB_symbol);                                             \
 166   SB_sym = XSYMBOL (SB_symbol);                                         \
 167   SB_oldval = SB_sym->value;                                            \
 168                                                                         \
 169   if (!SYMBOL_VALUE_MAGIC_P (SB_oldval) || UNBOUNDP (SB_oldval))        \
 170     {                                                                   \
 171       /* #### the following test will go away when we have a constant   \
 172          symbol magic object */                                         \
 173       if (EQ (SB_symbol, Qnil) ||                                       \
 174           EQ (SB_symbol, Qt)   ||                                       \
 175           SYMBOL_IS_KEYWORD (SB_symbol))                                \
 176         reject_constant_symbols (SB_symbol, SB_newval, 0,               \
 177                                  UNBOUNDP (SB_newval) ?                 \
 178                                  Qmakunbound : Qset);                   \
 179                                                                         \
 180       specpdl_ptr->symbol    = SB_symbol;                               \
 181       specpdl_ptr->old_value = SB_oldval;                               \
 182       specpdl_ptr->func      = 0;                                       \
 183       specpdl_ptr++;                                                    \
 184       specpdl_depth_counter++;                                          \
 185                                                                         \
 186       SB_sym->value = (SB_newval);                                      \
 187     }                                                                   \
 188   else                                                                  \
 189     specbind_magic (SB_symbol, SB_newval);                              \
 190 } while (0)
 191
 192 /* An even faster, but less safe inline version of specbind().
 193    Caller guarantees that:
 194    - SYMBOL is a non-constant symbol (i.e. not Qnil, Qt, or keyword).
 195    - specpdl_depth_counter >= specpdl_size.
 196    Else we crash.  */
 197 #define SPECBIND_FAST_UNSAFE(symbol_object, value_object) do {          \
 198   Lisp_Object SFU_symbol = (symbol_object);                             \
 199   Lisp_Object SFU_newval = (value_object);                              \
 200   Lisp_Symbol *SFU_sym   = XSYMBOL (SFU_symbol);                        \
 201   Lisp_Object SFU_oldval = SFU_sym->value;                              \
 202   if (!SYMBOL_VALUE_MAGIC_P (SFU_oldval) || UNBOUNDP (SFU_oldval))      \
 203     {                                                                   \
 204       specpdl_ptr->symbol    = SFU_symbol;                              \
 205       specpdl_ptr->old_value = SFU_oldval;                              \
 206       specpdl_ptr->func      = 0;                                       \
 207       specpdl_ptr++;                                                    \
 208       specpdl_depth_counter++;                                          \
 209                                                                         \
 210       SFU_sym->value = (SFU_newval);                                    \
 211     }                                                                   \
 212   else                                                                  \
 213     specbind_magic (SFU_symbol, SFU_newval);                            \
 214 } while (0)
 215
 216 /* Request enough room for SIZE future entries on special binding stack */
 217 #define SPECPDL_RESERVE(size) do {                      \
 218   size_t SR_size = (size);                              \
 219   if (specpdl_depth() + SR_size >= specpdl_size)        \
 220     grow_specpdl (SR_size);                             \
 221 } while (0)
 222
 223 /* Inline version of unbind_to().
 224    Use this instead of unbind_to() if speed is sufficiently important
 225    to save the overhead of even a single function call.
 226
 227    Most of the time, unbind_to() is called only on ordinary
 228    variables, so optimize for that.  */
 229 #define UNBIND_TO_GCPRO(count, value) do {              \
 230   int UNBIND_TO_count = (count);                        \
 231   while (specpdl_depth_counter != UNBIND_TO_count)      \
 232     {                                                   \
 233       Lisp_Symbol *sym;                                 \
 234       --specpdl_ptr;                                    \
 235       --specpdl_depth_counter;                          \
 236                                                         \
 237       if (specpdl_ptr->func != 0 ||                     \
 238           ((sym = XSYMBOL (specpdl_ptr->symbol)),       \
 239            SYMBOL_VALUE_MAGIC_P (sym->value)))          \
 240         {                                               \
 241           struct gcpro gcpro1;                          \
 242           GCPRO1 (value);                               \
 243           unbind_to_hairy (UNBIND_TO_count);            \
 244           UNGCPRO;                                      \
 245           break;                                        \
 246         }                                               \
 247                                                         \
 248       sym->value = specpdl_ptr->old_value;              \
 249     }                                                   \
 250 } while (0)
 251
 252 /* A slightly faster inline version of unbind_to,
 253    that doesn't offer GCPROing services. */
 254 #define UNBIND_TO(count) do {                           \
 255   int UNBIND_TO_count = (count);                        \
 256   while (specpdl_depth_counter != UNBIND_TO_count)      \
 257     {                                                   \
 258       Lisp_Symbol *sym;                                 \
 259       --specpdl_ptr;                                    \
 260       --specpdl_depth_counter;                          \
 261                                                         \
 262       if (specpdl_ptr->func != 0 ||                     \
 263           ((sym = XSYMBOL (specpdl_ptr->symbol)),       \
 264            SYMBOL_VALUE_MAGIC_P (sym->value)))          \
 265         {                                               \
 266           unbind_to_hairy (UNBIND_TO_count);            \
 267           break;                                        \
 268         }                                               \
 269                                                         \
 270       sym->value = specpdl_ptr->old_value;              \
 271     }                                                   \
 272 } while (0)
 273
 274 #ifdef ERROR_CHECK_TYPECHECK
 275 #define CHECK_SPECBIND_VARIABLE assert (specpdl_ptr->func == 0)
 276 #else
 277 #define CHECK_SPECBIND_VARIABLE DO_NOTHING
 278 #endif
 279
 280 #if 0
 281 /* Unused.  It's too hard to guarantee that the current bindings
 282    contain only variables.  */
 283 /* Another inline version of unbind_to().  VALUE is GC-protected.
 284    Caller guarantees that:
 285    - all of the elements on the binding stack are variable bindings.
 286    Else we crash.  */
 287 #define UNBIND_TO_GCPRO_VARIABLES_ONLY(count, value) do {       \
 288   int UNBIND_TO_count = (count);                                \
 289   while (specpdl_depth_counter != UNBIND_TO_count)              \
 290     {                                                           \
 291       Lisp_Symbol *sym;                                         \
 292       --specpdl_ptr;                                            \
 293       --specpdl_depth_counter;                                  \
 294                                                                 \
 295       CHECK_SPECBIND_VARIABLE;                                  \
 296       sym = XSYMBOL (specpdl_ptr->symbol);                      \
 297       if (!SYMBOL_VALUE_MAGIC_P (sym->value))                   \
 298         sym->value = specpdl_ptr->old_value;                    \
 299       else                                                      \
 300         {                                                       \
 301           struct gcpro gcpro1;                                  \
 302           GCPRO1 (value);                                       \
 303           unbind_to_hairy (UNBIND_TO_count);                    \
 304           UNGCPRO;                                              \
 305           break;                                                \
 306         }                                                       \
 307     }                                                           \
 308 } while (0)
 309 #endif /* unused */
 310
 311 /* A faster, but less safe inline version of Fset().
 312    Caller guarantees that:
 313    - SYMBOL is a non-constant symbol (i.e. not Qnil, Qt, or keyword).
 314    Else we crash.  */
 315 #define FSET_FAST_UNSAFE(sym, newval) do {                              \
 316   Lisp_Object FFU_sym = (sym);                                          \
 317   Lisp_Object FFU_newval = (newval);                                    \
 318   Lisp_Symbol *FFU_symbol = XSYMBOL (FFU_sym);                          \
 319   Lisp_Object FFU_oldval = FFU_symbol->value;                           \
 320   if (!SYMBOL_VALUE_MAGIC_P (FFU_oldval) || UNBOUNDP (FFU_oldval))      \
 321     FFU_symbol->value = FFU_newval;                                     \
 322   else                                                                  \
 323     Fset (FFU_sym, FFU_newval);                                         \
 324 } while (0)
 325
 326 #endif /* INCLUDED_backtrace_h_ */