aboutsummaryrefslogtreecommitdiffstats
path: root/src/eval.c
diff options
context:
space:
mode:
Diffstat (limited to 'src/eval.c')
-rw-r--r--src/eval.c485
1 files changed, 270 insertions, 215 deletions
diff --git a/src/eval.c b/src/eval.c
index 69483a9b205..d1d074df777 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -32,8 +32,6 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
32#include "xterm.h" 32#include "xterm.h"
33#endif 33#endif
34 34
35struct backtrace *backtrace_list;
36
37#if !BYTE_MARK_STACK 35#if !BYTE_MARK_STACK
38static 36static
39#endif 37#endif
@@ -105,7 +103,7 @@ static EMACS_INT when_entered_debugger;
105 103
106/* The function from which the last `signal' was called. Set in 104/* The function from which the last `signal' was called. Set in
107 Fsignal. */ 105 Fsignal. */
108 106/* FIXME: We should probably get rid of this! */
109Lisp_Object Vsignaling_function; 107Lisp_Object Vsignaling_function;
110 108
111/* If non-nil, Lisp code must not be run since some part of Emacs is 109/* If non-nil, Lisp code must not be run since some part of Emacs is
@@ -117,20 +115,48 @@ Lisp_Object inhibit_lisp_code;
117static Lisp_Object funcall_lambda (Lisp_Object, ptrdiff_t, Lisp_Object *); 115static Lisp_Object funcall_lambda (Lisp_Object, ptrdiff_t, Lisp_Object *);
118static Lisp_Object apply_lambda (Lisp_Object fun, Lisp_Object args); 116static Lisp_Object apply_lambda (Lisp_Object fun, Lisp_Object args);
119 117
120/* Functions to set Lisp_Object slots of struct specbinding. */ 118/* Functions to modify slots of backtrace records. */
119
120static void
121set_backtrace_args (struct specbinding *pdl, Lisp_Object *args)
122{ eassert (pdl->kind == SPECPDL_BACKTRACE); pdl->v.bt.args = args; }
123
124static void
125set_backtrace_nargs (struct specbinding *pdl, ptrdiff_t n)
126{ eassert (pdl->kind == SPECPDL_BACKTRACE); pdl->v.bt.nargs = n; }
121 127
122static void 128static void
123set_specpdl_symbol (Lisp_Object symbol) 129set_backtrace_debug_on_exit (struct specbinding *pdl, bool doe)
130{ eassert (pdl->kind == SPECPDL_BACKTRACE); pdl->v.bt.debug_on_exit = doe; }
131
132/* Helper functions to scan the backtrace. */
133
134bool backtrace_p (struct specbinding *) EXTERNALLY_VISIBLE;
135struct specbinding *backtrace_top (void) EXTERNALLY_VISIBLE;
136struct specbinding *backtrace_next (struct specbinding *pdl) EXTERNALLY_VISIBLE;
137
138bool backtrace_p (struct specbinding *pdl)
139{ return pdl >= specpdl; }
140
141struct specbinding *
142backtrace_top (void)
124{ 143{
125 specpdl_ptr->symbol = symbol; 144 struct specbinding *pdl = specpdl_ptr - 1;
145 while (backtrace_p (pdl) && pdl->kind != SPECPDL_BACKTRACE)
146 pdl--;
147 return pdl;
126} 148}
127 149
128static void 150struct specbinding *
129set_specpdl_old_value (Lisp_Object oldval) 151backtrace_next (struct specbinding *pdl)
130{ 152{
131 specpdl_ptr->old_value = oldval; 153 pdl--;
154 while (backtrace_p (pdl) && pdl->kind != SPECPDL_BACKTRACE)
155 pdl--;
156 return pdl;
132} 157}
133 158
159
134void 160void
135init_eval_once (void) 161init_eval_once (void)
136{ 162{
@@ -151,7 +177,6 @@ init_eval (void)
151 specpdl_ptr = specpdl; 177 specpdl_ptr = specpdl;
152 catchlist = 0; 178 catchlist = 0;
153 handlerlist = 0; 179 handlerlist = 0;
154 backtrace_list = 0;
155 Vquit_flag = Qnil; 180 Vquit_flag = Qnil;
156 debug_on_next_call = 0; 181 debug_on_next_call = 0;
157 lisp_eval_depth = 0; 182 lisp_eval_depth = 0;
@@ -234,7 +259,7 @@ static void
234do_debug_on_call (Lisp_Object code) 259do_debug_on_call (Lisp_Object code)
235{ 260{
236 debug_on_next_call = 0; 261 debug_on_next_call = 0;
237 backtrace_list->debug_on_exit = 1; 262 set_backtrace_debug_on_exit (specpdl_ptr - 1, true);
238 call_debugger (Fcons (code, Qnil)); 263 call_debugger (Fcons (code, Qnil));
239} 264}
240 265
@@ -530,9 +555,8 @@ The return value is BASE-VARIABLE. */)
530 struct specbinding *p; 555 struct specbinding *p;
531 556
532 for (p = specpdl_ptr; p > specpdl; ) 557 for (p = specpdl_ptr; p > specpdl; )
533 if ((--p)->func == NULL 558 if ((--p)->kind >= SPECPDL_LET
534 && (EQ (new_alias, 559 && (EQ (new_alias, specpdl_symbol (p))))
535 CONSP (p->symbol) ? XCAR (p->symbol) : p->symbol)))
536 error ("Don't know how to make a let-bound variable an alias"); 560 error ("Don't know how to make a let-bound variable an alias");
537 } 561 }
538 562
@@ -597,8 +621,9 @@ usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */)
597 struct specbinding *pdl = specpdl_ptr; 621 struct specbinding *pdl = specpdl_ptr;
598 while (pdl > specpdl) 622 while (pdl > specpdl)
599 { 623 {
600 if (EQ ((--pdl)->symbol, sym) && !pdl->func 624 if ((--pdl)->kind >= SPECPDL_LET
601 && EQ (pdl->old_value, Qunbound)) 625 && EQ (specpdl_symbol (pdl), sym)
626 && EQ (specpdl_old_value (pdl), Qunbound))
602 { 627 {
603 message_with_string 628 message_with_string
604 ("Warning: defvar ignored because %s is let-bound", 629 ("Warning: defvar ignored because %s is let-bound",
@@ -937,7 +962,7 @@ usage: (catch TAG BODY...) */)
937 962
938/* Set up a catch, then call C function FUNC on argument ARG. 963/* Set up a catch, then call C function FUNC on argument ARG.
939 FUNC should return a Lisp_Object. 964 FUNC should return a Lisp_Object.
940 This is how catches are done from within C code. */ 965 This is how catches are done from within C code. */
941 966
942Lisp_Object 967Lisp_Object
943internal_catch (Lisp_Object tag, Lisp_Object (*func) (Lisp_Object), Lisp_Object arg) 968internal_catch (Lisp_Object tag, Lisp_Object (*func) (Lisp_Object), Lisp_Object arg)
@@ -949,7 +974,6 @@ internal_catch (Lisp_Object tag, Lisp_Object (*func) (Lisp_Object), Lisp_Object
949 c.next = catchlist; 974 c.next = catchlist;
950 c.tag = tag; 975 c.tag = tag;
951 c.val = Qnil; 976 c.val = Qnil;
952 c.backlist = backtrace_list;
953 c.handlerlist = handlerlist; 977 c.handlerlist = handlerlist;
954 c.lisp_eval_depth = lisp_eval_depth; 978 c.lisp_eval_depth = lisp_eval_depth;
955 c.pdlcount = SPECPDL_INDEX (); 979 c.pdlcount = SPECPDL_INDEX ();
@@ -1014,7 +1038,6 @@ unwind_to_catch (struct catchtag *catch, Lisp_Object value)
1014#ifdef DEBUG_GCPRO 1038#ifdef DEBUG_GCPRO
1015 gcpro_level = gcprolist ? gcprolist->level + 1 : 0; 1039 gcpro_level = gcprolist ? gcprolist->level + 1 : 0;
1016#endif 1040#endif
1017 backtrace_list = catch->backlist;
1018 lisp_eval_depth = catch->lisp_eval_depth; 1041 lisp_eval_depth = catch->lisp_eval_depth;
1019 1042
1020 sys_longjmp (catch->jmp, 1); 1043 sys_longjmp (catch->jmp, 1);
@@ -1115,7 +1138,6 @@ internal_lisp_condition_case (volatile Lisp_Object var, Lisp_Object bodyform,
1115 1138
1116 c.tag = Qnil; 1139 c.tag = Qnil;
1117 c.val = Qnil; 1140 c.val = Qnil;
1118 c.backlist = backtrace_list;
1119 c.handlerlist = handlerlist; 1141 c.handlerlist = handlerlist;
1120 c.lisp_eval_depth = lisp_eval_depth; 1142 c.lisp_eval_depth = lisp_eval_depth;
1121 c.pdlcount = SPECPDL_INDEX (); 1143 c.pdlcount = SPECPDL_INDEX ();
@@ -1131,7 +1153,7 @@ internal_lisp_condition_case (volatile Lisp_Object var, Lisp_Object bodyform,
1131 1153
1132 /* Note that this just undoes the binding of h.var; whoever 1154 /* Note that this just undoes the binding of h.var; whoever
1133 longjumped to us unwound the stack to c.pdlcount before 1155 longjumped to us unwound the stack to c.pdlcount before
1134 throwing. */ 1156 throwing. */
1135 unbind_to (c.pdlcount, Qnil); 1157 unbind_to (c.pdlcount, Qnil);
1136 return val; 1158 return val;
1137 } 1159 }
@@ -1170,7 +1192,6 @@ internal_condition_case (Lisp_Object (*bfun) (void), Lisp_Object handlers,
1170 1192
1171 c.tag = Qnil; 1193 c.tag = Qnil;
1172 c.val = Qnil; 1194 c.val = Qnil;
1173 c.backlist = backtrace_list;
1174 c.handlerlist = handlerlist; 1195 c.handlerlist = handlerlist;
1175 c.lisp_eval_depth = lisp_eval_depth; 1196 c.lisp_eval_depth = lisp_eval_depth;
1176 c.pdlcount = SPECPDL_INDEX (); 1197 c.pdlcount = SPECPDL_INDEX ();
@@ -1208,7 +1229,6 @@ internal_condition_case_1 (Lisp_Object (*bfun) (Lisp_Object), Lisp_Object arg,
1208 1229
1209 c.tag = Qnil; 1230 c.tag = Qnil;
1210 c.val = Qnil; 1231 c.val = Qnil;
1211 c.backlist = backtrace_list;
1212 c.handlerlist = handlerlist; 1232 c.handlerlist = handlerlist;
1213 c.lisp_eval_depth = lisp_eval_depth; 1233 c.lisp_eval_depth = lisp_eval_depth;
1214 c.pdlcount = SPECPDL_INDEX (); 1234 c.pdlcount = SPECPDL_INDEX ();
@@ -1250,7 +1270,6 @@ internal_condition_case_2 (Lisp_Object (*bfun) (Lisp_Object, Lisp_Object),
1250 1270
1251 c.tag = Qnil; 1271 c.tag = Qnil;
1252 c.val = Qnil; 1272 c.val = Qnil;
1253 c.backlist = backtrace_list;
1254 c.handlerlist = handlerlist; 1273 c.handlerlist = handlerlist;
1255 c.lisp_eval_depth = lisp_eval_depth; 1274 c.lisp_eval_depth = lisp_eval_depth;
1256 c.pdlcount = SPECPDL_INDEX (); 1275 c.pdlcount = SPECPDL_INDEX ();
@@ -1294,7 +1313,6 @@ internal_condition_case_n (Lisp_Object (*bfun) (ptrdiff_t, Lisp_Object *),
1294 1313
1295 c.tag = Qnil; 1314 c.tag = Qnil;
1296 c.val = Qnil; 1315 c.val = Qnil;
1297 c.backlist = backtrace_list;
1298 c.handlerlist = handlerlist; 1316 c.handlerlist = handlerlist;
1299 c.lisp_eval_depth = lisp_eval_depth; 1317 c.lisp_eval_depth = lisp_eval_depth;
1300 c.pdlcount = SPECPDL_INDEX (); 1318 c.pdlcount = SPECPDL_INDEX ();
@@ -1362,7 +1380,6 @@ See also the function `condition-case'. */)
1362 = (NILP (error_symbol) ? Fcar (data) : error_symbol); 1380 = (NILP (error_symbol) ? Fcar (data) : error_symbol);
1363 register Lisp_Object clause = Qnil; 1381 register Lisp_Object clause = Qnil;
1364 struct handler *h; 1382 struct handler *h;
1365 struct backtrace *bp;
1366 1383
1367 immediate_quit = 0; 1384 immediate_quit = 0;
1368 abort_on_gc = 0; 1385 abort_on_gc = 0;
@@ -1398,13 +1415,13 @@ See also the function `condition-case'. */)
1398 too. Don't do this when ERROR_SYMBOL is nil, because that 1415 too. Don't do this when ERROR_SYMBOL is nil, because that
1399 is a memory-full error. */ 1416 is a memory-full error. */
1400 Vsignaling_function = Qnil; 1417 Vsignaling_function = Qnil;
1401 if (backtrace_list && !NILP (error_symbol)) 1418 if (!NILP (error_symbol))
1402 { 1419 {
1403 bp = backtrace_list->next; 1420 struct specbinding *pdl = backtrace_next (backtrace_top ());
1404 if (bp && EQ (bp->function, Qerror)) 1421 if (backtrace_p (pdl) && EQ (backtrace_function (pdl), Qerror))
1405 bp = bp->next; 1422 pdl = backtrace_next (pdl);
1406 if (bp) 1423 if (backtrace_p (pdl))
1407 Vsignaling_function = bp->function; 1424 Vsignaling_function = backtrace_function (pdl);
1408 } 1425 }
1409 1426
1410 for (h = handlerlist; h; h = h->next) 1427 for (h = handlerlist; h; h = h->next)
@@ -1901,6 +1918,36 @@ If LEXICAL is t, evaluate using lexical scoping. */)
1901 return unbind_to (count, eval_sub (form)); 1918 return unbind_to (count, eval_sub (form));
1902} 1919}
1903 1920
1921static void
1922grow_specpdl (void)
1923{
1924 register ptrdiff_t count = SPECPDL_INDEX ();
1925 ptrdiff_t max_size = min (max_specpdl_size, PTRDIFF_MAX);
1926 if (max_size <= specpdl_size)
1927 {
1928 if (max_specpdl_size < 400)
1929 max_size = max_specpdl_size = 400;
1930 if (max_size <= specpdl_size)
1931 signal_error ("Variable binding depth exceeds max-specpdl-size", Qnil);
1932 }
1933 specpdl = xpalloc (specpdl, &specpdl_size, 1, max_size, sizeof *specpdl);
1934 specpdl_ptr = specpdl + count;
1935}
1936
1937void
1938record_in_backtrace (Lisp_Object function, Lisp_Object *args, ptrdiff_t nargs)
1939{
1940 eassert (nargs >= UNEVALLED);
1941 if (specpdl_ptr == specpdl + specpdl_size)
1942 grow_specpdl ();
1943 specpdl_ptr->kind = SPECPDL_BACKTRACE;
1944 specpdl_ptr->v.bt.function = function;
1945 specpdl_ptr->v.bt.args = args;
1946 specpdl_ptr->v.bt.nargs = nargs;
1947 specpdl_ptr->v.bt.debug_on_exit = false;
1948 specpdl_ptr++;
1949}
1950
1904/* Eval a sub-expression of the current expression (i.e. in the same 1951/* Eval a sub-expression of the current expression (i.e. in the same
1905 lexical scope). */ 1952 lexical scope). */
1906Lisp_Object 1953Lisp_Object
@@ -1908,7 +1955,6 @@ eval_sub (Lisp_Object form)
1908{ 1955{
1909 Lisp_Object fun, val, original_fun, original_args; 1956 Lisp_Object fun, val, original_fun, original_args;
1910 Lisp_Object funcar; 1957 Lisp_Object funcar;
1911 struct backtrace backtrace;
1912 struct gcpro gcpro1, gcpro2, gcpro3; 1958 struct gcpro gcpro1, gcpro2, gcpro3;
1913 1959
1914 if (SYMBOLP (form)) 1960 if (SYMBOLP (form))
@@ -1946,12 +1992,8 @@ eval_sub (Lisp_Object form)
1946 original_fun = XCAR (form); 1992 original_fun = XCAR (form);
1947 original_args = XCDR (form); 1993 original_args = XCDR (form);
1948 1994
1949 backtrace.next = backtrace_list; 1995 /* This also protects them from gc. */
1950 backtrace.function = original_fun; /* This also protects them from gc. */ 1996 record_in_backtrace (original_fun, &original_args, UNEVALLED);
1951 backtrace.args = &original_args;
1952 backtrace.nargs = UNEVALLED;
1953 backtrace.debug_on_exit = 0;
1954 backtrace_list = &backtrace;
1955 1997
1956 if (debug_on_next_call) 1998 if (debug_on_next_call)
1957 do_debug_on_call (Qt); 1999 do_debug_on_call (Qt);
@@ -2005,8 +2047,8 @@ eval_sub (Lisp_Object form)
2005 gcpro3.nvars = argnum; 2047 gcpro3.nvars = argnum;
2006 } 2048 }
2007 2049
2008 backtrace.args = vals; 2050 set_backtrace_args (specpdl_ptr - 1, vals);
2009 backtrace.nargs = XINT (numargs); 2051 set_backtrace_nargs (specpdl_ptr - 1, XINT (numargs));
2010 2052
2011 val = (XSUBR (fun)->function.aMANY) (XINT (numargs), vals); 2053 val = (XSUBR (fun)->function.aMANY) (XINT (numargs), vals);
2012 UNGCPRO; 2054 UNGCPRO;
@@ -2027,8 +2069,8 @@ eval_sub (Lisp_Object form)
2027 2069
2028 UNGCPRO; 2070 UNGCPRO;
2029 2071
2030 backtrace.args = argvals; 2072 set_backtrace_args (specpdl_ptr - 1, argvals);
2031 backtrace.nargs = XINT (numargs); 2073 set_backtrace_nargs (specpdl_ptr - 1, XINT (numargs));
2032 2074
2033 switch (i) 2075 switch (i)
2034 { 2076 {
@@ -2118,9 +2160,9 @@ eval_sub (Lisp_Object form)
2118 check_cons_list (); 2160 check_cons_list ();
2119 2161
2120 lisp_eval_depth--; 2162 lisp_eval_depth--;
2121 if (backtrace.debug_on_exit) 2163 if (backtrace_debug_on_exit (specpdl_ptr - 1))
2122 val = call_debugger (Fcons (Qexit, Fcons (val, Qnil))); 2164 val = call_debugger (Fcons (Qexit, Fcons (val, Qnil)));
2123 backtrace_list = backtrace.next; 2165 specpdl_ptr--;
2124 2166
2125 return val; 2167 return val;
2126} 2168}
@@ -2600,7 +2642,6 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */)
2600 ptrdiff_t numargs = nargs - 1; 2642 ptrdiff_t numargs = nargs - 1;
2601 Lisp_Object lisp_numargs; 2643 Lisp_Object lisp_numargs;
2602 Lisp_Object val; 2644 Lisp_Object val;
2603 struct backtrace backtrace;
2604 register Lisp_Object *internal_args; 2645 register Lisp_Object *internal_args;
2605 ptrdiff_t i; 2646 ptrdiff_t i;
2606 2647
@@ -2614,12 +2655,8 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */)
2614 error ("Lisp nesting exceeds `max-lisp-eval-depth'"); 2655 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2615 } 2656 }
2616 2657
2617 backtrace.next = backtrace_list; 2658 /* This also GCPROs them. */
2618 backtrace.function = args[0]; 2659 record_in_backtrace (args[0], &args[1], nargs - 1);
2619 backtrace.args = &args[1]; /* This also GCPROs them. */
2620 backtrace.nargs = nargs - 1;
2621 backtrace.debug_on_exit = 0;
2622 backtrace_list = &backtrace;
2623 2660
2624 /* Call GC after setting up the backtrace, so the latter GCPROs the args. */ 2661 /* Call GC after setting up the backtrace, so the latter GCPROs the args. */
2625 maybe_gc (); 2662 maybe_gc ();
@@ -2744,9 +2781,9 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */)
2744 } 2781 }
2745 check_cons_list (); 2782 check_cons_list ();
2746 lisp_eval_depth--; 2783 lisp_eval_depth--;
2747 if (backtrace.debug_on_exit) 2784 if (backtrace_debug_on_exit (specpdl_ptr - 1))
2748 val = call_debugger (Fcons (Qexit, Fcons (val, Qnil))); 2785 val = call_debugger (Fcons (Qexit, Fcons (val, Qnil)));
2749 backtrace_list = backtrace.next; 2786 specpdl_ptr--;
2750 return val; 2787 return val;
2751} 2788}
2752 2789
@@ -2778,15 +2815,17 @@ apply_lambda (Lisp_Object fun, Lisp_Object args)
2778 2815
2779 UNGCPRO; 2816 UNGCPRO;
2780 2817
2781 backtrace_list->args = arg_vector; 2818 set_backtrace_args (specpdl_ptr - 1, arg_vector);
2782 backtrace_list->nargs = i; 2819 set_backtrace_nargs (specpdl_ptr - 1, i);
2783 tem = funcall_lambda (fun, numargs, arg_vector); 2820 tem = funcall_lambda (fun, numargs, arg_vector);
2784 2821
2785 /* Do the debug-on-exit now, while arg_vector still exists. */ 2822 /* Do the debug-on-exit now, while arg_vector still exists. */
2786 if (backtrace_list->debug_on_exit) 2823 if (backtrace_debug_on_exit (specpdl_ptr - 1))
2787 tem = call_debugger (Fcons (Qexit, Fcons (tem, Qnil))); 2824 {
2788 /* Don't do it again when we return to eval. */ 2825 /* Don't do it again when we return to eval. */
2789 backtrace_list->debug_on_exit = 0; 2826 set_backtrace_debug_on_exit (specpdl_ptr - 1, false);
2827 tem = call_debugger (Fcons (Qexit, Fcons (tem, Qnil)));
2828 }
2790 SAFE_FREE (); 2829 SAFE_FREE ();
2791 return tem; 2830 return tem;
2792} 2831}
@@ -2936,20 +2975,38 @@ DEFUN ("fetch-bytecode", Ffetch_bytecode, Sfetch_bytecode,
2936 return object; 2975 return object;
2937} 2976}
2938 2977
2939static void 2978/* Return true if SYMBOL currently has a let-binding
2940grow_specpdl (void) 2979 which was made in the buffer that is now current. */
2980
2981bool
2982let_shadows_buffer_binding_p (struct Lisp_Symbol *symbol)
2941{ 2983{
2942 register ptrdiff_t count = SPECPDL_INDEX (); 2984 struct specbinding *p;
2943 ptrdiff_t max_size = min (max_specpdl_size, PTRDIFF_MAX); 2985 Lisp_Object buf = Fcurrent_buffer ();
2944 if (max_size <= specpdl_size) 2986
2945 { 2987 for (p = specpdl_ptr; p > specpdl; )
2946 if (max_specpdl_size < 400) 2988 if ((--p)->kind > SPECPDL_LET)
2947 max_size = max_specpdl_size = 400; 2989 {
2948 if (max_size <= specpdl_size) 2990 struct Lisp_Symbol *let_bound_symbol = XSYMBOL (specpdl_symbol (p));
2949 signal_error ("Variable binding depth exceeds max-specpdl-size", Qnil); 2991 eassert (let_bound_symbol->redirect != SYMBOL_VARALIAS);
2950 } 2992 if (symbol == let_bound_symbol
2951 specpdl = xpalloc (specpdl, &specpdl_size, 1, max_size, sizeof *specpdl); 2993 && EQ (specpdl_where (p), buf))
2952 specpdl_ptr = specpdl + count; 2994 return 1;
2995 }
2996
2997 return 0;
2998}
2999
3000bool
3001let_shadows_global_binding_p (Lisp_Object symbol)
3002{
3003 struct specbinding *p;
3004
3005 for (p = specpdl_ptr; p > specpdl; )
3006 if ((--p)->kind >= SPECPDL_LET && EQ (specpdl_symbol (p), symbol))
3007 return 1;
3008
3009 return 0;
2953} 3010}
2954 3011
2955/* `specpdl_ptr->symbol' is a field which describes which variable is 3012/* `specpdl_ptr->symbol' is a field which describes which variable is
@@ -2985,9 +3042,9 @@ specbind (Lisp_Object symbol, Lisp_Object value)
2985 case SYMBOL_PLAINVAL: 3042 case SYMBOL_PLAINVAL:
2986 /* The most common case is that of a non-constant symbol with a 3043 /* The most common case is that of a non-constant symbol with a
2987 trivial value. Make that as fast as we can. */ 3044 trivial value. Make that as fast as we can. */
2988 set_specpdl_symbol (symbol); 3045 specpdl_ptr->kind = SPECPDL_LET;
2989 set_specpdl_old_value (SYMBOL_VAL (sym)); 3046 specpdl_ptr->v.let.symbol = symbol;
2990 specpdl_ptr->func = NULL; 3047 specpdl_ptr->v.let.old_value = SYMBOL_VAL (sym);
2991 ++specpdl_ptr; 3048 ++specpdl_ptr;
2992 if (!sym->constant) 3049 if (!sym->constant)
2993 SET_SYMBOL_VAL (sym, value); 3050 SET_SYMBOL_VAL (sym, value);
@@ -3000,59 +3057,36 @@ specbind (Lisp_Object symbol, Lisp_Object value)
3000 case SYMBOL_FORWARDED: 3057 case SYMBOL_FORWARDED:
3001 { 3058 {
3002 Lisp_Object ovalue = find_symbol_value (symbol); 3059 Lisp_Object ovalue = find_symbol_value (symbol);
3003 specpdl_ptr->func = 0; 3060 specpdl_ptr->kind = SPECPDL_LET_LOCAL;
3004 set_specpdl_old_value (ovalue); 3061 specpdl_ptr->v.let.symbol = symbol;
3062 specpdl_ptr->v.let.old_value = ovalue;
3063 specpdl_ptr->v.let.where = Fcurrent_buffer ();
3005 3064
3006 eassert (sym->redirect != SYMBOL_LOCALIZED 3065 eassert (sym->redirect != SYMBOL_LOCALIZED
3007 || (EQ (SYMBOL_BLV (sym)->where, 3066 || (EQ (SYMBOL_BLV (sym)->where, Fcurrent_buffer ())));
3008 SYMBOL_BLV (sym)->frame_local ?
3009 Fselected_frame () : Fcurrent_buffer ())));
3010 3067
3011 if (sym->redirect == SYMBOL_LOCALIZED 3068 if (sym->redirect == SYMBOL_LOCALIZED)
3012 || BUFFER_OBJFWDP (SYMBOL_FWD (sym))) 3069 {
3070 if (!blv_found (SYMBOL_BLV (sym)))
3071 specpdl_ptr->kind = SPECPDL_LET_DEFAULT;
3072 }
3073 else if (BUFFER_OBJFWDP (SYMBOL_FWD (sym)))
3013 { 3074 {
3014 Lisp_Object where, cur_buf = Fcurrent_buffer ();
3015
3016 /* For a local variable, record both the symbol and which
3017 buffer's or frame's value we are saving. */
3018 if (!NILP (Flocal_variable_p (symbol, Qnil)))
3019 {
3020 eassert (sym->redirect != SYMBOL_LOCALIZED
3021 || (blv_found (SYMBOL_BLV (sym))
3022 && EQ (cur_buf, SYMBOL_BLV (sym)->where)));
3023 where = cur_buf;
3024 }
3025 else if (sym->redirect == SYMBOL_LOCALIZED
3026 && blv_found (SYMBOL_BLV (sym)))
3027 where = SYMBOL_BLV (sym)->where;
3028 else
3029 where = Qnil;
3030
3031 /* We're not using the `unused' slot in the specbinding
3032 structure because this would mean we have to do more
3033 work for simple variables. */
3034 /* FIXME: The third value `current_buffer' is only used in
3035 let_shadows_buffer_binding_p which is itself only used
3036 in set_internal for local_if_set. */
3037 eassert (NILP (where) || EQ (where, cur_buf));
3038 set_specpdl_symbol (Fcons (symbol, Fcons (where, cur_buf)));
3039
3040 /* If SYMBOL is a per-buffer variable which doesn't have a 3075 /* If SYMBOL is a per-buffer variable which doesn't have a
3041 buffer-local value here, make the `let' change the global 3076 buffer-local value here, make the `let' change the global
3042 value by changing the value of SYMBOL in all buffers not 3077 value by changing the value of SYMBOL in all buffers not
3043 having their own value. This is consistent with what 3078 having their own value. This is consistent with what
3044 happens with other buffer-local variables. */ 3079 happens with other buffer-local variables. */
3045 if (NILP (where) 3080 if (NILP (Flocal_variable_p (symbol, Qnil)))
3046 && sym->redirect == SYMBOL_FORWARDED)
3047 { 3081 {
3048 eassert (BUFFER_OBJFWDP (SYMBOL_FWD (sym))); 3082 specpdl_ptr->kind = SPECPDL_LET_DEFAULT;
3049 ++specpdl_ptr; 3083 ++specpdl_ptr;
3050 Fset_default (symbol, value); 3084 Fset_default (symbol, value);
3051 return; 3085 return;
3052 } 3086 }
3053 } 3087 }
3054 else 3088 else
3055 set_specpdl_symbol (symbol); 3089 specpdl_ptr->kind = SPECPDL_LET;
3056 3090
3057 specpdl_ptr++; 3091 specpdl_ptr++;
3058 set_internal (symbol, value, Qnil, 1); 3092 set_internal (symbol, value, Qnil, 1);
@@ -3067,9 +3101,9 @@ record_unwind_protect (Lisp_Object (*function) (Lisp_Object), Lisp_Object arg)
3067{ 3101{
3068 if (specpdl_ptr == specpdl + specpdl_size) 3102 if (specpdl_ptr == specpdl + specpdl_size)
3069 grow_specpdl (); 3103 grow_specpdl ();
3070 specpdl_ptr->func = function; 3104 specpdl_ptr->kind = SPECPDL_UNWIND;
3071 set_specpdl_symbol (Qnil); 3105 specpdl_ptr->v.unwind.func = function;
3072 set_specpdl_old_value (arg); 3106 specpdl_ptr->v.unwind.arg = arg;
3073 specpdl_ptr++; 3107 specpdl_ptr++;
3074} 3108}
3075 3109
@@ -3093,41 +3127,50 @@ unbind_to (ptrdiff_t count, Lisp_Object value)
3093 struct specbinding this_binding; 3127 struct specbinding this_binding;
3094 this_binding = *--specpdl_ptr; 3128 this_binding = *--specpdl_ptr;
3095 3129
3096 if (this_binding.func != 0) 3130 switch (this_binding.kind)
3097 (*this_binding.func) (this_binding.old_value);
3098 /* If the symbol is a list, it is really (SYMBOL WHERE
3099 . CURRENT-BUFFER) where WHERE is either nil, a buffer, or a
3100 frame. If WHERE is a buffer or frame, this indicates we
3101 bound a variable that had a buffer-local or frame-local
3102 binding. WHERE nil means that the variable had the default
3103 value when it was bound. CURRENT-BUFFER is the buffer that
3104 was current when the variable was bound. */
3105 else if (CONSP (this_binding.symbol))
3106 { 3131 {
3107 Lisp_Object symbol, where; 3132 case SPECPDL_UNWIND:
3108 3133 (*specpdl_func (&this_binding)) (specpdl_arg (&this_binding));
3109 symbol = XCAR (this_binding.symbol); 3134 break;
3110 where = XCAR (XCDR (this_binding.symbol)); 3135 case SPECPDL_LET:
3111 3136 /* If variable has a trivial value (no forwarding), we can
3112 if (NILP (where)) 3137 just set it. No need to check for constant symbols here,
3113 Fset_default (symbol, this_binding.old_value); 3138 since that was already done by specbind. */
3114 /* If `where' is non-nil, reset the value in the appropriate 3139 if (XSYMBOL (specpdl_symbol (&this_binding))->redirect
3115 local binding, but only if that binding still exists. */ 3140 == SYMBOL_PLAINVAL)
3116 else if (BUFFERP (where) 3141 SET_SYMBOL_VAL (XSYMBOL (specpdl_symbol (&this_binding)),
3117 ? !NILP (Flocal_variable_p (symbol, where)) 3142 specpdl_old_value (&this_binding));
3118 : !NILP (Fassq (symbol, XFRAME (where)->param_alist))) 3143 else
3119 set_internal (symbol, this_binding.old_value, where, 1); 3144 /* NOTE: we only ever come here if make_local_foo was used for
3145 the first time on this var within this let. */
3146 Fset_default (specpdl_symbol (&this_binding),
3147 specpdl_old_value (&this_binding));
3148 break;
3149 case SPECPDL_BACKTRACE:
3150 break;
3151 case SPECPDL_LET_LOCAL:
3152 case SPECPDL_LET_DEFAULT:
3153 { /* If the symbol is a list, it is really (SYMBOL WHERE
3154 . CURRENT-BUFFER) where WHERE is either nil, a buffer, or a
3155 frame. If WHERE is a buffer or frame, this indicates we
3156 bound a variable that had a buffer-local or frame-local
3157 binding. WHERE nil means that the variable had the default
3158 value when it was bound. CURRENT-BUFFER is the buffer that
3159 was current when the variable was bound. */
3160 Lisp_Object symbol = specpdl_symbol (&this_binding);
3161 Lisp_Object where = specpdl_where (&this_binding);
3162 eassert (BUFFERP (where));
3163
3164 if (this_binding.kind == SPECPDL_LET_DEFAULT)
3165 Fset_default (symbol, specpdl_old_value (&this_binding));
3166 /* If this was a local binding, reset the value in the appropriate
3167 buffer, but only if that buffer's binding still exists. */
3168 else if (!NILP (Flocal_variable_p (symbol, where)))
3169 set_internal (symbol, specpdl_old_value (&this_binding),
3170 where, 1);
3171 }
3172 break;
3120 } 3173 }
3121 /* If variable has a trivial value (no forwarding), we can
3122 just set it. No need to check for constant symbols here,
3123 since that was already done by specbind. */
3124 else if (XSYMBOL (this_binding.symbol)->redirect == SYMBOL_PLAINVAL)
3125 SET_SYMBOL_VAL (XSYMBOL (this_binding.symbol),
3126 this_binding.old_value);
3127 else
3128 /* NOTE: we only ever come here if make_local_foo was used for
3129 the first time on this var within this let. */
3130 Fset_default (this_binding.symbol, this_binding.old_value);
3131 } 3174 }
3132 3175
3133 if (NILP (Vquit_flag) && !NILP (quitf)) 3176 if (NILP (Vquit_flag) && !NILP (quitf))
@@ -3153,18 +3196,16 @@ DEFUN ("backtrace-debug", Fbacktrace_debug, Sbacktrace_debug, 2, 2, 0,
3153The debugger is entered when that frame exits, if the flag is non-nil. */) 3196The debugger is entered when that frame exits, if the flag is non-nil. */)
3154 (Lisp_Object level, Lisp_Object flag) 3197 (Lisp_Object level, Lisp_Object flag)
3155{ 3198{
3156 register struct backtrace *backlist = backtrace_list; 3199 struct specbinding *pdl = backtrace_top ();
3157 register EMACS_INT i; 3200 register EMACS_INT i;
3158 3201
3159 CHECK_NUMBER (level); 3202 CHECK_NUMBER (level);
3160 3203
3161 for (i = 0; backlist && i < XINT (level); i++) 3204 for (i = 0; backtrace_p (pdl) && i < XINT (level); i++)
3162 { 3205 pdl = backtrace_next (pdl);
3163 backlist = backlist->next;
3164 }
3165 3206
3166 if (backlist) 3207 if (backtrace_p (pdl))
3167 backlist->debug_on_exit = !NILP (flag); 3208 set_backtrace_debug_on_exit (pdl, !NILP (flag));
3168 3209
3169 return flag; 3210 return flag;
3170} 3211}
@@ -3174,58 +3215,41 @@ DEFUN ("backtrace", Fbacktrace, Sbacktrace, 0, 0, "",
3174Output stream used is value of `standard-output'. */) 3215Output stream used is value of `standard-output'. */)
3175 (void) 3216 (void)
3176{ 3217{
3177 register struct backtrace *backlist = backtrace_list; 3218 struct specbinding *pdl = backtrace_top ();
3178 Lisp_Object tail;
3179 Lisp_Object tem; 3219 Lisp_Object tem;
3180 struct gcpro gcpro1;
3181 Lisp_Object old_print_level = Vprint_level; 3220 Lisp_Object old_print_level = Vprint_level;
3182 3221
3183 if (NILP (Vprint_level)) 3222 if (NILP (Vprint_level))
3184 XSETFASTINT (Vprint_level, 8); 3223 XSETFASTINT (Vprint_level, 8);
3185 3224
3186 tail = Qnil; 3225 while (backtrace_p (pdl))
3187 GCPRO1 (tail);
3188
3189 while (backlist)
3190 { 3226 {
3191 write_string (backlist->debug_on_exit ? "* " : " ", 2); 3227 write_string (backtrace_debug_on_exit (pdl) ? "* " : " ", 2);
3192 if (backlist->nargs == UNEVALLED) 3228 if (backtrace_nargs (pdl) == UNEVALLED)
3193 { 3229 {
3194 Fprin1 (Fcons (backlist->function, *backlist->args), Qnil); 3230 Fprin1 (Fcons (backtrace_function (pdl), *backtrace_args (pdl)),
3231 Qnil);
3195 write_string ("\n", -1); 3232 write_string ("\n", -1);
3196 } 3233 }
3197 else 3234 else
3198 { 3235 {
3199 tem = backlist->function; 3236 tem = backtrace_function (pdl);
3200 Fprin1 (tem, Qnil); /* This can QUIT. */ 3237 Fprin1 (tem, Qnil); /* This can QUIT. */
3201 write_string ("(", -1); 3238 write_string ("(", -1);
3202 if (backlist->nargs == MANY) 3239 {
3203 { /* FIXME: Can this happen? */ 3240 ptrdiff_t i;
3204 bool later_arg = 0; 3241 for (i = 0; i < backtrace_nargs (pdl); i++)
3205 for (tail = *backlist->args; !NILP (tail); tail = Fcdr (tail)) 3242 {
3206 { 3243 if (i) write_string (" ", -1);
3207 if (later_arg) 3244 Fprin1 (backtrace_args (pdl)[i], Qnil);
3208 write_string (" ", -1); 3245 }
3209 Fprin1 (Fcar (tail), Qnil); 3246 }
3210 later_arg = 1;
3211 }
3212 }
3213 else
3214 {
3215 ptrdiff_t i;
3216 for (i = 0; i < backlist->nargs; i++)
3217 {
3218 if (i) write_string (" ", -1);
3219 Fprin1 (backlist->args[i], Qnil);
3220 }
3221 }
3222 write_string (")\n", -1); 3247 write_string (")\n", -1);
3223 } 3248 }
3224 backlist = backlist->next; 3249 pdl = backtrace_next (pdl);
3225 } 3250 }
3226 3251
3227 Vprint_level = old_print_level; 3252 Vprint_level = old_print_level;
3228 UNGCPRO;
3229 return Qnil; 3253 return Qnil;
3230} 3254}
3231 3255
@@ -3241,53 +3265,84 @@ or a lambda expression for macro calls.
3241If NFRAMES is more than the number of frames, the value is nil. */) 3265If NFRAMES is more than the number of frames, the value is nil. */)
3242 (Lisp_Object nframes) 3266 (Lisp_Object nframes)
3243{ 3267{
3244 register struct backtrace *backlist = backtrace_list; 3268 struct specbinding *pdl = backtrace_top ();
3245 register EMACS_INT i; 3269 register EMACS_INT i;
3246 Lisp_Object tem;
3247 3270
3248 CHECK_NATNUM (nframes); 3271 CHECK_NATNUM (nframes);
3249 3272
3250 /* Find the frame requested. */ 3273 /* Find the frame requested. */
3251 for (i = 0; backlist && i < XFASTINT (nframes); i++) 3274 for (i = 0; backtrace_p (pdl) && i < XFASTINT (nframes); i++)
3252 backlist = backlist->next; 3275 pdl = backtrace_next (pdl);
3253 3276
3254 if (!backlist) 3277 if (!backtrace_p (pdl))
3255 return Qnil; 3278 return Qnil;
3256 if (backlist->nargs == UNEVALLED) 3279 if (backtrace_nargs (pdl) == UNEVALLED)
3257 return Fcons (Qnil, Fcons (backlist->function, *backlist->args)); 3280 return Fcons (Qnil,
3281 Fcons (backtrace_function (pdl), *backtrace_args (pdl)));
3258 else 3282 else
3259 { 3283 {
3260 if (backlist->nargs == MANY) /* FIXME: Can this happen? */ 3284 Lisp_Object tem = Flist (backtrace_nargs (pdl), backtrace_args (pdl));
3261 tem = *backlist->args;
3262 else
3263 tem = Flist (backlist->nargs, backlist->args);
3264 3285
3265 return Fcons (Qt, Fcons (backlist->function, tem)); 3286 return Fcons (Qt, Fcons (backtrace_function (pdl), tem));
3266 } 3287 }
3267} 3288}
3268 3289
3269 3290
3270#if BYTE_MARK_STACK
3271void 3291void
3272mark_backtrace (void) 3292mark_specpdl (void)
3273{ 3293{
3274 register struct backtrace *backlist; 3294 struct specbinding *pdl;
3275 ptrdiff_t i; 3295 for (pdl = specpdl; pdl != specpdl_ptr; pdl++)
3276
3277 for (backlist = backtrace_list; backlist; backlist = backlist->next)
3278 { 3296 {
3279 mark_object (backlist->function); 3297 switch (pdl->kind)
3298 {
3299 case SPECPDL_UNWIND:
3300 mark_object (specpdl_arg (pdl));
3301 break;
3302 case SPECPDL_BACKTRACE:
3303 {
3304 ptrdiff_t nargs = backtrace_nargs (pdl);
3305 mark_object (backtrace_function (pdl));
3306 if (nargs == UNEVALLED)
3307 nargs = 1;
3308 while (nargs--)
3309 mark_object (backtrace_args (pdl)[nargs]);
3310 }
3311 break;
3312 case SPECPDL_LET_DEFAULT:
3313 case SPECPDL_LET_LOCAL:
3314 mark_object (specpdl_where (pdl));
3315 case SPECPDL_LET:
3316 mark_object (specpdl_symbol (pdl));
3317 mark_object (specpdl_old_value (pdl));
3318 }
3319 }
3320}
3321
3322void
3323get_backtrace (Lisp_Object array)
3324{
3325 struct specbinding *pdl = backtrace_next (backtrace_top ());
3326 ptrdiff_t i = 0, asize = ASIZE (array);
3280 3327
3281 if (backlist->nargs == UNEVALLED 3328 /* Copy the backtrace contents into working memory. */
3282 || backlist->nargs == MANY) /* FIXME: Can this happen? */ 3329 for (; i < asize; i++)
3283 i = 1; 3330 {
3331 if (backtrace_p (pdl))
3332 {
3333 ASET (array, i, backtrace_function (pdl));
3334 pdl = backtrace_next (pdl);
3335 }
3284 else 3336 else
3285 i = backlist->nargs; 3337 ASET (array, i, Qnil);
3286 while (i--)
3287 mark_object (backlist->args[i]);
3288 } 3338 }
3289} 3339}
3290#endif 3340
3341Lisp_Object backtrace_top_function (void)
3342{
3343 struct specbinding *pdl = backtrace_top ();
3344 return (backtrace_p (pdl) ? backtrace_function (pdl) : Qnil);
3345}
3291 3346
3292void 3347void
3293syms_of_eval (void) 3348syms_of_eval (void)