428
+ − 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
440
+ − 33 #ifndef INCLUDED_backtrace_h_
+ − 34 #define INCLUDED_backtrace_h_
428
+ − 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 */
617
+ − 82 /* FSF uses a separate handler stack to hold condition-cases,
+ − 83 where we use Vcondition_handlers. We should switch to their
+ − 84 system becaue it avoids the need to mess around with consing
+ − 85 up stuff and then dangerously freeing it. See comment in
+ − 86 condition_case_unwind(). */
428
+ − 87 struct handler *handlerlist;
+ − 88 #endif
+ − 89 int lisp_eval_depth;
+ − 90 int pdlcount;
+ − 91 #if 0 /* FSFmacs */
+ − 92 /* This is the equivalent of async_timer_suppress_count.
+ − 93 We probably don't have to bother with this. */
+ − 94 int poll_suppress_count;
+ − 95 #endif
+ − 96 };
+ − 97
+ − 98 /* Dynamic-binding-o-rama */
+ − 99
+ − 100 /* Structure for recording Lisp call stack for backtrace purposes. */
+ − 101
+ − 102 /* The special binding stack holds the outer values of variables while
+ − 103 they are bound by a function application or a let form, stores the
+ − 104 code to be executed for Lisp unwind-protect forms, and stores the C
+ − 105 functions to be called for record_unwind_protect.
+ − 106
+ − 107 If func is non-zero, undoing this binding applies func to old_value;
+ − 108 This implements record_unwind_protect.
+ − 109 If func is zero and symbol is nil, undoing this binding evaluates
+ − 110 the list of forms in old_value; this implements Lisp's unwind-protect
+ − 111 form.
+ − 112 Otherwise, undoing this binding stores old_value as symbol's value; this
+ − 113 undoes the bindings made by a let form or function call. */
+ − 114
+ − 115 struct specbinding
+ − 116 {
+ − 117 Lisp_Object symbol;
+ − 118 Lisp_Object old_value;
+ − 119 Lisp_Object (*func) (Lisp_Object); /* for unwind-protect */
+ − 120 };
+ − 121
+ − 122 #if 0 /* FSFmacs */
+ − 123 /* #### */
+ − 124 /* Everything needed to describe an active condition case. */
+ − 125 struct handler
+ − 126 {
+ − 127 /* The handler clauses and variable from the condition-case form. */
+ − 128 Lisp_Object handler;
+ − 129 Lisp_Object var;
+ − 130 /* Fsignal stores here the condition-case clause that applies,
+ − 131 and Fcondition_case thus knows which clause to run. */
+ − 132 Lisp_Object chosen_clause;
+ − 133
+ − 134 /* Used to effect the longjmp() out to the handler. */
+ − 135 struct catchtag *tag;
+ − 136
+ − 137 /* The next enclosing handler. */
+ − 138 struct handler *next;
+ − 139 };
+ − 140
+ − 141 extern struct handler *handlerlist;
+ − 142
+ − 143 #endif
+ − 144
+ − 145 /* These are extern because GC needs to mark them */
+ − 146 extern struct specbinding *specpdl;
+ − 147 extern struct specbinding *specpdl_ptr;
+ − 148 extern struct catchtag *catchlist;
+ − 149 extern struct backtrace *backtrace_list;
+ − 150
+ − 151 /* Most callers should simply use specbind() and unbind_to(), but if
+ − 152 speed is REALLY IMPORTANT, you can use the faster macros below */
+ − 153 void specbind_magic (Lisp_Object, Lisp_Object);
647
+ − 154 void grow_specpdl (EMACS_INT reserved);
428
+ − 155 void unbind_to_hairy (int);
+ − 156 extern int specpdl_size;
+ − 157
+ − 158 /* Inline version of specbind().
+ − 159 Use this instead of specbind() if speed is sufficiently important
+ − 160 to save the overhead of even a single function call. */
+ − 161 #define SPECBIND(symbol_object, value_object) do { \
+ − 162 Lisp_Object SB_symbol = (symbol_object); \
+ − 163 Lisp_Object SB_newval = (value_object); \
+ − 164 Lisp_Object SB_oldval; \
440
+ − 165 Lisp_Symbol *SB_sym; \
428
+ − 166 \
+ − 167 SPECPDL_RESERVE (1); \
+ − 168 \
+ − 169 CHECK_SYMBOL (SB_symbol); \
+ − 170 SB_sym = XSYMBOL (SB_symbol); \
+ − 171 SB_oldval = SB_sym->value; \
+ − 172 \
+ − 173 if (!SYMBOL_VALUE_MAGIC_P (SB_oldval) || UNBOUNDP (SB_oldval)) \
+ − 174 { \
440
+ − 175 /* #### the following test will go away when we have a constant \
428
+ − 176 symbol magic object */ \
+ − 177 if (EQ (SB_symbol, Qnil) || \
+ − 178 EQ (SB_symbol, Qt) || \
+ − 179 SYMBOL_IS_KEYWORD (SB_symbol)) \
+ − 180 reject_constant_symbols (SB_symbol, SB_newval, 0, \
+ − 181 UNBOUNDP (SB_newval) ? \
+ − 182 Qmakunbound : Qset); \
+ − 183 \
+ − 184 specpdl_ptr->symbol = SB_symbol; \
+ − 185 specpdl_ptr->old_value = SB_oldval; \
+ − 186 specpdl_ptr->func = 0; \
+ − 187 specpdl_ptr++; \
+ − 188 specpdl_depth_counter++; \
+ − 189 \
+ − 190 SB_sym->value = (SB_newval); \
+ − 191 } \
+ − 192 else \
+ − 193 specbind_magic (SB_symbol, SB_newval); \
+ − 194 } while (0)
+ − 195
+ − 196 /* An even faster, but less safe inline version of specbind().
+ − 197 Caller guarantees that:
+ − 198 - SYMBOL is a non-constant symbol (i.e. not Qnil, Qt, or keyword).
+ − 199 - specpdl_depth_counter >= specpdl_size.
+ − 200 Else we crash. */
+ − 201 #define SPECBIND_FAST_UNSAFE(symbol_object, value_object) do { \
+ − 202 Lisp_Object SFU_symbol = (symbol_object); \
+ − 203 Lisp_Object SFU_newval = (value_object); \
440
+ − 204 Lisp_Symbol *SFU_sym = XSYMBOL (SFU_symbol); \
428
+ − 205 Lisp_Object SFU_oldval = SFU_sym->value; \
+ − 206 if (!SYMBOL_VALUE_MAGIC_P (SFU_oldval) || UNBOUNDP (SFU_oldval)) \
+ − 207 { \
+ − 208 specpdl_ptr->symbol = SFU_symbol; \
+ − 209 specpdl_ptr->old_value = SFU_oldval; \
+ − 210 specpdl_ptr->func = 0; \
+ − 211 specpdl_ptr++; \
+ − 212 specpdl_depth_counter++; \
+ − 213 \
+ − 214 SFU_sym->value = (SFU_newval); \
+ − 215 } \
+ − 216 else \
+ − 217 specbind_magic (SFU_symbol, SFU_newval); \
+ − 218 } while (0)
+ − 219
+ − 220 /* Request enough room for SIZE future entries on special binding stack */
+ − 221 #define SPECPDL_RESERVE(size) do { \
647
+ − 222 EMACS_INT SR_size = (size); \
428
+ − 223 if (specpdl_depth() + SR_size >= specpdl_size) \
+ − 224 grow_specpdl (SR_size); \
+ − 225 } while (0)
+ − 226
+ − 227 /* Inline version of unbind_to().
+ − 228 Use this instead of unbind_to() if speed is sufficiently important
+ − 229 to save the overhead of even a single function call.
+ − 230
+ − 231 Most of the time, unbind_to() is called only on ordinary
+ − 232 variables, so optimize for that. */
+ − 233 #define UNBIND_TO_GCPRO(count, value) do { \
+ − 234 int UNBIND_TO_count = (count); \
+ − 235 while (specpdl_depth_counter != UNBIND_TO_count) \
+ − 236 { \
440
+ − 237 Lisp_Symbol *sym; \
428
+ − 238 --specpdl_ptr; \
+ − 239 --specpdl_depth_counter; \
+ − 240 \
+ − 241 if (specpdl_ptr->func != 0 || \
+ − 242 ((sym = XSYMBOL (specpdl_ptr->symbol)), \
+ − 243 SYMBOL_VALUE_MAGIC_P (sym->value))) \
+ − 244 { \
+ − 245 struct gcpro gcpro1; \
+ − 246 GCPRO1 (value); \
+ − 247 unbind_to_hairy (UNBIND_TO_count); \
+ − 248 UNGCPRO; \
+ − 249 break; \
+ − 250 } \
+ − 251 \
+ − 252 sym->value = specpdl_ptr->old_value; \
+ − 253 } \
+ − 254 } while (0)
+ − 255
+ − 256 /* A slightly faster inline version of unbind_to,
+ − 257 that doesn't offer GCPROing services. */
+ − 258 #define UNBIND_TO(count) do { \
+ − 259 int UNBIND_TO_count = (count); \
+ − 260 while (specpdl_depth_counter != UNBIND_TO_count) \
+ − 261 { \
440
+ − 262 Lisp_Symbol *sym; \
428
+ − 263 --specpdl_ptr; \
+ − 264 --specpdl_depth_counter; \
+ − 265 \
+ − 266 if (specpdl_ptr->func != 0 || \
+ − 267 ((sym = XSYMBOL (specpdl_ptr->symbol)), \
+ − 268 SYMBOL_VALUE_MAGIC_P (sym->value))) \
+ − 269 { \
+ − 270 unbind_to_hairy (UNBIND_TO_count); \
+ − 271 break; \
+ − 272 } \
+ − 273 \
+ − 274 sym->value = specpdl_ptr->old_value; \
+ − 275 } \
+ − 276 } while (0)
+ − 277
+ − 278 #ifdef ERROR_CHECK_TYPECHECK
+ − 279 #define CHECK_SPECBIND_VARIABLE assert (specpdl_ptr->func == 0)
+ − 280 #else
+ − 281 #define CHECK_SPECBIND_VARIABLE DO_NOTHING
+ − 282 #endif
+ − 283
+ − 284 #if 0
+ − 285 /* Unused. It's too hard to guarantee that the current bindings
+ − 286 contain only variables. */
+ − 287 /* Another inline version of unbind_to(). VALUE is GC-protected.
+ − 288 Caller guarantees that:
+ − 289 - all of the elements on the binding stack are variable bindings.
+ − 290 Else we crash. */
+ − 291 #define UNBIND_TO_GCPRO_VARIABLES_ONLY(count, value) do { \
+ − 292 int UNBIND_TO_count = (count); \
+ − 293 while (specpdl_depth_counter != UNBIND_TO_count) \
+ − 294 { \
440
+ − 295 Lisp_Symbol *sym; \
428
+ − 296 --specpdl_ptr; \
+ − 297 --specpdl_depth_counter; \
+ − 298 \
+ − 299 CHECK_SPECBIND_VARIABLE; \
+ − 300 sym = XSYMBOL (specpdl_ptr->symbol); \
+ − 301 if (!SYMBOL_VALUE_MAGIC_P (sym->value)) \
+ − 302 sym->value = specpdl_ptr->old_value; \
+ − 303 else \
+ − 304 { \
+ − 305 struct gcpro gcpro1; \
+ − 306 GCPRO1 (value); \
+ − 307 unbind_to_hairy (UNBIND_TO_count); \
+ − 308 UNGCPRO; \
+ − 309 break; \
+ − 310 } \
+ − 311 } \
+ − 312 } while (0)
+ − 313 #endif /* unused */
+ − 314
+ − 315 /* A faster, but less safe inline version of Fset().
+ − 316 Caller guarantees that:
+ − 317 - SYMBOL is a non-constant symbol (i.e. not Qnil, Qt, or keyword).
+ − 318 Else we crash. */
+ − 319 #define FSET_FAST_UNSAFE(sym, newval) do { \
+ − 320 Lisp_Object FFU_sym = (sym); \
+ − 321 Lisp_Object FFU_newval = (newval); \
440
+ − 322 Lisp_Symbol *FFU_symbol = XSYMBOL (FFU_sym); \
428
+ − 323 Lisp_Object FFU_oldval = FFU_symbol->value; \
+ − 324 if (!SYMBOL_VALUE_MAGIC_P (FFU_oldval) || UNBOUNDP (FFU_oldval)) \
+ − 325 FFU_symbol->value = FFU_newval; \
+ − 326 else \
+ − 327 Fset (FFU_sym, FFU_newval); \
+ − 328 } while (0)
+ − 329
440
+ − 330 #endif /* INCLUDED_backtrace_h_ */
