aboutsummaryrefslogtreecommitdiffstats
path: root/src/eval.c
diff options
context:
space:
mode:
authorTom Tromey2013-06-03 12:25:05 -0600
committerTom Tromey2013-06-03 12:25:05 -0600
commit68359abba96d7ec4db8aab3d3dd9cf1105c3bab5 (patch)
tree862703e7e1a1888170136a8296a5750d6b2ae2eb /src/eval.c
parentcbcba8ce7f980b01c18c0fd561ef6687b1361507 (diff)
parente2d8a6f0a229b4ebe26484b892ec4f14888f58b6 (diff)
downloademacs-68359abba96d7ec4db8aab3d3dd9cf1105c3bab5.tar.gz
emacs-68359abba96d7ec4db8aab3d3dd9cf1105c3bab5.zip
merge from trunk; clean up some issues
Diffstat (limited to 'src/eval.c')
-rw-r--r--src/eval.c494
1 files changed, 267 insertions, 227 deletions
diff --git a/src/eval.c b/src/eval.c
index a58a1508aaf..be9de93bf1f 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
35/* static struct backtrace *backtrace_list; */
36
37/* #if !BYTE_MARK_STACK */ 35/* #if !BYTE_MARK_STACK */
38/* static */ 36/* static */
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,26 +115,39 @@ 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. */
121 119
122static void 120static void set_backtrace_args (struct specbinding *pdl, Lisp_Object *args)
123set_specpdl_symbol (Lisp_Object symbol) 121{ eassert (pdl->kind == SPECPDL_BACKTRACE); pdl->v.bt.args = args; }
124{
125 specpdl_ptr->symbol = symbol;
126}
127 122
128static void 123static void set_backtrace_nargs (struct specbinding *pdl, ptrdiff_t n)
129set_specpdl_old_value (Lisp_Object oldval) 124{ eassert (pdl->kind == SPECPDL_BACKTRACE); pdl->v.bt.nargs = n; }
125
126void set_backtrace_debug_on_exit (struct specbinding *pdl, bool doe)
127{ eassert (pdl->kind == SPECPDL_BACKTRACE); pdl->v.bt.debug_on_exit = doe; }
128
129/* Helper functions to scan the backtrace. */
130
131EXTERN_INLINE bool backtrace_p (struct specbinding *pdl)
132{ return pdl >= specpdl; }
133
134EXTERN_INLINE struct specbinding *backtrace_top (void)
130{ 135{
131 specpdl_ptr->old_value = oldval; 136 struct specbinding *pdl = specpdl_ptr - 1;
137 while (backtrace_p (pdl) && pdl->kind != SPECPDL_BACKTRACE)
138 pdl--;
139 return pdl;
132} 140}
133 141
134static inline void 142EXTERN_INLINE struct specbinding *backtrace_next (struct specbinding *pdl)
135set_specpdl_saved_value (Lisp_Object savedval)
136{ 143{
137 specpdl_ptr->saved_value = savedval; 144 pdl--;
145 while (backtrace_p (pdl) && pdl->kind != SPECPDL_BACKTRACE)
146 pdl--;
147 return pdl;
138} 148}
139 149
150
140void 151void
141init_eval_once (void) 152init_eval_once (void)
142{ 153{
@@ -157,7 +168,6 @@ init_eval (void)
157 specpdl_ptr = specpdl; 168 specpdl_ptr = specpdl;
158 catchlist = 0; 169 catchlist = 0;
159 handlerlist = 0; 170 handlerlist = 0;
160 backtrace_list = 0;
161 Vquit_flag = Qnil; 171 Vquit_flag = Qnil;
162 debug_on_next_call = 0; 172 debug_on_next_call = 0;
163 lisp_eval_depth = 0; 173 lisp_eval_depth = 0;
@@ -253,7 +263,7 @@ static void
253do_debug_on_call (Lisp_Object code) 263do_debug_on_call (Lisp_Object code)
254{ 264{
255 debug_on_next_call = 0; 265 debug_on_next_call = 0;
256 backtrace_list->debug_on_exit = 1; 266 set_backtrace_debug_on_exit (specpdl_ptr - 1, true);
257 call_debugger (Fcons (code, Qnil)); 267 call_debugger (Fcons (code, Qnil));
258} 268}
259 269
@@ -549,9 +559,8 @@ The return value is BASE-VARIABLE. */)
549 struct specbinding *p; 559 struct specbinding *p;
550 560
551 for (p = specpdl_ptr; p > specpdl; ) 561 for (p = specpdl_ptr; p > specpdl; )
552 if ((--p)->func == NULL 562 if ((--p)->kind >= SPECPDL_LET
553 && (EQ (new_alias, 563 && (EQ (new_alias, specpdl_symbol (p))))
554 CONSP (p->symbol) ? XCAR (p->symbol) : p->symbol)))
555 error ("Don't know how to make a let-bound variable an alias"); 564 error ("Don't know how to make a let-bound variable an alias");
556 } 565 }
557 566
@@ -616,8 +625,9 @@ usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */)
616 struct specbinding *pdl = specpdl_ptr; 625 struct specbinding *pdl = specpdl_ptr;
617 while (pdl > specpdl) 626 while (pdl > specpdl)
618 { 627 {
619 if (EQ ((--pdl)->symbol, sym) && !pdl->func 628 if ((--pdl)->kind >= SPECPDL_LET
620 && EQ (pdl->old_value, Qunbound)) 629 && EQ (specpdl_symbol (pdl), sym)
630 && EQ (specpdl_old_value (pdl), Qunbound))
621 { 631 {
622 message_with_string 632 message_with_string
623 ("Warning: defvar ignored because %s is let-bound", 633 ("Warning: defvar ignored because %s is let-bound",
@@ -956,7 +966,7 @@ usage: (catch TAG BODY...) */)
956 966
957/* Set up a catch, then call C function FUNC on argument ARG. 967/* Set up a catch, then call C function FUNC on argument ARG.
958 FUNC should return a Lisp_Object. 968 FUNC should return a Lisp_Object.
959 This is how catches are done from within C code. */ 969 This is how catches are done from within C code. */
960 970
961Lisp_Object 971Lisp_Object
962internal_catch (Lisp_Object tag, Lisp_Object (*func) (Lisp_Object), Lisp_Object arg) 972internal_catch (Lisp_Object tag, Lisp_Object (*func) (Lisp_Object), Lisp_Object arg)
@@ -968,7 +978,6 @@ internal_catch (Lisp_Object tag, Lisp_Object (*func) (Lisp_Object), Lisp_Object
968 c.next = catchlist; 978 c.next = catchlist;
969 c.tag = tag; 979 c.tag = tag;
970 c.val = Qnil; 980 c.val = Qnil;
971 c.backlist = backtrace_list;
972 c.f_handlerlist = handlerlist; 981 c.f_handlerlist = handlerlist;
973 c.f_lisp_eval_depth = lisp_eval_depth; 982 c.f_lisp_eval_depth = lisp_eval_depth;
974 c.pdlcount = SPECPDL_INDEX (); 983 c.pdlcount = SPECPDL_INDEX ();
@@ -1033,7 +1042,6 @@ unwind_to_catch (struct catchtag *catch, Lisp_Object value)
1033#ifdef DEBUG_GCPRO 1042#ifdef DEBUG_GCPRO
1034 gcpro_level = gcprolist ? gcprolist->level + 1 : 0; 1043 gcpro_level = gcprolist ? gcprolist->level + 1 : 0;
1035#endif 1044#endif
1036 backtrace_list = catch->backlist;
1037 lisp_eval_depth = catch->f_lisp_eval_depth; 1045 lisp_eval_depth = catch->f_lisp_eval_depth;
1038 1046
1039 sys_longjmp (catch->jmp, 1); 1047 sys_longjmp (catch->jmp, 1);
@@ -1134,7 +1142,6 @@ internal_lisp_condition_case (volatile Lisp_Object var, Lisp_Object bodyform,
1134 1142
1135 c.tag = Qnil; 1143 c.tag = Qnil;
1136 c.val = Qnil; 1144 c.val = Qnil;
1137 c.backlist = backtrace_list;
1138 c.f_handlerlist = handlerlist; 1145 c.f_handlerlist = handlerlist;
1139 c.f_lisp_eval_depth = lisp_eval_depth; 1146 c.f_lisp_eval_depth = lisp_eval_depth;
1140 c.pdlcount = SPECPDL_INDEX (); 1147 c.pdlcount = SPECPDL_INDEX ();
@@ -1150,7 +1157,7 @@ internal_lisp_condition_case (volatile Lisp_Object var, Lisp_Object bodyform,
1150 1157
1151 /* Note that this just undoes the binding of h.var; whoever 1158 /* Note that this just undoes the binding of h.var; whoever
1152 longjumped to us unwound the stack to c.pdlcount before 1159 longjumped to us unwound the stack to c.pdlcount before
1153 throwing. */ 1160 throwing. */
1154 unbind_to (c.pdlcount, Qnil); 1161 unbind_to (c.pdlcount, Qnil);
1155 return val; 1162 return val;
1156 } 1163 }
@@ -1189,7 +1196,6 @@ internal_condition_case (Lisp_Object (*bfun) (void), Lisp_Object handlers,
1189 1196
1190 c.tag = Qnil; 1197 c.tag = Qnil;
1191 c.val = Qnil; 1198 c.val = Qnil;
1192 c.backlist = backtrace_list;
1193 c.f_handlerlist = handlerlist; 1199 c.f_handlerlist = handlerlist;
1194 c.f_lisp_eval_depth = lisp_eval_depth; 1200 c.f_lisp_eval_depth = lisp_eval_depth;
1195 c.pdlcount = SPECPDL_INDEX (); 1201 c.pdlcount = SPECPDL_INDEX ();
@@ -1227,7 +1233,6 @@ internal_condition_case_1 (Lisp_Object (*bfun) (Lisp_Object), Lisp_Object arg,
1227 1233
1228 c.tag = Qnil; 1234 c.tag = Qnil;
1229 c.val = Qnil; 1235 c.val = Qnil;
1230 c.backlist = backtrace_list;
1231 c.f_handlerlist = handlerlist; 1236 c.f_handlerlist = handlerlist;
1232 c.f_lisp_eval_depth = lisp_eval_depth; 1237 c.f_lisp_eval_depth = lisp_eval_depth;
1233 c.pdlcount = SPECPDL_INDEX (); 1238 c.pdlcount = SPECPDL_INDEX ();
@@ -1269,7 +1274,6 @@ internal_condition_case_2 (Lisp_Object (*bfun) (Lisp_Object, Lisp_Object),
1269 1274
1270 c.tag = Qnil; 1275 c.tag = Qnil;
1271 c.val = Qnil; 1276 c.val = Qnil;
1272 c.backlist = backtrace_list;
1273 c.f_handlerlist = handlerlist; 1277 c.f_handlerlist = handlerlist;
1274 c.f_lisp_eval_depth = lisp_eval_depth; 1278 c.f_lisp_eval_depth = lisp_eval_depth;
1275 c.pdlcount = SPECPDL_INDEX (); 1279 c.pdlcount = SPECPDL_INDEX ();
@@ -1313,7 +1317,6 @@ internal_condition_case_n (Lisp_Object (*bfun) (ptrdiff_t, Lisp_Object *),
1313 1317
1314 c.tag = Qnil; 1318 c.tag = Qnil;
1315 c.val = Qnil; 1319 c.val = Qnil;
1316 c.backlist = backtrace_list;
1317 c.f_handlerlist = handlerlist; 1320 c.f_handlerlist = handlerlist;
1318 c.f_lisp_eval_depth = lisp_eval_depth; 1321 c.f_lisp_eval_depth = lisp_eval_depth;
1319 c.pdlcount = SPECPDL_INDEX (); 1322 c.pdlcount = SPECPDL_INDEX ();
@@ -1381,7 +1384,6 @@ See also the function `condition-case'. */)
1381 = (NILP (error_symbol) ? Fcar (data) : error_symbol); 1384 = (NILP (error_symbol) ? Fcar (data) : error_symbol);
1382 register Lisp_Object clause = Qnil; 1385 register Lisp_Object clause = Qnil;
1383 struct handler *h; 1386 struct handler *h;
1384 struct backtrace *bp;
1385 1387
1386 immediate_quit = 0; 1388 immediate_quit = 0;
1387 abort_on_gc = 0; 1389 abort_on_gc = 0;
@@ -1417,13 +1419,13 @@ See also the function `condition-case'. */)
1417 too. Don't do this when ERROR_SYMBOL is nil, because that 1419 too. Don't do this when ERROR_SYMBOL is nil, because that
1418 is a memory-full error. */ 1420 is a memory-full error. */
1419 Vsignaling_function = Qnil; 1421 Vsignaling_function = Qnil;
1420 if (backtrace_list && !NILP (error_symbol)) 1422 if (!NILP (error_symbol))
1421 { 1423 {
1422 bp = backtrace_list->next; 1424 struct specbinding *pdl = backtrace_next (backtrace_top ());
1423 if (bp && EQ (bp->function, Qerror)) 1425 if (backtrace_p (pdl) && EQ (backtrace_function (pdl), Qerror))
1424 bp = bp->next; 1426 pdl = backtrace_next (pdl);
1425 if (bp) 1427 if (backtrace_p (pdl))
1426 Vsignaling_function = bp->function; 1428 Vsignaling_function = backtrace_function (pdl);
1427 } 1429 }
1428 1430
1429 for (h = handlerlist; h; h = h->next) 1431 for (h = handlerlist; h; h = h->next)
@@ -1920,6 +1922,36 @@ If LEXICAL is t, evaluate using lexical scoping. */)
1920 return unbind_to (count, eval_sub (form)); 1922 return unbind_to (count, eval_sub (form));
1921} 1923}
1922 1924
1925static void
1926grow_specpdl (void)
1927{
1928 register ptrdiff_t count = SPECPDL_INDEX ();
1929 ptrdiff_t max_size = min (max_specpdl_size, PTRDIFF_MAX);
1930 if (max_size <= specpdl_size)
1931 {
1932 if (max_specpdl_size < 400)
1933 max_size = max_specpdl_size = 400;
1934 if (max_size <= specpdl_size)
1935 signal_error ("Variable binding depth exceeds max-specpdl-size", Qnil);
1936 }
1937 specpdl = xpalloc (specpdl, &specpdl_size, 1, max_size, sizeof *specpdl);
1938 specpdl_ptr = specpdl + count;
1939}
1940
1941LISP_INLINE void
1942record_in_backtrace (Lisp_Object function, Lisp_Object *args, ptrdiff_t nargs)
1943{
1944 eassert (nargs >= UNEVALLED);
1945 if (specpdl_ptr == specpdl + specpdl_size)
1946 grow_specpdl ();
1947 specpdl_ptr->kind = SPECPDL_BACKTRACE;
1948 specpdl_ptr->v.bt.function = function;
1949 specpdl_ptr->v.bt.args = args;
1950 specpdl_ptr->v.bt.nargs = nargs;
1951 specpdl_ptr->v.bt.debug_on_exit = false;
1952 specpdl_ptr++;
1953}
1954
1923/* Eval a sub-expression of the current expression (i.e. in the same 1955/* Eval a sub-expression of the current expression (i.e. in the same
1924 lexical scope). */ 1956 lexical scope). */
1925Lisp_Object 1957Lisp_Object
@@ -1927,7 +1959,6 @@ eval_sub (Lisp_Object form)
1927{ 1959{
1928 Lisp_Object fun, val, original_fun, original_args; 1960 Lisp_Object fun, val, original_fun, original_args;
1929 Lisp_Object funcar; 1961 Lisp_Object funcar;
1930 struct backtrace backtrace;
1931 struct gcpro gcpro1, gcpro2, gcpro3; 1962 struct gcpro gcpro1, gcpro2, gcpro3;
1932 1963
1933 if (SYMBOLP (form)) 1964 if (SYMBOLP (form))
@@ -1965,12 +1996,8 @@ eval_sub (Lisp_Object form)
1965 original_fun = XCAR (form); 1996 original_fun = XCAR (form);
1966 original_args = XCDR (form); 1997 original_args = XCDR (form);
1967 1998
1968 backtrace.next = backtrace_list; 1999 /* This also protects them from gc. */
1969 backtrace.function = original_fun; /* This also protects them from gc. */ 2000 record_in_backtrace (original_fun, &original_args, UNEVALLED);
1970 backtrace.args = &original_args;
1971 backtrace.nargs = UNEVALLED;
1972 backtrace.debug_on_exit = 0;
1973 backtrace_list = &backtrace;
1974 2001
1975 if (debug_on_next_call) 2002 if (debug_on_next_call)
1976 do_debug_on_call (Qt); 2003 do_debug_on_call (Qt);
@@ -2024,8 +2051,8 @@ eval_sub (Lisp_Object form)
2024 gcpro3.nvars = argnum; 2051 gcpro3.nvars = argnum;
2025 } 2052 }
2026 2053
2027 backtrace.args = vals; 2054 set_backtrace_args (specpdl_ptr - 1, vals);
2028 backtrace.nargs = XINT (numargs); 2055 set_backtrace_nargs (specpdl_ptr - 1, XINT (numargs));
2029 2056
2030 val = (XSUBR (fun)->function.aMANY) (XINT (numargs), vals); 2057 val = (XSUBR (fun)->function.aMANY) (XINT (numargs), vals);
2031 UNGCPRO; 2058 UNGCPRO;
@@ -2046,8 +2073,8 @@ eval_sub (Lisp_Object form)
2046 2073
2047 UNGCPRO; 2074 UNGCPRO;
2048 2075
2049 backtrace.args = argvals; 2076 set_backtrace_args (specpdl_ptr - 1, argvals);
2050 backtrace.nargs = XINT (numargs); 2077 set_backtrace_nargs (specpdl_ptr - 1, XINT (numargs));
2051 2078
2052 switch (i) 2079 switch (i)
2053 { 2080 {
@@ -2137,9 +2164,9 @@ eval_sub (Lisp_Object form)
2137 check_cons_list (); 2164 check_cons_list ();
2138 2165
2139 lisp_eval_depth--; 2166 lisp_eval_depth--;
2140 if (backtrace.debug_on_exit) 2167 if (backtrace_debug_on_exit (specpdl_ptr - 1))
2141 val = call_debugger (Fcons (Qexit, Fcons (val, Qnil))); 2168 val = call_debugger (Fcons (Qexit, Fcons (val, Qnil)));
2142 backtrace_list = backtrace.next; 2169 specpdl_ptr--;
2143 2170
2144 return val; 2171 return val;
2145} 2172}
@@ -2619,7 +2646,6 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */)
2619 ptrdiff_t numargs = nargs - 1; 2646 ptrdiff_t numargs = nargs - 1;
2620 Lisp_Object lisp_numargs; 2647 Lisp_Object lisp_numargs;
2621 Lisp_Object val; 2648 Lisp_Object val;
2622 struct backtrace backtrace;
2623 register Lisp_Object *internal_args; 2649 register Lisp_Object *internal_args;
2624 ptrdiff_t i; 2650 ptrdiff_t i;
2625 2651
@@ -2633,12 +2659,8 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */)
2633 error ("Lisp nesting exceeds `max-lisp-eval-depth'"); 2659 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2634 } 2660 }
2635 2661
2636 backtrace.next = backtrace_list; 2662 /* This also GCPROs them. */
2637 backtrace.function = args[0]; 2663 record_in_backtrace (args[0], &args[1], nargs - 1);
2638 backtrace.args = &args[1]; /* This also GCPROs them. */
2639 backtrace.nargs = nargs - 1;
2640 backtrace.debug_on_exit = 0;
2641 backtrace_list = &backtrace;
2642 2664
2643 /* Call GC after setting up the backtrace, so the latter GCPROs the args. */ 2665 /* Call GC after setting up the backtrace, so the latter GCPROs the args. */
2644 maybe_gc (); 2666 maybe_gc ();
@@ -2763,9 +2785,9 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */)
2763 } 2785 }
2764 check_cons_list (); 2786 check_cons_list ();
2765 lisp_eval_depth--; 2787 lisp_eval_depth--;
2766 if (backtrace.debug_on_exit) 2788 if (backtrace_debug_on_exit (specpdl_ptr - 1))
2767 val = call_debugger (Fcons (Qexit, Fcons (val, Qnil))); 2789 val = call_debugger (Fcons (Qexit, Fcons (val, Qnil)));
2768 backtrace_list = backtrace.next; 2790 specpdl_ptr--;
2769 return val; 2791 return val;
2770} 2792}
2771 2793
@@ -2797,15 +2819,17 @@ apply_lambda (Lisp_Object fun, Lisp_Object args)
2797 2819
2798 UNGCPRO; 2820 UNGCPRO;
2799 2821
2800 backtrace_list->args = arg_vector; 2822 set_backtrace_args (specpdl_ptr - 1, arg_vector);
2801 backtrace_list->nargs = i; 2823 set_backtrace_nargs (specpdl_ptr - 1, i);
2802 tem = funcall_lambda (fun, numargs, arg_vector); 2824 tem = funcall_lambda (fun, numargs, arg_vector);
2803 2825
2804 /* Do the debug-on-exit now, while arg_vector still exists. */ 2826 /* Do the debug-on-exit now, while arg_vector still exists. */
2805 if (backtrace_list->debug_on_exit) 2827 if (backtrace_debug_on_exit (specpdl_ptr - 1))
2806 tem = call_debugger (Fcons (Qexit, Fcons (tem, Qnil))); 2828 {
2807 /* Don't do it again when we return to eval. */ 2829 /* Don't do it again when we return to eval. */
2808 backtrace_list->debug_on_exit = 0; 2830 set_backtrace_debug_on_exit (specpdl_ptr - 1, false);
2831 tem = call_debugger (Fcons (Qexit, Fcons (tem, Qnil)));
2832 }
2809 SAFE_FREE (); 2833 SAFE_FREE ();
2810 return tem; 2834 return tem;
2811} 2835}
@@ -2955,20 +2979,38 @@ DEFUN ("fetch-bytecode", Ffetch_bytecode, Sfetch_bytecode,
2955 return object; 2979 return object;
2956} 2980}
2957 2981
2958static void 2982/* Return true if SYMBOL currently has a let-binding
2959grow_specpdl (void) 2983 which was made in the buffer that is now current. */
2984
2985bool
2986let_shadows_buffer_binding_p (struct Lisp_Symbol *symbol)
2960{ 2987{
2961 register ptrdiff_t count = SPECPDL_INDEX (); 2988 struct specbinding *p;
2962 ptrdiff_t max_size = min (max_specpdl_size, PTRDIFF_MAX); 2989 Lisp_Object buf = Fcurrent_buffer ();
2963 if (max_size <= specpdl_size) 2990
2964 { 2991 for (p = specpdl_ptr; p > specpdl; )
2965 if (max_specpdl_size < 400) 2992 if ((--p)->kind > SPECPDL_LET)
2966 max_size = max_specpdl_size = 400; 2993 {
2967 if (max_size <= specpdl_size) 2994 struct Lisp_Symbol *let_bound_symbol = XSYMBOL (specpdl_symbol (p));
2968 signal_error ("Variable binding depth exceeds max-specpdl-size", Qnil); 2995 eassert (let_bound_symbol->redirect != SYMBOL_VARALIAS);
2969 } 2996 if (symbol == let_bound_symbol
2970 specpdl = xpalloc (specpdl, &specpdl_size, 1, max_size, sizeof *specpdl); 2997 && EQ (specpdl_where (p), buf))
2971 specpdl_ptr = specpdl + count; 2998 return 1;
2999 }
3000
3001 return 0;
3002}
3003
3004bool
3005let_shadows_global_binding_p (Lisp_Object symbol)
3006{
3007 struct specbinding *p;
3008
3009 for (p = specpdl_ptr; p > specpdl; )
3010 if ((--p)->kind >= SPECPDL_LET && EQ (specpdl_symbol (p), symbol))
3011 return 1;
3012
3013 return 0;
2972} 3014}
2973 3015
2974static Lisp_Object 3016static Lisp_Object
@@ -3050,10 +3092,10 @@ specbind (Lisp_Object symbol, Lisp_Object value)
3050 case SYMBOL_PLAINVAL: 3092 case SYMBOL_PLAINVAL:
3051 /* The most common case is that of a non-constant symbol with a 3093 /* The most common case is that of a non-constant symbol with a
3052 trivial value. Make that as fast as we can. */ 3094 trivial value. Make that as fast as we can. */
3053 set_specpdl_symbol (symbol); 3095 specpdl_ptr->kind = SPECPDL_LET;
3054 set_specpdl_old_value (SYMBOL_VAL (sym)); 3096 specpdl_ptr->v.let.symbol = symbol;
3055 specpdl_ptr->func = NULL; 3097 specpdl_ptr->v.let.old_value = SYMBOL_VAL (sym);
3056 specpdl_ptr->saved_value = Qnil; 3098 specpdl_ptr->v.let.saved_value = Qnil;
3057 ++specpdl_ptr; 3099 ++specpdl_ptr;
3058 do_specbind (sym, specpdl_ptr - 1, value); 3100 do_specbind (sym, specpdl_ptr - 1, value);
3059 break; 3101 break;
@@ -3063,59 +3105,36 @@ specbind (Lisp_Object symbol, Lisp_Object value)
3063 case SYMBOL_FORWARDED: 3105 case SYMBOL_FORWARDED:
3064 { 3106 {
3065 Lisp_Object ovalue = find_symbol_value (symbol); 3107 Lisp_Object ovalue = find_symbol_value (symbol);
3066 specpdl_ptr->func = 0; 3108 specpdl_ptr->kind = SPECPDL_LET_LOCAL;
3067 set_specpdl_old_value (ovalue); 3109 specpdl_ptr->v.let.symbol = symbol;
3110 specpdl_ptr->v.let.old_value = ovalue;
3111 specpdl_ptr->v.let.where = Fcurrent_buffer ();
3068 3112
3069 eassert (sym->redirect != SYMBOL_LOCALIZED 3113 eassert (sym->redirect != SYMBOL_LOCALIZED
3070 || (EQ (SYMBOL_BLV (sym)->where, 3114 || (EQ (SYMBOL_BLV (sym)->where, Fcurrent_buffer ())));
3071 SYMBOL_BLV (sym)->frame_local ?
3072 Fselected_frame () : Fcurrent_buffer ())));
3073 3115
3074 if (sym->redirect == SYMBOL_LOCALIZED 3116 if (sym->redirect == SYMBOL_LOCALIZED)
3075 || BUFFER_OBJFWDP (SYMBOL_FWD (sym))) 3117 {
3118 if (!blv_found (SYMBOL_BLV (sym)))
3119 specpdl_ptr->kind = SPECPDL_LET_DEFAULT;
3120 }
3121 else if (BUFFER_OBJFWDP (SYMBOL_FWD (sym)))
3076 { 3122 {
3077 Lisp_Object where, cur_buf = Fcurrent_buffer ();
3078
3079 /* For a local variable, record both the symbol and which
3080 buffer's or frame's value we are saving. */
3081 if (!NILP (Flocal_variable_p (symbol, Qnil)))
3082 {
3083 eassert (sym->redirect != SYMBOL_LOCALIZED
3084 || (blv_found (SYMBOL_BLV (sym))
3085 && EQ (cur_buf, SYMBOL_BLV (sym)->where)));
3086 where = cur_buf;
3087 }
3088 else if (sym->redirect == SYMBOL_LOCALIZED
3089 && blv_found (SYMBOL_BLV (sym)))
3090 where = SYMBOL_BLV (sym)->where;
3091 else
3092 where = Qnil;
3093
3094 /* We're not using the `unused' slot in the specbinding
3095 structure because this would mean we have to do more
3096 work for simple variables. */
3097 /* FIXME: The third value `current_buffer' is only used in
3098 let_shadows_buffer_binding_p which is itself only used
3099 in set_internal for local_if_set. */
3100 eassert (NILP (where) || EQ (where, cur_buf));
3101 set_specpdl_symbol (Fcons (symbol, Fcons (where, cur_buf)));
3102
3103 /* If SYMBOL is a per-buffer variable which doesn't have a 3123 /* If SYMBOL is a per-buffer variable which doesn't have a
3104 buffer-local value here, make the `let' change the global 3124 buffer-local value here, make the `let' change the global
3105 value by changing the value of SYMBOL in all buffers not 3125 value by changing the value of SYMBOL in all buffers not
3106 having their own value. This is consistent with what 3126 having their own value. This is consistent with what
3107 happens with other buffer-local variables. */ 3127 happens with other buffer-local variables. */
3108 if (NILP (where) 3128 if (NILP (Flocal_variable_p (symbol, Qnil)))
3109 && sym->redirect == SYMBOL_FORWARDED)
3110 { 3129 {
3111 eassert (BUFFER_OBJFWDP (SYMBOL_FWD (sym))); 3130 specpdl_ptr->kind = SPECPDL_LET_DEFAULT;
3112 ++specpdl_ptr; 3131 ++specpdl_ptr;
3113 do_specbind (sym, specpdl_ptr - 1, value); 3132 do_specbind (sym, specpdl_ptr - 1, value);
3114 return; 3133 return;
3115 } 3134 }
3116 } 3135 }
3117 else 3136 else
3118 set_specpdl_symbol (symbol); 3137 specpdl_ptr->kind = SPECPDL_LET;
3119 3138
3120 specpdl_ptr++; 3139 specpdl_ptr++;
3121 do_specbind (sym, specpdl_ptr - 1, value); 3140 do_specbind (sym, specpdl_ptr - 1, value);
@@ -3130,10 +3149,9 @@ record_unwind_protect (Lisp_Object (*function) (Lisp_Object), Lisp_Object arg)
3130{ 3149{
3131 if (specpdl_ptr == specpdl + specpdl_size) 3150 if (specpdl_ptr == specpdl + specpdl_size)
3132 grow_specpdl (); 3151 grow_specpdl ();
3133 specpdl_ptr->func = function; 3152 specpdl_ptr->kind = SPECPDL_UNWIND;
3134 set_specpdl_symbol (Qnil); 3153 specpdl_ptr->v.unwind.func = function;
3135 set_specpdl_old_value (arg); 3154 specpdl_ptr->v.unwind.arg = arg;
3136 set_specpdl_saved_value (Qnil);
3137 specpdl_ptr++; 3155 specpdl_ptr++;
3138} 3156}
3139 3157
@@ -3144,7 +3162,7 @@ rebind_for_thread_switch (void)
3144 3162
3145 for (bind = specpdl; bind != specpdl_ptr; ++bind) 3163 for (bind = specpdl; bind != specpdl_ptr; ++bind)
3146 { 3164 {
3147 if (bind->func == NULL) 3165 if (bind->kind >= SPECPDL_LET)
3148 { 3166 {
3149 Lisp_Object value = bind->saved_value; 3167 Lisp_Object value = bind->saved_value;
3150 3168
@@ -3157,41 +3175,50 @@ rebind_for_thread_switch (void)
3157static void 3175static void
3158do_one_unbind (const struct specbinding *this_binding, int unwinding) 3176do_one_unbind (const struct specbinding *this_binding, int unwinding)
3159{ 3177{
3160 if (this_binding->func != 0) 3178 switch (this_binding->kind)
3161 (*this_binding->func) (this_binding->old_value); 3179 {
3162 /* If the symbol is a list, it is really (SYMBOL WHERE 3180 case SPECPDL_UNWIND:
3163 . CURRENT-BUFFER) where WHERE is either nil, a buffer, or a 3181 (*specpdl_func (this_binding)) (specpdl_arg (this_binding));
3164 frame. If WHERE is a buffer or frame, this indicates we 3182 break;
3165 bound a variable that had a buffer-local or frame-local 3183 case SPECPDL_LET:
3166 binding. WHERE nil means that the variable had the default 3184 /* If variable has a trivial value (no forwarding), we can
3167 value when it was bound. CURRENT-BUFFER is the buffer that 3185 just set it. No need to check for constant symbols here,
3168 was current when the variable was bound. */ 3186 since that was already done by specbind. */
3169 else if (CONSP (this_binding->symbol)) 3187 if (XSYMBOL (specpdl_symbol (this_binding))->redirect
3170 { 3188 == SYMBOL_PLAINVAL)
3171 Lisp_Object symbol, where; 3189 SET_SYMBOL_VAL (XSYMBOL (specpdl_symbol (this_binding)),
3172 3190 specpdl_old_value (this_binding));
3173 symbol = XCAR (this_binding->symbol); 3191 else
3174 where = XCAR (XCDR (this_binding->symbol)); 3192 /* NOTE: we only ever come here if make_local_foo was used for
3175 3193 the first time on this var within this let. */
3176 if (NILP (where)) 3194 Fset_default (specpdl_symbol (this_binding),
3177 Fset_default (symbol, this_binding->old_value); 3195 specpdl_old_value (this_binding));
3178 /* If `where' is non-nil, reset the value in the appropriate 3196 break;
3179 local binding, but only if that binding still exists. */ 3197 case SPECPDL_BACKTRACE:
3180 else if (BUFFERP (where) 3198 break;
3181 ? !NILP (Flocal_variable_p (symbol, where)) 3199 case SPECPDL_LET_LOCAL:
3182 : !NILP (Fassq (symbol, XFRAME (where)->param_alist))) 3200 case SPECPDL_LET_DEFAULT:
3183 set_internal (symbol, this_binding->old_value, where, 1); 3201 { /* If the symbol is a list, it is really (SYMBOL WHERE
3184 } 3202 . CURRENT-BUFFER) where WHERE is either nil, a buffer, or a
3185 /* If variable has a trivial value (no forwarding), we can 3203 frame. If WHERE is a buffer or frame, this indicates we
3186 just set it. No need to check for constant symbols here, 3204 bound a variable that had a buffer-local or frame-local
3187 since that was already done by specbind. */ 3205 binding. WHERE nil means that the variable had the default
3188 else if (XSYMBOL (this_binding->symbol)->redirect == SYMBOL_PLAINVAL) 3206 value when it was bound. CURRENT-BUFFER is the buffer that
3189 SET_SYMBOL_VAL (XSYMBOL (this_binding->symbol), 3207 was current when the variable was bound. */
3190 this_binding->old_value); 3208 Lisp_Object symbol = specpdl_symbol (this_binding);
3191 else 3209 Lisp_Object where = specpdl_where (this_binding);
3192 /* NOTE: we only ever come here if make_local_foo was used for 3210 eassert (BUFFERP (where));
3193 the first time on this var within this let. */ 3211
3194 Fset_default (this_binding->symbol, this_binding->old_value); 3212 if (this_binding->kind == SPECPDL_LET_DEFAULT)
3213 Fset_default (symbol, specpdl_old_value (this_binding));
3214 /* If this was a local binding, reset the value in the appropriate
3215 buffer, but only if that buffer's binding still exists. */
3216 else if (!NILP (Flocal_variable_p (symbol, where)))
3217 set_internal (symbol, specpdl_old_value (this_binding),
3218 where, 1);
3219 }
3220 break;
3221 }
3195} 3222}
3196 3223
3197Lisp_Object 3224Lisp_Object
@@ -3231,7 +3258,7 @@ unbind_for_thread_switch (void)
3231 3258
3232 for (bind = specpdl_ptr; bind != specpdl; --bind) 3259 for (bind = specpdl_ptr; bind != specpdl; --bind)
3233 { 3260 {
3234 if (bind->func == NULL) 3261 if (bind->kind >= SPECPDL_LET)
3235 { 3262 {
3236 bind->saved_value = find_symbol_value (binding_symbol (bind)); 3263 bind->saved_value = find_symbol_value (binding_symbol (bind));
3237 do_one_unbind (bind, 0); 3264 do_one_unbind (bind, 0);
@@ -3255,18 +3282,16 @@ DEFUN ("backtrace-debug", Fbacktrace_debug, Sbacktrace_debug, 2, 2, 0,
3255The debugger is entered when that frame exits, if the flag is non-nil. */) 3282The debugger is entered when that frame exits, if the flag is non-nil. */)
3256 (Lisp_Object level, Lisp_Object flag) 3283 (Lisp_Object level, Lisp_Object flag)
3257{ 3284{
3258 register struct backtrace *backlist = backtrace_list; 3285 struct specbinding *pdl = backtrace_top ();
3259 register EMACS_INT i; 3286 register EMACS_INT i;
3260 3287
3261 CHECK_NUMBER (level); 3288 CHECK_NUMBER (level);
3262 3289
3263 for (i = 0; backlist && i < XINT (level); i++) 3290 for (i = 0; backtrace_p (pdl) && i < XINT (level); i++)
3264 { 3291 pdl = backtrace_next (pdl);
3265 backlist = backlist->next;
3266 }
3267 3292
3268 if (backlist) 3293 if (backtrace_p (pdl))
3269 backlist->debug_on_exit = !NILP (flag); 3294 set_backtrace_debug_on_exit (pdl, !NILP (flag));
3270 3295
3271 return flag; 3296 return flag;
3272} 3297}
@@ -3276,58 +3301,41 @@ DEFUN ("backtrace", Fbacktrace, Sbacktrace, 0, 0, "",
3276Output stream used is value of `standard-output'. */) 3301Output stream used is value of `standard-output'. */)
3277 (void) 3302 (void)
3278{ 3303{
3279 register struct backtrace *backlist = backtrace_list; 3304 struct specbinding *pdl = backtrace_top ();
3280 Lisp_Object tail;
3281 Lisp_Object tem; 3305 Lisp_Object tem;
3282 struct gcpro gcpro1;
3283 Lisp_Object old_print_level = Vprint_level; 3306 Lisp_Object old_print_level = Vprint_level;
3284 3307
3285 if (NILP (Vprint_level)) 3308 if (NILP (Vprint_level))
3286 XSETFASTINT (Vprint_level, 8); 3309 XSETFASTINT (Vprint_level, 8);
3287 3310
3288 tail = Qnil; 3311 while (backtrace_p (pdl))
3289 GCPRO1 (tail);
3290
3291 while (backlist)
3292 { 3312 {
3293 write_string (backlist->debug_on_exit ? "* " : " ", 2); 3313 write_string (backtrace_debug_on_exit (pdl) ? "* " : " ", 2);
3294 if (backlist->nargs == UNEVALLED) 3314 if (backtrace_nargs (pdl) == UNEVALLED)
3295 { 3315 {
3296 Fprin1 (Fcons (backlist->function, *backlist->args), Qnil); 3316 Fprin1 (Fcons (backtrace_function (pdl), *backtrace_args (pdl)),
3317 Qnil);
3297 write_string ("\n", -1); 3318 write_string ("\n", -1);
3298 } 3319 }
3299 else 3320 else
3300 { 3321 {
3301 tem = backlist->function; 3322 tem = backtrace_function (pdl);
3302 Fprin1 (tem, Qnil); /* This can QUIT. */ 3323 Fprin1 (tem, Qnil); /* This can QUIT. */
3303 write_string ("(", -1); 3324 write_string ("(", -1);
3304 if (backlist->nargs == MANY) 3325 {
3305 { /* FIXME: Can this happen? */ 3326 ptrdiff_t i;
3306 bool later_arg = 0; 3327 for (i = 0; i < backtrace_nargs (pdl); i++)
3307 for (tail = *backlist->args; !NILP (tail); tail = Fcdr (tail)) 3328 {
3308 { 3329 if (i) write_string (" ", -1);
3309 if (later_arg) 3330 Fprin1 (backtrace_args (pdl)[i], Qnil);
3310 write_string (" ", -1); 3331 }
3311 Fprin1 (Fcar (tail), Qnil); 3332 }
3312 later_arg = 1;
3313 }
3314 }
3315 else
3316 {
3317 ptrdiff_t i;
3318 for (i = 0; i < backlist->nargs; i++)
3319 {
3320 if (i) write_string (" ", -1);
3321 Fprin1 (backlist->args[i], Qnil);
3322 }
3323 }
3324 write_string (")\n", -1); 3333 write_string (")\n", -1);
3325 } 3334 }
3326 backlist = backlist->next; 3335 pdl = backtrace_next (pdl);
3327 } 3336 }
3328 3337
3329 Vprint_level = old_print_level; 3338 Vprint_level = old_print_level;
3330 UNGCPRO;
3331 return Qnil; 3339 return Qnil;
3332} 3340}
3333 3341
@@ -3343,53 +3351,85 @@ or a lambda expression for macro calls.
3343If NFRAMES is more than the number of frames, the value is nil. */) 3351If NFRAMES is more than the number of frames, the value is nil. */)
3344 (Lisp_Object nframes) 3352 (Lisp_Object nframes)
3345{ 3353{
3346 register struct backtrace *backlist = backtrace_list; 3354 struct specbinding *pdl = backtrace_top ();
3347 register EMACS_INT i; 3355 register EMACS_INT i;
3348 Lisp_Object tem;
3349 3356
3350 CHECK_NATNUM (nframes); 3357 CHECK_NATNUM (nframes);
3351 3358
3352 /* Find the frame requested. */ 3359 /* Find the frame requested. */
3353 for (i = 0; backlist && i < XFASTINT (nframes); i++) 3360 for (i = 0; backtrace_p (pdl) && i < XFASTINT (nframes); i++)
3354 backlist = backlist->next; 3361 pdl = backtrace_next (pdl);
3355 3362
3356 if (!backlist) 3363 if (!backtrace_p (pdl))
3357 return Qnil; 3364 return Qnil;
3358 if (backlist->nargs == UNEVALLED) 3365 if (backtrace_nargs (pdl) == UNEVALLED)
3359 return Fcons (Qnil, Fcons (backlist->function, *backlist->args)); 3366 return Fcons (Qnil,
3367 Fcons (backtrace_function (pdl), *backtrace_args (pdl)));
3360 else 3368 else
3361 { 3369 {
3362 if (backlist->nargs == MANY) /* FIXME: Can this happen? */ 3370 Lisp_Object tem = Flist (backtrace_nargs (pdl), backtrace_args (pdl));
3363 tem = *backlist->args;
3364 else
3365 tem = Flist (backlist->nargs, backlist->args);
3366 3371
3367 return Fcons (Qt, Fcons (backlist->function, tem)); 3372 return Fcons (Qt, Fcons (backtrace_function (pdl), tem));
3368 } 3373 }
3369} 3374}
3370 3375
3371 3376
3372#if BYTE_MARK_STACK
3373void 3377void
3374mark_backtrace (void) 3378mark_specpdl (struct specbinding *first, struct specbinding *ptr)
3375{ 3379{
3376 register struct backtrace *backlist; 3380 struct specbinding *pdl;
3377 ptrdiff_t i; 3381 for (pdl = first; pdl != ptr; pdl++)
3378
3379 for (backlist = backtrace_list; backlist; backlist = backlist->next)
3380 { 3382 {
3381 mark_object (backlist->function); 3383 switch (pdl->kind)
3384 {
3385 case SPECPDL_UNWIND:
3386 mark_object (specpdl_arg (pdl));
3387 break;
3388 case SPECPDL_BACKTRACE:
3389 {
3390 ptrdiff_t nargs = backtrace_nargs (pdl);
3391 mark_object (backtrace_function (pdl));
3392 if (nargs == UNEVALLED)
3393 nargs = 1;
3394 while (nargs--)
3395 mark_object (backtrace_args (pdl)[nargs]);
3396 }
3397 break;
3398 case SPECPDL_LET_DEFAULT:
3399 case SPECPDL_LET_LOCAL:
3400 mark_object (specpdl_where (pdl));
3401 case SPECPDL_LET:
3402 mark_object (specpdl_symbol (pdl));
3403 mark_object (specpdl_old_value (pdl));
3404 mark_object (specpdl_saved_value (pdl));
3405 }
3406 }
3407}
3408
3409void
3410get_backtrace (Lisp_Object array)
3411{
3412 struct specbinding *pdl = backtrace_next (backtrace_top ());
3413 ptrdiff_t i = 0, asize = ASIZE (array);
3382 3414
3383 if (backlist->nargs == UNEVALLED 3415 /* Copy the backtrace contents into working memory. */
3384 || backlist->nargs == MANY) /* FIXME: Can this happen? */ 3416 for (; i < asize; i++)
3385 i = 1; 3417 {
3418 if (backtrace_p (pdl))
3419 {
3420 ASET (array, i, backtrace_function (pdl));
3421 pdl = backtrace_next (pdl);
3422 }
3386 else 3423 else
3387 i = backlist->nargs; 3424 ASET (array, i, Qnil);
3388 while (i--)
3389 mark_object (backlist->args[i]);
3390 } 3425 }
3391} 3426}
3392#endif 3427
3428Lisp_Object backtrace_top_function (void)
3429{
3430 struct specbinding *pdl = backtrace_top ();
3431 return (backtrace_p (pdl) ? backtrace_function (pdl) : Qnil);
3432}
3393 3433
3394void 3434void
3395syms_of_eval (void) 3435syms_of_eval (void)