diff options
Diffstat (limited to 'src/eval.c')
| -rw-r--r-- | src/eval.c | 485 |
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 | ||
| 35 | 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! */ | |
| 109 | Lisp_Object Vsignaling_function; | 107 | Lisp_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; | |||
| 117 | static Lisp_Object funcall_lambda (Lisp_Object, ptrdiff_t, Lisp_Object *); | 115 | static Lisp_Object funcall_lambda (Lisp_Object, ptrdiff_t, Lisp_Object *); |
| 118 | static Lisp_Object apply_lambda (Lisp_Object fun, Lisp_Object args); | 116 | static 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 | |||
| 120 | static void | ||
| 121 | set_backtrace_args (struct specbinding *pdl, Lisp_Object *args) | ||
| 122 | { eassert (pdl->kind == SPECPDL_BACKTRACE); pdl->v.bt.args = args; } | ||
| 123 | |||
| 124 | static void | ||
| 125 | set_backtrace_nargs (struct specbinding *pdl, ptrdiff_t n) | ||
| 126 | { eassert (pdl->kind == SPECPDL_BACKTRACE); pdl->v.bt.nargs = n; } | ||
| 121 | 127 | ||
| 122 | static void | 128 | static void |
| 123 | set_specpdl_symbol (Lisp_Object symbol) | 129 | set_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 | |||
| 134 | bool backtrace_p (struct specbinding *) EXTERNALLY_VISIBLE; | ||
| 135 | struct specbinding *backtrace_top (void) EXTERNALLY_VISIBLE; | ||
| 136 | struct specbinding *backtrace_next (struct specbinding *pdl) EXTERNALLY_VISIBLE; | ||
| 137 | |||
| 138 | bool backtrace_p (struct specbinding *pdl) | ||
| 139 | { return pdl >= specpdl; } | ||
| 140 | |||
| 141 | struct specbinding * | ||
| 142 | backtrace_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 | ||
| 128 | static void | 150 | struct specbinding * |
| 129 | set_specpdl_old_value (Lisp_Object oldval) | 151 | backtrace_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 | |||
| 134 | void | 160 | void |
| 135 | init_eval_once (void) | 161 | init_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 | |||
| 234 | do_debug_on_call (Lisp_Object code) | 259 | do_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 | ||
| 942 | Lisp_Object | 967 | Lisp_Object |
| 943 | internal_catch (Lisp_Object tag, Lisp_Object (*func) (Lisp_Object), Lisp_Object arg) | 968 | internal_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 | ||
| 1921 | static void | ||
| 1922 | grow_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 | |||
| 1937 | void | ||
| 1938 | record_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). */ |
| 1906 | Lisp_Object | 1953 | Lisp_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 | ||
| 2939 | static void | 2978 | /* Return true if SYMBOL currently has a let-binding |
| 2940 | grow_specpdl (void) | 2979 | which was made in the buffer that is now current. */ |
| 2980 | |||
| 2981 | bool | ||
| 2982 | let_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 | |||
| 3000 | bool | ||
| 3001 | let_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, | |||
| 3153 | The debugger is entered when that frame exits, if the flag is non-nil. */) | 3196 | The 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, "", | |||
| 3174 | Output stream used is value of `standard-output'. */) | 3215 | Output 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. | |||
| 3241 | If NFRAMES is more than the number of frames, the value is nil. */) | 3265 | If 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 | ||
| 3271 | void | 3291 | void |
| 3272 | mark_backtrace (void) | 3292 | mark_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 | |||
| 3322 | void | ||
| 3323 | get_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 | |
| 3341 | Lisp_Object backtrace_top_function (void) | ||
| 3342 | { | ||
| 3343 | struct specbinding *pdl = backtrace_top (); | ||
| 3344 | return (backtrace_p (pdl) ? backtrace_function (pdl) : Qnil); | ||
| 3345 | } | ||
| 3291 | 3346 | ||
| 3292 | void | 3347 | void |
| 3293 | syms_of_eval (void) | 3348 | syms_of_eval (void) |