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