aboutsummaryrefslogtreecommitdiffstats
path: root/src/eval.c
diff options
context:
space:
mode:
Diffstat (limited to 'src/eval.c')
-rw-r--r--src/eval.c757
1 files changed, 520 insertions, 237 deletions
diff --git a/src/eval.c b/src/eval.c
index d0effc755a2..be582775fea 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -18,7 +18,9 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
18 18
19 19
20#include <config.h> 20#include <config.h>
21#include <limits.h>
21#include <setjmp.h> 22#include <setjmp.h>
23#include <stdio.h>
22#include "lisp.h" 24#include "lisp.h"
23#include "blockinput.h" 25#include "blockinput.h"
24#include "commands.h" 26#include "commands.h"
@@ -30,26 +32,45 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
30#include "xterm.h" 32#include "xterm.h"
31#endif 33#endif
32 34
33/* This definition is duplicated in alloc.c and keyboard.c */ 35/* This definition is duplicated in alloc.c and keyboard.c. */
34/* Putting it in lisp.h makes cc bomb out! */ 36/* Putting it in lisp.h makes cc bomb out! */
35 37
36struct backtrace 38struct backtrace
37{ 39{
38 struct backtrace *next; 40 struct backtrace *next;
39 Lisp_Object *function; 41 Lisp_Object *function;
40 Lisp_Object *args; /* Points to vector of args. */ 42 Lisp_Object *args; /* Points to vector of args. */
41 int nargs; /* Length of vector. 43#define NARGS_BITS (BITS_PER_INT - 2)
42 If nargs is UNEVALLED, args points to slot holding 44 /* Let's not use size_t because we want to allow negative values (for
43 list of unevalled args */ 45 UNEVALLED). Also let's steal 2 bits so we save a word (or more for
44 char evalargs; 46 alignment). In any case I doubt Emacs would survive a function call with
45 /* Nonzero means call value of debugger when done with this operation. */ 47 more than 500M arguments. */
46 char debug_on_exit; 48 int nargs : NARGS_BITS; /* Length of vector.
49 If nargs is UNEVALLED, args points
50 to slot holding list of unevalled args. */
51 char evalargs : 1;
52 /* Nonzero means call value of debugger when done with this operation. */
53 char debug_on_exit : 1;
47}; 54};
48 55
49struct backtrace *backtrace_list; 56static struct backtrace *backtrace_list;
50 57
58#if !BYTE_MARK_STACK
59static
60#endif
51struct catchtag *catchlist; 61struct catchtag *catchlist;
52 62
63/* Chain of condition handlers currently in effect.
64 The elements of this chain are contained in the stack frames
65 of Fcondition_case and internal_condition_case.
66 When an error is signaled (by calling Fsignal, below),
67 this chain is searched for an element that applies. */
68
69#if !BYTE_MARK_STACK
70static
71#endif
72struct handler *handlerlist;
73
53#ifdef DEBUG_GCPRO 74#ifdef DEBUG_GCPRO
54/* Count levels of GCPRO to detect failure to UNGCPRO. */ 75/* Count levels of GCPRO to detect failure to UNGCPRO. */
55int gcpro_level; 76int gcpro_level;
@@ -57,10 +78,13 @@ int gcpro_level;
57 78
58Lisp_Object Qautoload, Qmacro, Qexit, Qinteractive, Qcommandp, Qdefun; 79Lisp_Object Qautoload, Qmacro, Qexit, Qinteractive, Qcommandp, Qdefun;
59Lisp_Object Qinhibit_quit; 80Lisp_Object Qinhibit_quit;
60Lisp_Object Qand_rest, Qand_optional; 81Lisp_Object Qand_rest;
61Lisp_Object Qdebug_on_error; 82static Lisp_Object Qand_optional;
62Lisp_Object Qdeclare; 83static Lisp_Object Qdebug_on_error;
63Lisp_Object Qdebug; 84static Lisp_Object Qdeclare;
85Lisp_Object Qinternal_interpreter_environment, Qclosure;
86
87static Lisp_Object Qdebug;
64 88
65/* This holds either the symbol `run-hooks' or nil. 89/* This holds either the symbol `run-hooks' or nil.
66 It is nil at an early stage of startup, and when Emacs 90 It is nil at an early stage of startup, and when Emacs
@@ -89,7 +113,7 @@ struct specbinding *specpdl_ptr;
89 113
90/* Depth in Lisp evaluations and function calls. */ 114/* Depth in Lisp evaluations and function calls. */
91 115
92EMACS_INT lisp_eval_depth; 116static EMACS_INT lisp_eval_depth;
93 117
94/* The value of num_nonmacro_input_events as of the last time we 118/* The value of num_nonmacro_input_events as of the last time we
95 started to enter the debugger. If we decide to enter the debugger 119 started to enter the debugger. If we decide to enter the debugger
@@ -98,7 +122,7 @@ EMACS_INT lisp_eval_depth;
98 signal the error instead of entering an infinite loop of debugger 122 signal the error instead of entering an infinite loop of debugger
99 invocations. */ 123 invocations. */
100 124
101int when_entered_debugger; 125static int when_entered_debugger;
102 126
103/* The function from which the last `signal' was called. Set in 127/* The function from which the last `signal' was called. Set in
104 Fsignal. */ 128 Fsignal. */
@@ -111,10 +135,11 @@ Lisp_Object Vsignaling_function;
111 135
112int handling_signal; 136int handling_signal;
113 137
114static Lisp_Object funcall_lambda (Lisp_Object, int, Lisp_Object*); 138static Lisp_Object funcall_lambda (Lisp_Object, ptrdiff_t, Lisp_Object *);
115static void unwind_to_catch (struct catchtag *, Lisp_Object) NO_RETURN; 139static void unwind_to_catch (struct catchtag *, Lisp_Object) NO_RETURN;
116static int interactive_p (int); 140static int interactive_p (int);
117static Lisp_Object apply_lambda (Lisp_Object, Lisp_Object, int); 141static Lisp_Object apply_lambda (Lisp_Object fun, Lisp_Object args);
142static Lisp_Object Ffetch_bytecode (Lisp_Object);
118 143
119void 144void
120init_eval_once (void) 145init_eval_once (void)
@@ -123,7 +148,7 @@ init_eval_once (void)
123 specpdl = (struct specbinding *) xmalloc (specpdl_size * sizeof (struct specbinding)); 148 specpdl = (struct specbinding *) xmalloc (specpdl_size * sizeof (struct specbinding));
124 specpdl_ptr = specpdl; 149 specpdl_ptr = specpdl;
125 /* Don't forget to update docs (lispref node "Local Variables"). */ 150 /* Don't forget to update docs (lispref node "Local Variables"). */
126 max_specpdl_size = 1000; 151 max_specpdl_size = 1300; /* 1000 is not enough for CEDET's c-by.el. */
127 max_lisp_eval_depth = 600; 152 max_lisp_eval_depth = 600;
128 153
129 Vrun_hooks = Qnil; 154 Vrun_hooks = Qnil;
@@ -146,7 +171,7 @@ init_eval (void)
146 when_entered_debugger = -1; 171 when_entered_debugger = -1;
147} 172}
148 173
149/* unwind-protect function used by call_debugger. */ 174/* Unwind-protect function used by call_debugger. */
150 175
151static Lisp_Object 176static Lisp_Object
152restore_stack_limits (Lisp_Object data) 177restore_stack_limits (Lisp_Object data)
@@ -158,7 +183,7 @@ restore_stack_limits (Lisp_Object data)
158 183
159/* Call the Lisp debugger, giving it argument ARG. */ 184/* Call the Lisp debugger, giving it argument ARG. */
160 185
161Lisp_Object 186static Lisp_Object
162call_debugger (Lisp_Object arg) 187call_debugger (Lisp_Object arg)
163{ 188{
164 int debug_while_redisplaying; 189 int debug_while_redisplaying;
@@ -214,7 +239,7 @@ call_debugger (Lisp_Object arg)
214 return unbind_to (count, val); 239 return unbind_to (count, val);
215} 240}
216 241
217void 242static void
218do_debug_on_call (Lisp_Object code) 243do_debug_on_call (Lisp_Object code)
219{ 244{
220 debug_on_next_call = 0; 245 debug_on_next_call = 0;
@@ -240,7 +265,7 @@ usage: (or CONDITIONS...) */)
240 265
241 while (CONSP (args)) 266 while (CONSP (args))
242 { 267 {
243 val = Feval (XCAR (args)); 268 val = eval_sub (XCAR (args));
244 if (!NILP (val)) 269 if (!NILP (val))
245 break; 270 break;
246 args = XCDR (args); 271 args = XCDR (args);
@@ -264,7 +289,7 @@ usage: (and CONDITIONS...) */)
264 289
265 while (CONSP (args)) 290 while (CONSP (args))
266 { 291 {
267 val = Feval (XCAR (args)); 292 val = eval_sub (XCAR (args));
268 if (NILP (val)) 293 if (NILP (val))
269 break; 294 break;
270 args = XCDR (args); 295 args = XCDR (args);
@@ -286,11 +311,11 @@ usage: (if COND THEN ELSE...) */)
286 struct gcpro gcpro1; 311 struct gcpro gcpro1;
287 312
288 GCPRO1 (args); 313 GCPRO1 (args);
289 cond = Feval (Fcar (args)); 314 cond = eval_sub (Fcar (args));
290 UNGCPRO; 315 UNGCPRO;
291 316
292 if (!NILP (cond)) 317 if (!NILP (cond))
293 return Feval (Fcar (Fcdr (args))); 318 return eval_sub (Fcar (Fcdr (args)));
294 return Fprogn (Fcdr (Fcdr (args))); 319 return Fprogn (Fcdr (Fcdr (args)));
295} 320}
296 321
@@ -314,7 +339,7 @@ usage: (cond CLAUSES...) */)
314 while (!NILP (args)) 339 while (!NILP (args))
315 { 340 {
316 clause = Fcar (args); 341 clause = Fcar (args);
317 val = Feval (Fcar (clause)); 342 val = eval_sub (Fcar (clause));
318 if (!NILP (val)) 343 if (!NILP (val))
319 { 344 {
320 if (!EQ (XCDR (clause), Qnil)) 345 if (!EQ (XCDR (clause), Qnil))
@@ -340,7 +365,7 @@ usage: (progn BODY...) */)
340 365
341 while (CONSP (args)) 366 while (CONSP (args))
342 { 367 {
343 val = Feval (XCAR (args)); 368 val = eval_sub (XCAR (args));
344 args = XCDR (args); 369 args = XCDR (args);
345 } 370 }
346 371
@@ -369,13 +394,12 @@ usage: (prog1 FIRST BODY...) */)
369 394
370 do 395 do
371 { 396 {
397 Lisp_Object tem = eval_sub (XCAR (args_left));
372 if (!(argnum++)) 398 if (!(argnum++))
373 val = Feval (Fcar (args_left)); 399 val = tem;
374 else 400 args_left = XCDR (args_left);
375 Feval (Fcar (args_left));
376 args_left = Fcdr (args_left);
377 } 401 }
378 while (!NILP(args_left)); 402 while (CONSP (args_left));
379 403
380 UNGCPRO; 404 UNGCPRO;
381 return val; 405 return val;
@@ -404,13 +428,12 @@ usage: (prog2 FORM1 FORM2 BODY...) */)
404 428
405 do 429 do
406 { 430 {
431 Lisp_Object tem = eval_sub (XCAR (args_left));
407 if (!(argnum++)) 432 if (!(argnum++))
408 val = Feval (Fcar (args_left)); 433 val = tem;
409 else 434 args_left = XCDR (args_left);
410 Feval (Fcar (args_left));
411 args_left = Fcdr (args_left);
412 } 435 }
413 while (!NILP (args_left)); 436 while (CONSP (args_left));
414 437
415 UNGCPRO; 438 UNGCPRO;
416 return val; 439 return val;
@@ -428,7 +451,7 @@ usage: (setq [SYM VAL]...) */)
428 (Lisp_Object args) 451 (Lisp_Object args)
429{ 452{
430 register Lisp_Object args_left; 453 register Lisp_Object args_left;
431 register Lisp_Object val, sym; 454 register Lisp_Object val, sym, lex_binding;
432 struct gcpro gcpro1; 455 struct gcpro gcpro1;
433 456
434 if (NILP (args)) 457 if (NILP (args))
@@ -439,9 +462,19 @@ usage: (setq [SYM VAL]...) */)
439 462
440 do 463 do
441 { 464 {
442 val = Feval (Fcar (Fcdr (args_left))); 465 val = eval_sub (Fcar (Fcdr (args_left)));
443 sym = Fcar (args_left); 466 sym = Fcar (args_left);
444 Fset (sym, val); 467
468 /* Like for eval_sub, we do not check declared_special here since
469 it's been done when let-binding. */
470 if (!NILP (Vinternal_interpreter_environment) /* Mere optimization! */
471 && SYMBOLP (sym)
472 && !NILP (lex_binding
473 = Fassq (sym, Vinternal_interpreter_environment)))
474 XSETCDR (lex_binding, val); /* SYM is lexically bound. */
475 else
476 Fset (sym, val); /* SYM is dynamically bound. */
477
445 args_left = Fcdr (Fcdr (args_left)); 478 args_left = Fcdr (Fcdr (args_left));
446 } 479 }
447 while (!NILP(args_left)); 480 while (!NILP(args_left));
@@ -467,9 +500,21 @@ In byte compilation, `function' causes its argument to be compiled.
467usage: (function ARG) */) 500usage: (function ARG) */)
468 (Lisp_Object args) 501 (Lisp_Object args)
469{ 502{
503 Lisp_Object quoted = XCAR (args);
504
470 if (!NILP (Fcdr (args))) 505 if (!NILP (Fcdr (args)))
471 xsignal2 (Qwrong_number_of_arguments, Qfunction, Flength (args)); 506 xsignal2 (Qwrong_number_of_arguments, Qfunction, Flength (args));
472 return Fcar (args); 507
508 if (!NILP (Vinternal_interpreter_environment)
509 && CONSP (quoted)
510 && EQ (XCAR (quoted), Qlambda))
511 /* This is a lambda expression within a lexical environment;
512 return an interpreted closure instead of a simple lambda. */
513 return Fcons (Qclosure, Fcons (Vinternal_interpreter_environment,
514 XCDR (quoted)));
515 else
516 /* Simply quote the argument. */
517 return quoted;
473} 518}
474 519
475 520
@@ -492,7 +537,7 @@ spec that specifies non-nil unconditionally (such as \"p\"); or (ii)
492use `called-interactively-p'. */) 537use `called-interactively-p'. */)
493 (void) 538 (void)
494{ 539{
495 return (INTERACTIVE && interactive_p (1)) ? Qt : Qnil; 540 return interactive_p (1) ? Qt : Qnil;
496} 541}
497 542
498 543
@@ -556,7 +601,7 @@ interactive_p (int exclude_subrs_p)
556 || btp->nargs == UNEVALLED)) 601 || btp->nargs == UNEVALLED))
557 btp = btp->next; 602 btp = btp->next;
558 603
559 /* btp now points at the frame of the innermost function that isn't 604 /* `btp' now points at the frame of the innermost function that isn't
560 a special form, ignoring frames for Finteractive_p and/or 605 a special form, ignoring frames for Finteractive_p and/or
561 Fbytecode at the top. If this frame is for a built-in function 606 Fbytecode at the top. If this frame is for a built-in function
562 (such as load or eval-region) return nil. */ 607 (such as load or eval-region) return nil. */
@@ -564,7 +609,7 @@ interactive_p (int exclude_subrs_p)
564 if (exclude_subrs_p && SUBRP (fun)) 609 if (exclude_subrs_p && SUBRP (fun))
565 return 0; 610 return 0;
566 611
567 /* btp points to the frame of a Lisp function that called interactive-p. 612 /* `btp' points to the frame of a Lisp function that called interactive-p.
568 Return t if that function was called interactively. */ 613 Return t if that function was called interactively. */
569 if (btp && btp->next && EQ (*btp->next->function, Qcall_interactively)) 614 if (btp && btp->next && EQ (*btp->next->function, Qcall_interactively))
570 return 1; 615 return 1;
@@ -585,6 +630,8 @@ usage: (defun NAME ARGLIST [DOCSTRING] BODY...) */)
585 fn_name = Fcar (args); 630 fn_name = Fcar (args);
586 CHECK_SYMBOL (fn_name); 631 CHECK_SYMBOL (fn_name);
587 defn = Fcons (Qlambda, Fcdr (args)); 632 defn = Fcons (Qlambda, Fcdr (args));
633 if (!NILP (Vinternal_interpreter_environment)) /* Mere optimization! */
634 defn = Ffunction (Fcons (defn, Qnil));
588 if (!NILP (Vpurify_flag)) 635 if (!NILP (Vpurify_flag))
589 defn = Fpurecopy (defn); 636 defn = Fpurecopy (defn);
590 if (CONSP (XSYMBOL (fn_name)->function) 637 if (CONSP (XSYMBOL (fn_name)->function)
@@ -656,7 +703,11 @@ usage: (defmacro NAME ARGLIST [DOCSTRING] [DECL] BODY...) */)
656 tail = Fcons (lambda_list, tail); 703 tail = Fcons (lambda_list, tail);
657 else 704 else
658 tail = Fcons (lambda_list, Fcons (doc, tail)); 705 tail = Fcons (lambda_list, Fcons (doc, tail));
659 defn = Fcons (Qmacro, Fcons (Qlambda, tail)); 706
707 defn = Fcons (Qlambda, tail);
708 if (!NILP (Vinternal_interpreter_environment)) /* Mere optimization! */
709 defn = Ffunction (Fcons (defn, Qnil));
710 defn = Fcons (Qmacro, defn);
660 711
661 if (!NILP (Vpurify_flag)) 712 if (!NILP (Vpurify_flag))
662 defn = Fpurecopy (defn); 713 defn = Fpurecopy (defn);
@@ -716,6 +767,8 @@ The return value is BASE-VARIABLE. */)
716 error ("Don't know how to make a let-bound variable an alias"); 767 error ("Don't know how to make a let-bound variable an alias");
717 } 768 }
718 769
770 sym->declared_special = 1;
771 XSYMBOL (base_variable)->declared_special = 1;
719 sym->redirect = SYMBOL_VARALIAS; 772 sym->redirect = SYMBOL_VARALIAS;
720 SET_SYMBOL_ALIAS (sym, XSYMBOL (base_variable)); 773 SET_SYMBOL_ALIAS (sym, XSYMBOL (base_variable));
721 sym->constant = SYMBOL_CONSTANT_P (base_variable); 774 sym->constant = SYMBOL_CONSTANT_P (base_variable);
@@ -761,20 +814,23 @@ usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */)
761 tem = Fdefault_boundp (sym); 814 tem = Fdefault_boundp (sym);
762 if (!NILP (tail)) 815 if (!NILP (tail))
763 { 816 {
817 /* Do it before evaluating the initial value, for self-references. */
818 XSYMBOL (sym)->declared_special = 1;
819
764 if (SYMBOL_CONSTANT_P (sym)) 820 if (SYMBOL_CONSTANT_P (sym))
765 { 821 {
766 /* For upward compatibility, allow (defvar :foo (quote :foo)). */ 822 /* For upward compatibility, allow (defvar :foo (quote :foo)). */
767 Lisp_Object tem = Fcar (tail); 823 Lisp_Object tem1 = Fcar (tail);
768 if (! (CONSP (tem) 824 if (! (CONSP (tem1)
769 && EQ (XCAR (tem), Qquote) 825 && EQ (XCAR (tem1), Qquote)
770 && CONSP (XCDR (tem)) 826 && CONSP (XCDR (tem1))
771 && EQ (XCAR (XCDR (tem)), sym))) 827 && EQ (XCAR (XCDR (tem1)), sym)))
772 error ("Constant symbol `%s' specified in defvar", 828 error ("Constant symbol `%s' specified in defvar",
773 SDATA (SYMBOL_NAME (sym))); 829 SDATA (SYMBOL_NAME (sym)));
774 } 830 }
775 831
776 if (NILP (tem)) 832 if (NILP (tem))
777 Fset_default (sym, Feval (Fcar (tail))); 833 Fset_default (sym, eval_sub (Fcar (tail)));
778 else 834 else
779 { /* Check if there is really a global binding rather than just a let 835 { /* Check if there is really a global binding rather than just a let
780 binding that shadows the global unboundness of the var. */ 836 binding that shadows the global unboundness of the var. */
@@ -800,11 +856,19 @@ usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */)
800 } 856 }
801 LOADHIST_ATTACH (sym); 857 LOADHIST_ATTACH (sym);
802 } 858 }
859 else if (!NILP (Vinternal_interpreter_environment)
860 && !XSYMBOL (sym)->declared_special)
861 /* A simple (defvar foo) with lexical scoping does "nothing" except
862 declare that var to be dynamically scoped *locally* (i.e. within
863 the current file or let-block). */
864 Vinternal_interpreter_environment =
865 Fcons (sym, Vinternal_interpreter_environment);
803 else 866 else
804 /* Simple (defvar <var>) should not count as a definition at all. 867 {
805 It could get in the way of other definitions, and unloading this 868 /* Simple (defvar <var>) should not count as a definition at all.
806 package could try to make the variable unbound. */ 869 It could get in the way of other definitions, and unloading this
807 ; 870 package could try to make the variable unbound. */
871 }
808 872
809 return sym; 873 return sym;
810} 874}
@@ -829,10 +893,11 @@ usage: (defconst SYMBOL INITVALUE [DOCSTRING]) */)
829 if (!NILP (Fcdr (Fcdr (Fcdr (args))))) 893 if (!NILP (Fcdr (Fcdr (Fcdr (args)))))
830 error ("Too many arguments"); 894 error ("Too many arguments");
831 895
832 tem = Feval (Fcar (Fcdr (args))); 896 tem = eval_sub (Fcar (Fcdr (args)));
833 if (!NILP (Vpurify_flag)) 897 if (!NILP (Vpurify_flag))
834 tem = Fpurecopy (tem); 898 tem = Fpurecopy (tem);
835 Fset_default (sym, tem); 899 Fset_default (sym, tem);
900 XSYMBOL (sym)->declared_special = 1;
836 tem = Fcar (Fcdr (Fcdr (args))); 901 tem = Fcar (Fcdr (Fcdr (args)));
837 if (!NILP (tem)) 902 if (!NILP (tem))
838 { 903 {
@@ -855,7 +920,8 @@ user_variable_p_eh (Lisp_Object ignore)
855static Lisp_Object 920static Lisp_Object
856lisp_indirect_variable (Lisp_Object sym) 921lisp_indirect_variable (Lisp_Object sym)
857{ 922{
858 XSETSYMBOL (sym, indirect_variable (XSYMBOL (sym))); 923 struct Lisp_Symbol *s = indirect_variable (XSYMBOL (sym));
924 XSETSYMBOL (sym, s);
859 return sym; 925 return sym;
860} 926}
861 927
@@ -918,27 +984,53 @@ Each VALUEFORM can refer to the symbols already bound by this VARLIST.
918usage: (let* VARLIST BODY...) */) 984usage: (let* VARLIST BODY...) */)
919 (Lisp_Object args) 985 (Lisp_Object args)
920{ 986{
921 Lisp_Object varlist, val, elt; 987 Lisp_Object varlist, var, val, elt, lexenv;
922 int count = SPECPDL_INDEX (); 988 int count = SPECPDL_INDEX ();
923 struct gcpro gcpro1, gcpro2, gcpro3; 989 struct gcpro gcpro1, gcpro2, gcpro3;
924 990
925 GCPRO3 (args, elt, varlist); 991 GCPRO3 (args, elt, varlist);
926 992
993 lexenv = Vinternal_interpreter_environment;
994
927 varlist = Fcar (args); 995 varlist = Fcar (args);
928 while (!NILP (varlist)) 996 while (CONSP (varlist))
929 { 997 {
930 QUIT; 998 QUIT;
931 elt = Fcar (varlist); 999
1000 elt = XCAR (varlist);
932 if (SYMBOLP (elt)) 1001 if (SYMBOLP (elt))
933 specbind (elt, Qnil); 1002 {
1003 var = elt;
1004 val = Qnil;
1005 }
934 else if (! NILP (Fcdr (Fcdr (elt)))) 1006 else if (! NILP (Fcdr (Fcdr (elt))))
935 signal_error ("`let' bindings can have only one value-form", elt); 1007 signal_error ("`let' bindings can have only one value-form", elt);
936 else 1008 else
937 { 1009 {
938 val = Feval (Fcar (Fcdr (elt))); 1010 var = Fcar (elt);
939 specbind (Fcar (elt), val); 1011 val = eval_sub (Fcar (Fcdr (elt)));
940 } 1012 }
941 varlist = Fcdr (varlist); 1013
1014 if (!NILP (lexenv) && SYMBOLP (var)
1015 && !XSYMBOL (var)->declared_special
1016 && NILP (Fmemq (var, Vinternal_interpreter_environment)))
1017 /* Lexically bind VAR by adding it to the interpreter's binding
1018 alist. */
1019 {
1020 Lisp_Object newenv
1021 = Fcons (Fcons (var, val), Vinternal_interpreter_environment);
1022 if (EQ (Vinternal_interpreter_environment, lexenv))
1023 /* Save the old lexical environment on the specpdl stack,
1024 but only for the first lexical binding, since we'll never
1025 need to revert to one of the intermediate ones. */
1026 specbind (Qinternal_interpreter_environment, newenv);
1027 else
1028 Vinternal_interpreter_environment = newenv;
1029 }
1030 else
1031 specbind (var, val);
1032
1033 varlist = XCDR (varlist);
942 } 1034 }
943 UNGCPRO; 1035 UNGCPRO;
944 val = Fprogn (Fcdr (args)); 1036 val = Fprogn (Fcdr (args));
@@ -954,20 +1046,20 @@ All the VALUEFORMs are evalled before any symbols are bound.
954usage: (let VARLIST BODY...) */) 1046usage: (let VARLIST BODY...) */)
955 (Lisp_Object args) 1047 (Lisp_Object args)
956{ 1048{
957 Lisp_Object *temps, tem; 1049 Lisp_Object *temps, tem, lexenv;
958 register Lisp_Object elt, varlist; 1050 register Lisp_Object elt, varlist;
959 int count = SPECPDL_INDEX (); 1051 int count = SPECPDL_INDEX ();
960 register int argnum; 1052 ptrdiff_t argnum;
961 struct gcpro gcpro1, gcpro2; 1053 struct gcpro gcpro1, gcpro2;
962 USE_SAFE_ALLOCA; 1054 USE_SAFE_ALLOCA;
963 1055
964 varlist = Fcar (args); 1056 varlist = Fcar (args);
965 1057
966 /* Make space to hold the values to give the bound variables */ 1058 /* Make space to hold the values to give the bound variables. */
967 elt = Flength (varlist); 1059 elt = Flength (varlist);
968 SAFE_ALLOCA_LISP (temps, XFASTINT (elt)); 1060 SAFE_ALLOCA_LISP (temps, XFASTINT (elt));
969 1061
970 /* Compute the values and store them in `temps' */ 1062 /* Compute the values and store them in `temps'. */
971 1063
972 GCPRO2 (args, *temps); 1064 GCPRO2 (args, *temps);
973 gcpro2.nvars = 0; 1065 gcpro2.nvars = 0;
@@ -981,22 +1073,36 @@ usage: (let VARLIST BODY...) */)
981 else if (! NILP (Fcdr (Fcdr (elt)))) 1073 else if (! NILP (Fcdr (Fcdr (elt))))
982 signal_error ("`let' bindings can have only one value-form", elt); 1074 signal_error ("`let' bindings can have only one value-form", elt);
983 else 1075 else
984 temps [argnum++] = Feval (Fcar (Fcdr (elt))); 1076 temps [argnum++] = eval_sub (Fcar (Fcdr (elt)));
985 gcpro2.nvars = argnum; 1077 gcpro2.nvars = argnum;
986 } 1078 }
987 UNGCPRO; 1079 UNGCPRO;
988 1080
1081 lexenv = Vinternal_interpreter_environment;
1082
989 varlist = Fcar (args); 1083 varlist = Fcar (args);
990 for (argnum = 0; CONSP (varlist); varlist = XCDR (varlist)) 1084 for (argnum = 0; CONSP (varlist); varlist = XCDR (varlist))
991 { 1085 {
1086 Lisp_Object var;
1087
992 elt = XCAR (varlist); 1088 elt = XCAR (varlist);
1089 var = SYMBOLP (elt) ? elt : Fcar (elt);
993 tem = temps[argnum++]; 1090 tem = temps[argnum++];
994 if (SYMBOLP (elt)) 1091
995 specbind (elt, tem); 1092 if (!NILP (lexenv) && SYMBOLP (var)
1093 && !XSYMBOL (var)->declared_special
1094 && NILP (Fmemq (var, Vinternal_interpreter_environment)))
1095 /* Lexically bind VAR by adding it to the lexenv alist. */
1096 lexenv = Fcons (Fcons (var, tem), lexenv);
996 else 1097 else
997 specbind (Fcar (elt), tem); 1098 /* Dynamically bind VAR. */
1099 specbind (var, tem);
998 } 1100 }
999 1101
1102 if (!EQ (lexenv, Vinternal_interpreter_environment))
1103 /* Instantiate a new lexical environment. */
1104 specbind (Qinternal_interpreter_environment, lexenv);
1105
1000 elt = Fprogn (Fcdr (args)); 1106 elt = Fprogn (Fcdr (args));
1001 SAFE_FREE (); 1107 SAFE_FREE ();
1002 return unbind_to (count, elt); 1108 return unbind_to (count, elt);
@@ -1016,7 +1122,7 @@ usage: (while TEST BODY...) */)
1016 1122
1017 test = Fcar (args); 1123 test = Fcar (args);
1018 body = Fcdr (args); 1124 body = Fcdr (args);
1019 while (!NILP (Feval (test))) 1125 while (!NILP (eval_sub (test)))
1020 { 1126 {
1021 QUIT; 1127 QUIT;
1022 Fprogn (body); 1128 Fprogn (body);
@@ -1070,7 +1176,7 @@ definitions to shadow the loaded ones for use in file byte-compilation. */)
1070 /* SYM is not mentioned in ENVIRONMENT. 1176 /* SYM is not mentioned in ENVIRONMENT.
1071 Look at its function definition. */ 1177 Look at its function definition. */
1072 if (EQ (def, Qunbound) || !CONSP (def)) 1178 if (EQ (def, Qunbound) || !CONSP (def))
1073 /* Not defined or definition not suitable */ 1179 /* Not defined or definition not suitable. */
1074 break; 1180 break;
1075 if (EQ (XCAR (def), Qautoload)) 1181 if (EQ (XCAR (def), Qautoload))
1076 { 1182 {
@@ -1118,7 +1224,7 @@ usage: (catch TAG BODY...) */)
1118 struct gcpro gcpro1; 1224 struct gcpro gcpro1;
1119 1225
1120 GCPRO1 (args); 1226 GCPRO1 (args);
1121 tag = Feval (Fcar (args)); 1227 tag = eval_sub (Fcar (args));
1122 UNGCPRO; 1228 UNGCPRO;
1123 return internal_catch (tag, Fprogn, Fcdr (args)); 1229 return internal_catch (tag, Fprogn, Fcdr (args));
1124} 1230}
@@ -1211,10 +1317,7 @@ unwind_to_catch (struct catchtag *catch, Lisp_Object value)
1211 byte_stack_list = catch->byte_stack; 1317 byte_stack_list = catch->byte_stack;
1212 gcprolist = catch->gcpro; 1318 gcprolist = catch->gcpro;
1213#ifdef DEBUG_GCPRO 1319#ifdef DEBUG_GCPRO
1214 if (gcprolist != 0) 1320 gcpro_level = gcprolist ? gcprolist->level + 1 : 0;
1215 gcpro_level = gcprolist->level + 1;
1216 else
1217 gcpro_level = 0;
1218#endif 1321#endif
1219 backtrace_list = catch->backlist; 1322 backtrace_list = catch->backlist;
1220 lisp_eval_depth = catch->lisp_eval_depth; 1323 lisp_eval_depth = catch->lisp_eval_depth;
@@ -1251,18 +1354,10 @@ usage: (unwind-protect BODYFORM UNWINDFORMS...) */)
1251 int count = SPECPDL_INDEX (); 1354 int count = SPECPDL_INDEX ();
1252 1355
1253 record_unwind_protect (Fprogn, Fcdr (args)); 1356 record_unwind_protect (Fprogn, Fcdr (args));
1254 val = Feval (Fcar (args)); 1357 val = eval_sub (Fcar (args));
1255 return unbind_to (count, val); 1358 return unbind_to (count, val);
1256} 1359}
1257 1360
1258/* Chain of condition handlers currently in effect.
1259 The elements of this chain are contained in the stack frames
1260 of Fcondition_case and internal_condition_case.
1261 When an error is signaled (by calling Fsignal, below),
1262 this chain is searched for an element that applies. */
1263
1264struct handler *handlerlist;
1265
1266DEFUN ("condition-case", Fcondition_case, Scondition_case, 2, UNEVALLED, 0, 1361DEFUN ("condition-case", Fcondition_case, Scondition_case, 2, UNEVALLED, 0,
1267 doc: /* Regain control when an error is signaled. 1362 doc: /* Regain control when an error is signaled.
1268Executes BODYFORM and returns its value if no error happens. 1363Executes BODYFORM and returns its value if no error happens.
@@ -1318,7 +1413,8 @@ internal_lisp_condition_case (volatile Lisp_Object var, Lisp_Object bodyform,
1318 || (CONSP (tem) 1413 || (CONSP (tem)
1319 && (SYMBOLP (XCAR (tem)) 1414 && (SYMBOLP (XCAR (tem))
1320 || CONSP (XCAR (tem)))))) 1415 || CONSP (XCAR (tem))))))
1321 error ("Invalid condition handler", tem); 1416 error ("Invalid condition handler: %s",
1417 SDATA (Fprin1_to_string (tem, Qt)));
1322 } 1418 }
1323 1419
1324 c.tag = Qnil; 1420 c.tag = Qnil;
@@ -1352,7 +1448,7 @@ internal_lisp_condition_case (volatile Lisp_Object var, Lisp_Object bodyform,
1352 h.tag = &c; 1448 h.tag = &c;
1353 handlerlist = &h; 1449 handlerlist = &h;
1354 1450
1355 val = Feval (bodyform); 1451 val = eval_sub (bodyform);
1356 catchlist = c.next; 1452 catchlist = c.next;
1357 handlerlist = h.next; 1453 handlerlist = h.next;
1358 return val; 1454 return val;
@@ -1509,8 +1605,8 @@ internal_condition_case_2 (Lisp_Object (*bfun) (Lisp_Object, Lisp_Object),
1509 and ARGS as second argument. */ 1605 and ARGS as second argument. */
1510 1606
1511Lisp_Object 1607Lisp_Object
1512internal_condition_case_n (Lisp_Object (*bfun) (int, Lisp_Object*), 1608internal_condition_case_n (Lisp_Object (*bfun) (ptrdiff_t, Lisp_Object *),
1513 int nargs, 1609 ptrdiff_t nargs,
1514 Lisp_Object *args, 1610 Lisp_Object *args,
1515 Lisp_Object handlers, 1611 Lisp_Object handlers,
1516 Lisp_Object (*hfun) (Lisp_Object)) 1612 Lisp_Object (*hfun) (Lisp_Object))
@@ -1637,7 +1733,7 @@ See also the function `condition-case'. */)
1637 if (!NILP (clause)) 1733 if (!NILP (clause))
1638 break; 1734 break;
1639 } 1735 }
1640 1736
1641 if (/* Don't run the debugger for a memory-full error. 1737 if (/* Don't run the debugger for a memory-full error.
1642 (There is no room in memory to do that!) */ 1738 (There is no room in memory to do that!) */
1643 !NILP (error_symbol) 1739 !NILP (error_symbol)
@@ -1654,13 +1750,13 @@ See also the function `condition-case'. */)
1654 can continue code which has signaled a quit. */ 1750 can continue code which has signaled a quit. */
1655 if (debugger_called && EQ (real_error_symbol, Qquit)) 1751 if (debugger_called && EQ (real_error_symbol, Qquit))
1656 return Qnil; 1752 return Qnil;
1657 } 1753 }
1658 1754
1659 if (!NILP (clause)) 1755 if (!NILP (clause))
1660 { 1756 {
1661 Lisp_Object unwind_data 1757 Lisp_Object unwind_data
1662 = (NILP (error_symbol) ? data : Fcons (error_symbol, data)); 1758 = (NILP (error_symbol) ? data : Fcons (error_symbol, data));
1663 1759
1664 h->chosen_clause = clause; 1760 h->chosen_clause = clause;
1665 unwind_to_catch (h->tag, unwind_data); 1761 unwind_to_catch (h->tag, unwind_data);
1666 } 1762 }
@@ -1672,9 +1768,9 @@ See also the function `condition-case'. */)
1672 1768
1673 if (! NILP (error_symbol)) 1769 if (! NILP (error_symbol))
1674 data = Fcons (error_symbol, data); 1770 data = Fcons (error_symbol, data);
1675 1771
1676 string = Ferror_message_string (data); 1772 string = Ferror_message_string (data);
1677 fatal ("%s", SDATA (string), 0); 1773 fatal ("%s", SDATA (string));
1678} 1774}
1679 1775
1680/* Internal version of Fsignal that never returns. 1776/* Internal version of Fsignal that never returns.
@@ -1822,7 +1918,7 @@ maybe_call_debugger (Lisp_Object conditions, Lisp_Object sig, Lisp_Object data)
1822 ? debug_on_quit 1918 ? debug_on_quit
1823 : wants_debugger (Vdebug_on_error, conditions)) 1919 : wants_debugger (Vdebug_on_error, conditions))
1824 && ! skip_debugger (conditions, combined_data) 1920 && ! skip_debugger (conditions, combined_data)
1825 /* rms: what's this for? */ 1921 /* RMS: What's this for? */
1826 && when_entered_debugger < num_nonmacro_input_events) 1922 && when_entered_debugger < num_nonmacro_input_events)
1827 { 1923 {
1828 call_debugger (Fcons (Qerror, Fcons (combined_data, Qnil))); 1924 call_debugger (Fcons (Qerror, Fcons (combined_data, Qnil)));
@@ -1889,44 +1985,51 @@ find_handler_clause (Lisp_Object handlers, Lisp_Object conditions,
1889} 1985}
1890 1986
1891 1987
1892/* dump an error message; called like vprintf */ 1988/* Dump an error message; called like vprintf. */
1893void 1989void
1894verror (const char *m, va_list ap) 1990verror (const char *m, va_list ap)
1895{ 1991{
1896 char buf[200]; 1992 char buf[4000];
1897 EMACS_INT size = 200; 1993 size_t size = sizeof buf;
1898 int mlen; 1994 size_t size_max = STRING_BYTES_BOUND + 1;
1995 size_t mlen = strlen (m);
1899 char *buffer = buf; 1996 char *buffer = buf;
1900 int allocated = 0; 1997 size_t used;
1901 Lisp_Object string; 1998 Lisp_Object string;
1902 1999
1903 mlen = strlen (m);
1904
1905 while (1) 2000 while (1)
1906 { 2001 {
1907 EMACS_INT used; 2002 va_list ap_copy;
1908 used = doprnt (buffer, size, m, m + mlen, ap); 2003 va_copy (ap_copy, ap);
1909 if (used < size) 2004 used = doprnt (buffer, size, m, m + mlen, ap_copy);
2005 va_end (ap_copy);
2006
2007 /* Note: the -1 below is because `doprnt' returns the number of bytes
2008 excluding the terminating null byte, and it always terminates with a
2009 null byte, even when producing a truncated message. */
2010 if (used < size - 1)
1910 break; 2011 break;
1911 size *= 2; 2012 if (size <= size_max / 2)
1912 if (allocated) 2013 size *= 2;
1913 buffer = (char *) xrealloc (buffer, size); 2014 else if (size < size_max)
2015 size = size_max;
1914 else 2016 else
1915 { 2017 break; /* and leave the message truncated */
1916 buffer = (char *) xmalloc (size); 2018
1917 allocated = 1; 2019 if (buffer != buf)
1918 } 2020 xfree (buffer);
2021 buffer = (char *) xmalloc (size);
1919 } 2022 }
1920 2023
1921 string = build_string (buffer); 2024 string = make_string (buffer, used);
1922 if (allocated) 2025 if (buffer != buf)
1923 xfree (buffer); 2026 xfree (buffer);
1924 2027
1925 xsignal1 (Qerror, string); 2028 xsignal1 (Qerror, string);
1926} 2029}
1927 2030
1928 2031
1929/* dump an error message; called like printf */ 2032/* Dump an error message; called like printf. */
1930 2033
1931/* VARARGS 1 */ 2034/* VARARGS 1 */
1932void 2035void
@@ -1996,9 +2099,12 @@ then strings and vectors are not accepted. */)
1996 if (!CONSP (fun)) 2099 if (!CONSP (fun))
1997 return Qnil; 2100 return Qnil;
1998 funcar = XCAR (fun); 2101 funcar = XCAR (fun);
1999 if (EQ (funcar, Qlambda)) 2102 if (EQ (funcar, Qclosure))
2103 return (!NILP (Fassq (Qinteractive, Fcdr (Fcdr (XCDR (fun)))))
2104 ? Qt : if_prop);
2105 else if (EQ (funcar, Qlambda))
2000 return !NILP (Fassq (Qinteractive, Fcdr (XCDR (fun)))) ? Qt : if_prop; 2106 return !NILP (Fassq (Qinteractive, Fcdr (XCDR (fun)))) ? Qt : if_prop;
2001 if (EQ (funcar, Qautoload)) 2107 else if (EQ (funcar, Qautoload))
2002 return !NILP (Fcar (Fcdr (Fcdr (XCDR (fun))))) ? Qt : if_prop; 2108 return !NILP (Fcar (Fcdr (Fcdr (XCDR (fun))))) ? Qt : if_prop;
2003 else 2109 else
2004 return Qnil; 2110 return Qnil;
@@ -2022,7 +2128,7 @@ this does nothing and returns nil. */)
2022 CHECK_SYMBOL (function); 2128 CHECK_SYMBOL (function);
2023 CHECK_STRING (file); 2129 CHECK_STRING (file);
2024 2130
2025 /* If function is defined and not as an autoload, don't override */ 2131 /* If function is defined and not as an autoload, don't override. */
2026 if (!EQ (XSYMBOL (function)->function, Qunbound) 2132 if (!EQ (XSYMBOL (function)->function, Qunbound)
2027 && !(CONSP (XSYMBOL (function)->function) 2133 && !(CONSP (XSYMBOL (function)->function)
2028 && EQ (XCAR (XSYMBOL (function)->function), Qautoload))) 2134 && EQ (XCAR (XSYMBOL (function)->function), Qautoload)))
@@ -2038,7 +2144,7 @@ this does nothing and returns nil. */)
2038 We used to use 0 here, but that leads to accidental sharing in 2144 We used to use 0 here, but that leads to accidental sharing in
2039 purecopy's hash-consing, so we use a (hopefully) unique integer 2145 purecopy's hash-consing, so we use a (hopefully) unique integer
2040 instead. */ 2146 instead. */
2041 docstring = make_number (XHASH (function)); 2147 docstring = make_number (XPNTR (function));
2042 return Ffset (function, 2148 return Ffset (function,
2043 Fpurecopy (list5 (Qautoload, file, docstring, 2149 Fpurecopy (list5 (Qautoload, file, docstring,
2044 interactive, type))); 2150 interactive, type)));
@@ -2116,9 +2222,21 @@ do_autoload (Lisp_Object fundef, Lisp_Object funname)
2116} 2222}
2117 2223
2118 2224
2119DEFUN ("eval", Feval, Seval, 1, 1, 0, 2225DEFUN ("eval", Feval, Seval, 1, 2, 0,
2120 doc: /* Evaluate FORM and return its value. */) 2226 doc: /* Evaluate FORM and return its value.
2121 (Lisp_Object form) 2227If LEXICAL is t, evaluate using lexical scoping. */)
2228 (Lisp_Object form, Lisp_Object lexical)
2229{
2230 int count = SPECPDL_INDEX ();
2231 specbind (Qinternal_interpreter_environment,
2232 NILP (lexical) ? Qnil : Fcons (Qt, Qnil));
2233 return unbind_to (count, eval_sub (form));
2234}
2235
2236/* Eval a sub-expression of the current expression (i.e. in the same
2237 lexical scope). */
2238Lisp_Object
2239eval_sub (Lisp_Object form)
2122{ 2240{
2123 Lisp_Object fun, val, original_fun, original_args; 2241 Lisp_Object fun, val, original_fun, original_args;
2124 Lisp_Object funcar; 2242 Lisp_Object funcar;
@@ -2129,7 +2247,20 @@ DEFUN ("eval", Feval, Seval, 1, 1, 0,
2129 abort (); 2247 abort ();
2130 2248
2131 if (SYMBOLP (form)) 2249 if (SYMBOLP (form))
2132 return Fsymbol_value (form); 2250 {
2251 /* Look up its binding in the lexical environment.
2252 We do not pay attention to the declared_special flag here, since we
2253 already did that when let-binding the variable. */
2254 Lisp_Object lex_binding
2255 = !NILP (Vinternal_interpreter_environment) /* Mere optimization! */
2256 ? Fassq (form, Vinternal_interpreter_environment)
2257 : Qnil;
2258 if (CONSP (lex_binding))
2259 return XCDR (lex_binding);
2260 else
2261 return Fsymbol_value (form);
2262 }
2263
2133 if (!CONSP (form)) 2264 if (!CONSP (form))
2134 return form; 2265 return form;
2135 2266
@@ -2157,7 +2288,7 @@ DEFUN ("eval", Feval, Seval, 1, 1, 0,
2157 2288
2158 backtrace.next = backtrace_list; 2289 backtrace.next = backtrace_list;
2159 backtrace_list = &backtrace; 2290 backtrace_list = &backtrace;
2160 backtrace.function = &original_fun; /* This also protects them from gc */ 2291 backtrace.function = &original_fun; /* This also protects them from gc. */
2161 backtrace.args = &original_args; 2292 backtrace.args = &original_args;
2162 backtrace.nargs = UNEVALLED; 2293 backtrace.nargs = UNEVALLED;
2163 backtrace.evalargs = 1; 2294 backtrace.evalargs = 1;
@@ -2167,7 +2298,7 @@ DEFUN ("eval", Feval, Seval, 1, 1, 0,
2167 do_debug_on_call (Qt); 2298 do_debug_on_call (Qt);
2168 2299
2169 /* At this point, only original_fun and original_args 2300 /* At this point, only original_fun and original_args
2170 have values that will be used below */ 2301 have values that will be used below. */
2171 retry: 2302 retry:
2172 2303
2173 /* Optimize for no indirection. */ 2304 /* Optimize for no indirection. */
@@ -2188,8 +2319,9 @@ DEFUN ("eval", Feval, Seval, 1, 1, 0,
2188 2319
2189 CHECK_CONS_LIST (); 2320 CHECK_CONS_LIST ();
2190 2321
2191 if (XINT (numargs) < XSUBR (fun)->min_args || 2322 if (XINT (numargs) < XSUBR (fun)->min_args
2192 (XSUBR (fun)->max_args >= 0 && XSUBR (fun)->max_args < XINT (numargs))) 2323 || (XSUBR (fun)->max_args >= 0
2324 && XSUBR (fun)->max_args < XINT (numargs)))
2193 xsignal2 (Qwrong_number_of_arguments, original_fun, numargs); 2325 xsignal2 (Qwrong_number_of_arguments, original_fun, numargs);
2194 2326
2195 else if (XSUBR (fun)->max_args == UNEVALLED) 2327 else if (XSUBR (fun)->max_args == UNEVALLED)
@@ -2199,9 +2331,9 @@ DEFUN ("eval", Feval, Seval, 1, 1, 0,
2199 } 2331 }
2200 else if (XSUBR (fun)->max_args == MANY) 2332 else if (XSUBR (fun)->max_args == MANY)
2201 { 2333 {
2202 /* Pass a vector of evaluated arguments */ 2334 /* Pass a vector of evaluated arguments. */
2203 Lisp_Object *vals; 2335 Lisp_Object *vals;
2204 register int argnum = 0; 2336 ptrdiff_t argnum = 0;
2205 USE_SAFE_ALLOCA; 2337 USE_SAFE_ALLOCA;
2206 2338
2207 SAFE_ALLOCA_LISP (vals, XINT (numargs)); 2339 SAFE_ALLOCA_LISP (vals, XINT (numargs));
@@ -2212,7 +2344,7 @@ DEFUN ("eval", Feval, Seval, 1, 1, 0,
2212 2344
2213 while (!NILP (args_left)) 2345 while (!NILP (args_left))
2214 { 2346 {
2215 vals[argnum++] = Feval (Fcar (args_left)); 2347 vals[argnum++] = eval_sub (Fcar (args_left));
2216 args_left = Fcdr (args_left); 2348 args_left = Fcdr (args_left);
2217 gcpro3.nvars = argnum; 2349 gcpro3.nvars = argnum;
2218 } 2350 }
@@ -2233,7 +2365,7 @@ DEFUN ("eval", Feval, Seval, 1, 1, 0,
2233 maxargs = XSUBR (fun)->max_args; 2365 maxargs = XSUBR (fun)->max_args;
2234 for (i = 0; i < maxargs; args_left = Fcdr (args_left)) 2366 for (i = 0; i < maxargs; args_left = Fcdr (args_left))
2235 { 2367 {
2236 argvals[i] = Feval (Fcar (args_left)); 2368 argvals[i] = eval_sub (Fcar (args_left));
2237 gcpro3.nvars = ++i; 2369 gcpro3.nvars = ++i;
2238 } 2370 }
2239 2371
@@ -2293,7 +2425,7 @@ DEFUN ("eval", Feval, Seval, 1, 1, 0,
2293 } 2425 }
2294 } 2426 }
2295 else if (COMPILEDP (fun)) 2427 else if (COMPILEDP (fun))
2296 val = apply_lambda (fun, original_args, 1); 2428 val = apply_lambda (fun, original_args);
2297 else 2429 else
2298 { 2430 {
2299 if (EQ (fun, Qunbound)) 2431 if (EQ (fun, Qunbound))
@@ -2309,9 +2441,10 @@ DEFUN ("eval", Feval, Seval, 1, 1, 0,
2309 goto retry; 2441 goto retry;
2310 } 2442 }
2311 if (EQ (funcar, Qmacro)) 2443 if (EQ (funcar, Qmacro))
2312 val = Feval (apply1 (Fcdr (fun), original_args)); 2444 val = eval_sub (apply1 (Fcdr (fun), original_args));
2313 else if (EQ (funcar, Qlambda)) 2445 else if (EQ (funcar, Qlambda)
2314 val = apply_lambda (fun, original_args, 1); 2446 || EQ (funcar, Qclosure))
2447 val = apply_lambda (fun, original_args);
2315 else 2448 else
2316 xsignal1 (Qinvalid_function, original_fun); 2449 xsignal1 (Qinvalid_function, original_fun);
2317 } 2450 }
@@ -2330,9 +2463,9 @@ DEFUN ("apply", Fapply, Sapply, 2, MANY, 0,
2330Then return the value FUNCTION returns. 2463Then return the value FUNCTION returns.
2331Thus, (apply '+ 1 2 '(3 4)) returns 10. 2464Thus, (apply '+ 1 2 '(3 4)) returns 10.
2332usage: (apply FUNCTION &rest ARGUMENTS) */) 2465usage: (apply FUNCTION &rest ARGUMENTS) */)
2333 (int nargs, Lisp_Object *args) 2466 (ptrdiff_t nargs, Lisp_Object *args)
2334{ 2467{
2335 register int i, numargs; 2468 ptrdiff_t i, numargs;
2336 register Lisp_Object spread_arg; 2469 register Lisp_Object spread_arg;
2337 register Lisp_Object *funcall_args; 2470 register Lisp_Object *funcall_args;
2338 Lisp_Object fun, retval; 2471 Lisp_Object fun, retval;
@@ -2362,7 +2495,7 @@ usage: (apply FUNCTION &rest ARGUMENTS) */)
2362 fun = indirect_function (fun); 2495 fun = indirect_function (fun);
2363 if (EQ (fun, Qunbound)) 2496 if (EQ (fun, Qunbound))
2364 { 2497 {
2365 /* Let funcall get the error */ 2498 /* Let funcall get the error. */
2366 fun = args[0]; 2499 fun = args[0];
2367 goto funcall; 2500 goto funcall;
2368 } 2501 }
@@ -2371,11 +2504,11 @@ usage: (apply FUNCTION &rest ARGUMENTS) */)
2371 { 2504 {
2372 if (numargs < XSUBR (fun)->min_args 2505 if (numargs < XSUBR (fun)->min_args
2373 || (XSUBR (fun)->max_args >= 0 && XSUBR (fun)->max_args < numargs)) 2506 || (XSUBR (fun)->max_args >= 0 && XSUBR (fun)->max_args < numargs))
2374 goto funcall; /* Let funcall get the error */ 2507 goto funcall; /* Let funcall get the error. */
2375 else if (XSUBR (fun)->max_args > numargs) 2508 else if (XSUBR (fun)->max_args >= 0 && XSUBR (fun)->max_args > numargs)
2376 { 2509 {
2377 /* Avoid making funcall cons up a yet another new vector of arguments 2510 /* Avoid making funcall cons up a yet another new vector of arguments
2378 by explicitly supplying nil's for optional values */ 2511 by explicitly supplying nil's for optional values. */
2379 SAFE_ALLOCA_LISP (funcall_args, 1 + XSUBR (fun)->max_args); 2512 SAFE_ALLOCA_LISP (funcall_args, 1 + XSUBR (fun)->max_args);
2380 for (i = numargs; i < XSUBR (fun)->max_args;) 2513 for (i = numargs; i < XSUBR (fun)->max_args;)
2381 funcall_args[++i] = Qnil; 2514 funcall_args[++i] = Qnil;
@@ -2413,9 +2546,12 @@ usage: (apply FUNCTION &rest ARGUMENTS) */)
2413 2546
2414/* Run hook variables in various ways. */ 2547/* Run hook variables in various ways. */
2415 2548
2416enum run_hooks_condition {to_completion, until_success, until_failure}; 2549static Lisp_Object
2417static Lisp_Object run_hook_with_args (int, Lisp_Object *, 2550funcall_nil (ptrdiff_t nargs, Lisp_Object *args)
2418 enum run_hooks_condition); 2551{
2552 Ffuncall (nargs, args);
2553 return Qnil;
2554}
2419 2555
2420DEFUN ("run-hooks", Frun_hooks, Srun_hooks, 0, MANY, 0, 2556DEFUN ("run-hooks", Frun_hooks, Srun_hooks, 0, MANY, 0,
2421 doc: /* Run each hook in HOOKS. 2557 doc: /* Run each hook in HOOKS.
@@ -2432,15 +2568,15 @@ hook; they should use `run-mode-hooks' instead.
2432Do not use `make-local-variable' to make a hook variable buffer-local. 2568Do not use `make-local-variable' to make a hook variable buffer-local.
2433Instead, use `add-hook' and specify t for the LOCAL argument. 2569Instead, use `add-hook' and specify t for the LOCAL argument.
2434usage: (run-hooks &rest HOOKS) */) 2570usage: (run-hooks &rest HOOKS) */)
2435 (int nargs, Lisp_Object *args) 2571 (ptrdiff_t nargs, Lisp_Object *args)
2436{ 2572{
2437 Lisp_Object hook[1]; 2573 Lisp_Object hook[1];
2438 register int i; 2574 ptrdiff_t i;
2439 2575
2440 for (i = 0; i < nargs; i++) 2576 for (i = 0; i < nargs; i++)
2441 { 2577 {
2442 hook[0] = args[i]; 2578 hook[0] = args[i];
2443 run_hook_with_args (1, hook, to_completion); 2579 run_hook_with_args (1, hook, funcall_nil);
2444 } 2580 }
2445 2581
2446 return Qnil; 2582 return Qnil;
@@ -2461,9 +2597,9 @@ as that may change.
2461Do not use `make-local-variable' to make a hook variable buffer-local. 2597Do not use `make-local-variable' to make a hook variable buffer-local.
2462Instead, use `add-hook' and specify t for the LOCAL argument. 2598Instead, use `add-hook' and specify t for the LOCAL argument.
2463usage: (run-hook-with-args HOOK &rest ARGS) */) 2599usage: (run-hook-with-args HOOK &rest ARGS) */)
2464 (int nargs, Lisp_Object *args) 2600 (ptrdiff_t nargs, Lisp_Object *args)
2465{ 2601{
2466 return run_hook_with_args (nargs, args, to_completion); 2602 return run_hook_with_args (nargs, args, funcall_nil);
2467} 2603}
2468 2604
2469DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success, 2605DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success,
@@ -2481,9 +2617,15 @@ However, if they all return nil, we return nil.
2481Do not use `make-local-variable' to make a hook variable buffer-local. 2617Do not use `make-local-variable' to make a hook variable buffer-local.
2482Instead, use `add-hook' and specify t for the LOCAL argument. 2618Instead, use `add-hook' and specify t for the LOCAL argument.
2483usage: (run-hook-with-args-until-success HOOK &rest ARGS) */) 2619usage: (run-hook-with-args-until-success HOOK &rest ARGS) */)
2484 (int nargs, Lisp_Object *args) 2620 (ptrdiff_t nargs, Lisp_Object *args)
2621{
2622 return run_hook_with_args (nargs, args, Ffuncall);
2623}
2624
2625static Lisp_Object
2626funcall_not (ptrdiff_t nargs, Lisp_Object *args)
2485{ 2627{
2486 return run_hook_with_args (nargs, args, until_success); 2628 return NILP (Ffuncall (nargs, args)) ? Qt : Qnil;
2487} 2629}
2488 2630
2489DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure, 2631DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure,
@@ -2500,23 +2642,47 @@ Then we return nil. However, if they all return non-nil, we return non-nil.
2500Do not use `make-local-variable' to make a hook variable buffer-local. 2642Do not use `make-local-variable' to make a hook variable buffer-local.
2501Instead, use `add-hook' and specify t for the LOCAL argument. 2643Instead, use `add-hook' and specify t for the LOCAL argument.
2502usage: (run-hook-with-args-until-failure HOOK &rest ARGS) */) 2644usage: (run-hook-with-args-until-failure HOOK &rest ARGS) */)
2503 (int nargs, Lisp_Object *args) 2645 (ptrdiff_t nargs, Lisp_Object *args)
2646{
2647 return NILP (run_hook_with_args (nargs, args, funcall_not)) ? Qt : Qnil;
2648}
2649
2650static Lisp_Object
2651run_hook_wrapped_funcall (ptrdiff_t nargs, Lisp_Object *args)
2652{
2653 Lisp_Object tmp = args[0], ret;
2654 args[0] = args[1];
2655 args[1] = tmp;
2656 ret = Ffuncall (nargs, args);
2657 args[1] = args[0];
2658 args[0] = tmp;
2659 return ret;
2660}
2661
2662DEFUN ("run-hook-wrapped", Frun_hook_wrapped, Srun_hook_wrapped, 2, MANY, 0,
2663 doc: /* Run HOOK, passing each function through WRAP-FUNCTION.
2664I.e. instead of calling each function FUN directly with arguments ARGS,
2665it calls WRAP-FUNCTION with arguments FUN and ARGS.
2666As soon as a call to WRAP-FUNCTION returns non-nil, `run-hook-wrapped'
2667aborts and returns that value.
2668usage: (run-hook-wrapped HOOK WRAP-FUNCTION &rest ARGS) */)
2669 (ptrdiff_t nargs, Lisp_Object *args)
2504{ 2670{
2505 return run_hook_with_args (nargs, args, until_failure); 2671 return run_hook_with_args (nargs, args, run_hook_wrapped_funcall);
2506} 2672}
2507 2673
2508/* ARGS[0] should be a hook symbol. 2674/* ARGS[0] should be a hook symbol.
2509 Call each of the functions in the hook value, passing each of them 2675 Call each of the functions in the hook value, passing each of them
2510 as arguments all the rest of ARGS (all NARGS - 1 elements). 2676 as arguments all the rest of ARGS (all NARGS - 1 elements).
2511 COND specifies a condition to test after each call 2677 FUNCALL specifies how to call each function on the hook.
2512 to decide whether to stop.
2513 The caller (or its caller, etc) must gcpro all of ARGS, 2678 The caller (or its caller, etc) must gcpro all of ARGS,
2514 except that it isn't necessary to gcpro ARGS[0]. */ 2679 except that it isn't necessary to gcpro ARGS[0]. */
2515 2680
2516static Lisp_Object 2681Lisp_Object
2517run_hook_with_args (int nargs, Lisp_Object *args, enum run_hooks_condition cond) 2682run_hook_with_args (ptrdiff_t nargs, Lisp_Object *args,
2683 Lisp_Object (*funcall) (ptrdiff_t nargs, Lisp_Object *args))
2518{ 2684{
2519 Lisp_Object sym, val, ret; 2685 Lisp_Object sym, val, ret = Qnil;
2520 struct gcpro gcpro1, gcpro2, gcpro3; 2686 struct gcpro gcpro1, gcpro2, gcpro3;
2521 2687
2522 /* If we are dying or still initializing, 2688 /* If we are dying or still initializing,
@@ -2526,58 +2692,53 @@ run_hook_with_args (int nargs, Lisp_Object *args, enum run_hooks_condition cond)
2526 2692
2527 sym = args[0]; 2693 sym = args[0];
2528 val = find_symbol_value (sym); 2694 val = find_symbol_value (sym);
2529 ret = (cond == until_failure ? Qt : Qnil);
2530 2695
2531 if (EQ (val, Qunbound) || NILP (val)) 2696 if (EQ (val, Qunbound) || NILP (val))
2532 return ret; 2697 return ret;
2533 else if (!CONSP (val) || EQ (XCAR (val), Qlambda)) 2698 else if (!CONSP (val) || EQ (XCAR (val), Qlambda))
2534 { 2699 {
2535 args[0] = val; 2700 args[0] = val;
2536 return Ffuncall (nargs, args); 2701 return funcall (nargs, args);
2537 } 2702 }
2538 else 2703 else
2539 { 2704 {
2540 Lisp_Object globals = Qnil; 2705 Lisp_Object global_vals = Qnil;
2541 GCPRO3 (sym, val, globals); 2706 GCPRO3 (sym, val, global_vals);
2542 2707
2543 for (; 2708 for (;
2544 CONSP (val) && ((cond == to_completion) 2709 CONSP (val) && NILP (ret);
2545 || (cond == until_success ? NILP (ret)
2546 : !NILP (ret)));
2547 val = XCDR (val)) 2710 val = XCDR (val))
2548 { 2711 {
2549 if (EQ (XCAR (val), Qt)) 2712 if (EQ (XCAR (val), Qt))
2550 { 2713 {
2551 /* t indicates this hook has a local binding; 2714 /* t indicates this hook has a local binding;
2552 it means to run the global binding too. */ 2715 it means to run the global binding too. */
2553 globals = Fdefault_value (sym); 2716 global_vals = Fdefault_value (sym);
2554 if (NILP (globals)) continue; 2717 if (NILP (global_vals)) continue;
2555 2718
2556 if (!CONSP (globals) || EQ (XCAR (globals), Qlambda)) 2719 if (!CONSP (global_vals) || EQ (XCAR (global_vals), Qlambda))
2557 { 2720 {
2558 args[0] = globals; 2721 args[0] = global_vals;
2559 ret = Ffuncall (nargs, args); 2722 ret = funcall (nargs, args);
2560 } 2723 }
2561 else 2724 else
2562 { 2725 {
2563 for (; 2726 for (;
2564 CONSP (globals) && ((cond == to_completion) 2727 CONSP (global_vals) && NILP (ret);
2565 || (cond == until_success ? NILP (ret) 2728 global_vals = XCDR (global_vals))
2566 : !NILP (ret)));
2567 globals = XCDR (globals))
2568 { 2729 {
2569 args[0] = XCAR (globals); 2730 args[0] = XCAR (global_vals);
2570 /* In a global value, t should not occur. If it does, we 2731 /* In a global value, t should not occur. If it does, we
2571 must ignore it to avoid an endless loop. */ 2732 must ignore it to avoid an endless loop. */
2572 if (!EQ (args[0], Qt)) 2733 if (!EQ (args[0], Qt))
2573 ret = Ffuncall (nargs, args); 2734 ret = funcall (nargs, args);
2574 } 2735 }
2575 } 2736 }
2576 } 2737 }
2577 else 2738 else
2578 { 2739 {
2579 args[0] = XCAR (val); 2740 args[0] = XCAR (val);
2580 ret = Ffuncall (nargs, args); 2741 ret = funcall (nargs, args);
2581 } 2742 }
2582 } 2743 }
2583 2744
@@ -2599,7 +2760,7 @@ run_hook_with_args_2 (Lisp_Object hook, Lisp_Object arg1, Lisp_Object arg2)
2599 Frun_hook_with_args (3, temp); 2760 Frun_hook_with_args (3, temp);
2600} 2761}
2601 2762
2602/* Apply fn to arg */ 2763/* Apply fn to arg. */
2603Lisp_Object 2764Lisp_Object
2604apply1 (Lisp_Object fn, Lisp_Object arg) 2765apply1 (Lisp_Object fn, Lisp_Object arg)
2605{ 2766{
@@ -2618,7 +2779,7 @@ apply1 (Lisp_Object fn, Lisp_Object arg)
2618 } 2779 }
2619} 2780}
2620 2781
2621/* Call function fn on no arguments */ 2782/* Call function fn on no arguments. */
2622Lisp_Object 2783Lisp_Object
2623call0 (Lisp_Object fn) 2784call0 (Lisp_Object fn)
2624{ 2785{
@@ -2628,7 +2789,7 @@ call0 (Lisp_Object fn)
2628 RETURN_UNGCPRO (Ffuncall (1, &fn)); 2789 RETURN_UNGCPRO (Ffuncall (1, &fn));
2629} 2790}
2630 2791
2631/* Call function fn with 1 argument arg1 */ 2792/* Call function fn with 1 argument arg1. */
2632/* ARGSUSED */ 2793/* ARGSUSED */
2633Lisp_Object 2794Lisp_Object
2634call1 (Lisp_Object fn, Lisp_Object arg1) 2795call1 (Lisp_Object fn, Lisp_Object arg1)
@@ -2643,7 +2804,7 @@ call1 (Lisp_Object fn, Lisp_Object arg1)
2643 RETURN_UNGCPRO (Ffuncall (2, args)); 2804 RETURN_UNGCPRO (Ffuncall (2, args));
2644} 2805}
2645 2806
2646/* Call function fn with 2 arguments arg1, arg2 */ 2807/* Call function fn with 2 arguments arg1, arg2. */
2647/* ARGSUSED */ 2808/* ARGSUSED */
2648Lisp_Object 2809Lisp_Object
2649call2 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2) 2810call2 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2)
@@ -2658,7 +2819,7 @@ call2 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2)
2658 RETURN_UNGCPRO (Ffuncall (3, args)); 2819 RETURN_UNGCPRO (Ffuncall (3, args));
2659} 2820}
2660 2821
2661/* Call function fn with 3 arguments arg1, arg2, arg3 */ 2822/* Call function fn with 3 arguments arg1, arg2, arg3. */
2662/* ARGSUSED */ 2823/* ARGSUSED */
2663Lisp_Object 2824Lisp_Object
2664call3 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3) 2825call3 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3)
@@ -2674,7 +2835,7 @@ call3 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3)
2674 RETURN_UNGCPRO (Ffuncall (4, args)); 2835 RETURN_UNGCPRO (Ffuncall (4, args));
2675} 2836}
2676 2837
2677/* Call function fn with 4 arguments arg1, arg2, arg3, arg4 */ 2838/* Call function fn with 4 arguments arg1, arg2, arg3, arg4. */
2678/* ARGSUSED */ 2839/* ARGSUSED */
2679Lisp_Object 2840Lisp_Object
2680call4 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, 2841call4 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3,
@@ -2692,7 +2853,7 @@ call4 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3,
2692 RETURN_UNGCPRO (Ffuncall (5, args)); 2853 RETURN_UNGCPRO (Ffuncall (5, args));
2693} 2854}
2694 2855
2695/* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5 */ 2856/* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5. */
2696/* ARGSUSED */ 2857/* ARGSUSED */
2697Lisp_Object 2858Lisp_Object
2698call5 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, 2859call5 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3,
@@ -2711,7 +2872,7 @@ call5 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3,
2711 RETURN_UNGCPRO (Ffuncall (6, args)); 2872 RETURN_UNGCPRO (Ffuncall (6, args));
2712} 2873}
2713 2874
2714/* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6 */ 2875/* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6. */
2715/* ARGSUSED */ 2876/* ARGSUSED */
2716Lisp_Object 2877Lisp_Object
2717call6 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, 2878call6 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3,
@@ -2731,7 +2892,7 @@ call6 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3,
2731 RETURN_UNGCPRO (Ffuncall (7, args)); 2892 RETURN_UNGCPRO (Ffuncall (7, args));
2732} 2893}
2733 2894
2734/* Call function fn with 7 arguments arg1, arg2, arg3, arg4, arg5, arg6, arg7 */ 2895/* Call function fn with 7 arguments arg1, arg2, arg3, arg4, arg5, arg6, arg7. */
2735/* ARGSUSED */ 2896/* ARGSUSED */
2736Lisp_Object 2897Lisp_Object
2737call7 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, 2898call7 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3,
@@ -2754,21 +2915,54 @@ call7 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3,
2754 2915
2755/* The caller should GCPRO all the elements of ARGS. */ 2916/* The caller should GCPRO all the elements of ARGS. */
2756 2917
2918DEFUN ("functionp", Ffunctionp, Sfunctionp, 1, 1, 0,
2919 doc: /* Non-nil if OBJECT is a function. */)
2920 (Lisp_Object object)
2921{
2922 if (SYMBOLP (object) && !NILP (Ffboundp (object)))
2923 {
2924 object = Findirect_function (object, Qt);
2925
2926 if (CONSP (object) && EQ (XCAR (object), Qautoload))
2927 {
2928 /* Autoloaded symbols are functions, except if they load
2929 macros or keymaps. */
2930 int i;
2931 for (i = 0; i < 4 && CONSP (object); i++)
2932 object = XCDR (object);
2933
2934 return (CONSP (object) && !NILP (XCAR (object))) ? Qnil : Qt;
2935 }
2936 }
2937
2938 if (SUBRP (object))
2939 return (XSUBR (object)->max_args != UNEVALLED) ? Qt : Qnil;
2940 else if (COMPILEDP (object))
2941 return Qt;
2942 else if (CONSP (object))
2943 {
2944 Lisp_Object car = XCAR (object);
2945 return (EQ (car, Qlambda) || EQ (car, Qclosure)) ? Qt : Qnil;
2946 }
2947 else
2948 return Qnil;
2949}
2950
2757DEFUN ("funcall", Ffuncall, Sfuncall, 1, MANY, 0, 2951DEFUN ("funcall", Ffuncall, Sfuncall, 1, MANY, 0,
2758 doc: /* Call first argument as a function, passing remaining arguments to it. 2952 doc: /* Call first argument as a function, passing remaining arguments to it.
2759Return the value that function returns. 2953Return the value that function returns.
2760Thus, (funcall 'cons 'x 'y) returns (x . y). 2954Thus, (funcall 'cons 'x 'y) returns (x . y).
2761usage: (funcall FUNCTION &rest ARGUMENTS) */) 2955usage: (funcall FUNCTION &rest ARGUMENTS) */)
2762 (int nargs, Lisp_Object *args) 2956 (ptrdiff_t nargs, Lisp_Object *args)
2763{ 2957{
2764 Lisp_Object fun, original_fun; 2958 Lisp_Object fun, original_fun;
2765 Lisp_Object funcar; 2959 Lisp_Object funcar;
2766 int numargs = nargs - 1; 2960 ptrdiff_t numargs = nargs - 1;
2767 Lisp_Object lisp_numargs; 2961 Lisp_Object lisp_numargs;
2768 Lisp_Object val; 2962 Lisp_Object val;
2769 struct backtrace backtrace; 2963 struct backtrace backtrace;
2770 register Lisp_Object *internal_args; 2964 register Lisp_Object *internal_args;
2771 register int i; 2965 ptrdiff_t i;
2772 2966
2773 QUIT; 2967 QUIT;
2774 if ((consing_since_gc > gc_cons_threshold 2968 if ((consing_since_gc > gc_cons_threshold
@@ -2898,7 +3092,8 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */)
2898 funcar = XCAR (fun); 3092 funcar = XCAR (fun);
2899 if (!SYMBOLP (funcar)) 3093 if (!SYMBOLP (funcar))
2900 xsignal1 (Qinvalid_function, original_fun); 3094 xsignal1 (Qinvalid_function, original_fun);
2901 if (EQ (funcar, Qlambda)) 3095 if (EQ (funcar, Qlambda)
3096 || EQ (funcar, Qclosure))
2902 val = funcall_lambda (fun, numargs, args + 1); 3097 val = funcall_lambda (fun, numargs, args + 1);
2903 else if (EQ (funcar, Qautoload)) 3098 else if (EQ (funcar, Qautoload))
2904 { 3099 {
@@ -2918,40 +3113,36 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */)
2918} 3113}
2919 3114
2920static Lisp_Object 3115static Lisp_Object
2921apply_lambda (Lisp_Object fun, Lisp_Object args, int eval_flag) 3116apply_lambda (Lisp_Object fun, Lisp_Object args)
2922{ 3117{
2923 Lisp_Object args_left; 3118 Lisp_Object args_left;
2924 Lisp_Object numargs; 3119 ptrdiff_t i, numargs;
2925 register Lisp_Object *arg_vector; 3120 register Lisp_Object *arg_vector;
2926 struct gcpro gcpro1, gcpro2, gcpro3; 3121 struct gcpro gcpro1, gcpro2, gcpro3;
2927 register int i;
2928 register Lisp_Object tem; 3122 register Lisp_Object tem;
2929 USE_SAFE_ALLOCA; 3123 USE_SAFE_ALLOCA;
2930 3124
2931 numargs = Flength (args); 3125 numargs = XFASTINT (Flength (args));
2932 SAFE_ALLOCA_LISP (arg_vector, XINT (numargs)); 3126 SAFE_ALLOCA_LISP (arg_vector, numargs);
2933 args_left = args; 3127 args_left = args;
2934 3128
2935 GCPRO3 (*arg_vector, args_left, fun); 3129 GCPRO3 (*arg_vector, args_left, fun);
2936 gcpro1.nvars = 0; 3130 gcpro1.nvars = 0;
2937 3131
2938 for (i = 0; i < XINT (numargs);) 3132 for (i = 0; i < numargs; )
2939 { 3133 {
2940 tem = Fcar (args_left), args_left = Fcdr (args_left); 3134 tem = Fcar (args_left), args_left = Fcdr (args_left);
2941 if (eval_flag) tem = Feval (tem); 3135 tem = eval_sub (tem);
2942 arg_vector[i++] = tem; 3136 arg_vector[i++] = tem;
2943 gcpro1.nvars = i; 3137 gcpro1.nvars = i;
2944 } 3138 }
2945 3139
2946 UNGCPRO; 3140 UNGCPRO;
2947 3141
2948 if (eval_flag) 3142 backtrace_list->args = arg_vector;
2949 { 3143 backtrace_list->nargs = i;
2950 backtrace_list->args = arg_vector;
2951 backtrace_list->nargs = i;
2952 }
2953 backtrace_list->evalargs = 0; 3144 backtrace_list->evalargs = 0;
2954 tem = funcall_lambda (fun, XINT (numargs), arg_vector); 3145 tem = funcall_lambda (fun, numargs, arg_vector);
2955 3146
2956 /* Do the debug-on-exit now, while arg_vector still exists. */ 3147 /* Do the debug-on-exit now, while arg_vector still exists. */
2957 if (backtrace_list->debug_on_exit) 3148 if (backtrace_list->debug_on_exit)
@@ -2967,14 +3158,24 @@ apply_lambda (Lisp_Object fun, Lisp_Object args, int eval_flag)
2967 FUN must be either a lambda-expression or a compiled-code object. */ 3158 FUN must be either a lambda-expression or a compiled-code object. */
2968 3159
2969static Lisp_Object 3160static Lisp_Object
2970funcall_lambda (Lisp_Object fun, int nargs, register Lisp_Object *arg_vector) 3161funcall_lambda (Lisp_Object fun, ptrdiff_t nargs,
3162 register Lisp_Object *arg_vector)
2971{ 3163{
2972 Lisp_Object val, syms_left, next; 3164 Lisp_Object val, syms_left, next, lexenv;
2973 int count = SPECPDL_INDEX (); 3165 int count = SPECPDL_INDEX ();
2974 int i, optional, rest; 3166 ptrdiff_t i;
3167 int optional, rest;
2975 3168
2976 if (CONSP (fun)) 3169 if (CONSP (fun))
2977 { 3170 {
3171 if (EQ (XCAR (fun), Qclosure))
3172 {
3173 fun = XCDR (fun); /* Drop `closure'. */
3174 lexenv = XCAR (fun);
3175 CHECK_LIST_CONS (fun, fun);
3176 }
3177 else
3178 lexenv = Qnil;
2978 syms_left = XCDR (fun); 3179 syms_left = XCDR (fun);
2979 if (CONSP (syms_left)) 3180 if (CONSP (syms_left))
2980 syms_left = XCAR (syms_left); 3181 syms_left = XCAR (syms_left);
@@ -2982,7 +3183,30 @@ funcall_lambda (Lisp_Object fun, int nargs, register Lisp_Object *arg_vector)
2982 xsignal1 (Qinvalid_function, fun); 3183 xsignal1 (Qinvalid_function, fun);
2983 } 3184 }
2984 else if (COMPILEDP (fun)) 3185 else if (COMPILEDP (fun))
2985 syms_left = AREF (fun, COMPILED_ARGLIST); 3186 {
3187 syms_left = AREF (fun, COMPILED_ARGLIST);
3188 if (INTEGERP (syms_left))
3189 /* A byte-code object with a non-nil `push args' slot means we
3190 shouldn't bind any arguments, instead just call the byte-code
3191 interpreter directly; it will push arguments as necessary.
3192
3193 Byte-code objects with either a non-existant, or a nil value for
3194 the `push args' slot (the default), have dynamically-bound
3195 arguments, and use the argument-binding code below instead (as do
3196 all interpreted functions, even lexically bound ones). */
3197 {
3198 /* If we have not actually read the bytecode string
3199 and constants vector yet, fetch them from the file. */
3200 if (CONSP (AREF (fun, COMPILED_BYTECODE)))
3201 Ffetch_bytecode (fun);
3202 return exec_byte_code (AREF (fun, COMPILED_BYTECODE),
3203 AREF (fun, COMPILED_CONSTANTS),
3204 AREF (fun, COMPILED_STACK_DEPTH),
3205 syms_left,
3206 nargs, arg_vector);
3207 }
3208 lexenv = Qnil;
3209 }
2986 else 3210 else
2987 abort (); 3211 abort ();
2988 3212
@@ -2999,17 +3223,29 @@ funcall_lambda (Lisp_Object fun, int nargs, register Lisp_Object *arg_vector)
2999 rest = 1; 3223 rest = 1;
3000 else if (EQ (next, Qand_optional)) 3224 else if (EQ (next, Qand_optional))
3001 optional = 1; 3225 optional = 1;
3002 else if (rest) 3226 else
3003 { 3227 {
3004 specbind (next, Flist (nargs - i, &arg_vector[i])); 3228 Lisp_Object arg;
3005 i = nargs; 3229 if (rest)
3230 {
3231 arg = Flist (nargs - i, &arg_vector[i]);
3232 i = nargs;
3233 }
3234 else if (i < nargs)
3235 arg = arg_vector[i++];
3236 else if (!optional)
3237 xsignal2 (Qwrong_number_of_arguments, fun, make_number (nargs));
3238 else
3239 arg = Qnil;
3240
3241 /* Bind the argument. */
3242 if (!NILP (lexenv) && SYMBOLP (next))
3243 /* Lexically bind NEXT by adding it to the lexenv alist. */
3244 lexenv = Fcons (Fcons (next, arg), lexenv);
3245 else
3246 /* Dynamically bind NEXT. */
3247 specbind (next, arg);
3006 } 3248 }
3007 else if (i < nargs)
3008 specbind (next, arg_vector[i++]);
3009 else if (!optional)
3010 xsignal2 (Qwrong_number_of_arguments, fun, make_number (nargs));
3011 else
3012 specbind (next, Qnil);
3013 } 3249 }
3014 3250
3015 if (!NILP (syms_left)) 3251 if (!NILP (syms_left))
@@ -3017,6 +3253,10 @@ funcall_lambda (Lisp_Object fun, int nargs, register Lisp_Object *arg_vector)
3017 else if (i < nargs) 3253 else if (i < nargs)
3018 xsignal2 (Qwrong_number_of_arguments, fun, make_number (nargs)); 3254 xsignal2 (Qwrong_number_of_arguments, fun, make_number (nargs));
3019 3255
3256 if (!EQ (lexenv, Vinternal_interpreter_environment))
3257 /* Instantiate a new lexical environment. */
3258 specbind (Qinternal_interpreter_environment, lexenv);
3259
3020 if (CONSP (fun)) 3260 if (CONSP (fun))
3021 val = Fprogn (XCDR (XCDR (fun))); 3261 val = Fprogn (XCDR (XCDR (fun)));
3022 else 3262 else
@@ -3025,9 +3265,10 @@ funcall_lambda (Lisp_Object fun, int nargs, register Lisp_Object *arg_vector)
3025 and constants vector yet, fetch them from the file. */ 3265 and constants vector yet, fetch them from the file. */
3026 if (CONSP (AREF (fun, COMPILED_BYTECODE))) 3266 if (CONSP (AREF (fun, COMPILED_BYTECODE)))
3027 Ffetch_bytecode (fun); 3267 Ffetch_bytecode (fun);
3028 val = Fbyte_code (AREF (fun, COMPILED_BYTECODE), 3268 val = exec_byte_code (AREF (fun, COMPILED_BYTECODE),
3029 AREF (fun, COMPILED_CONSTANTS), 3269 AREF (fun, COMPILED_CONSTANTS),
3030 AREF (fun, COMPILED_STACK_DEPTH)); 3270 AREF (fun, COMPILED_STACK_DEPTH),
3271 Qnil, 0, 0);
3031 } 3272 }
3032 3273
3033 return unbind_to (count, val); 3274 return unbind_to (count, val);
@@ -3057,7 +3298,7 @@ DEFUN ("fetch-bytecode", Ffetch_bytecode, Sfetch_bytecode,
3057 return object; 3298 return object;
3058} 3299}
3059 3300
3060void 3301static void
3061grow_specpdl (void) 3302grow_specpdl (void)
3062{ 3303{
3063 register int count = SPECPDL_INDEX (); 3304 register int count = SPECPDL_INDEX ();
@@ -3075,7 +3316,7 @@ grow_specpdl (void)
3075 specpdl_ptr = specpdl + count; 3316 specpdl_ptr = specpdl + count;
3076} 3317}
3077 3318
3078/* specpdl_ptr->symbol is a field which describes which variable is 3319/* `specpdl_ptr->symbol' is a field which describes which variable is
3079 let-bound, so it can be properly undone when we unbind_to. 3320 let-bound, so it can be properly undone when we unbind_to.
3080 It can have the following two shapes: 3321 It can have the following two shapes:
3081 - SYMBOL : if it's a plain symbol, it means that we have let-bound 3322 - SYMBOL : if it's a plain symbol, it means that we have let-bound
@@ -3263,6 +3504,17 @@ unbind_to (int count, Lisp_Object value)
3263 UNGCPRO; 3504 UNGCPRO;
3264 return value; 3505 return value;
3265} 3506}
3507
3508DEFUN ("special-variable-p", Fspecial_variable_p, Sspecial_variable_p, 1, 1, 0,
3509 doc: /* Return non-nil if SYMBOL's global binding has been declared special.
3510A special variable is one that will be bound dynamically, even in a
3511context where binding is lexical by default. */)
3512 (Lisp_Object symbol)
3513{
3514 CHECK_SYMBOL (symbol);
3515 return XSYMBOL (symbol)->declared_special ? Qt : Qnil;
3516}
3517
3266 3518
3267DEFUN ("backtrace-debug", Fbacktrace_debug, Sbacktrace_debug, 2, 2, 0, 3519DEFUN ("backtrace-debug", Fbacktrace_debug, Sbacktrace_debug, 2, 2, 0,
3268 doc: /* Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG. 3520 doc: /* Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.
@@ -3291,7 +3543,6 @@ Output stream used is value of `standard-output'. */)
3291 (void) 3543 (void)
3292{ 3544{
3293 register struct backtrace *backlist = backtrace_list; 3545 register struct backtrace *backlist = backtrace_list;
3294 register int i;
3295 Lisp_Object tail; 3546 Lisp_Object tail;
3296 Lisp_Object tem; 3547 Lisp_Object tem;
3297 struct gcpro gcpro1; 3548 struct gcpro gcpro1;
@@ -3314,13 +3565,14 @@ Output stream used is value of `standard-output'. */)
3314 else 3565 else
3315 { 3566 {
3316 tem = *backlist->function; 3567 tem = *backlist->function;
3317 Fprin1 (tem, Qnil); /* This can QUIT */ 3568 Fprin1 (tem, Qnil); /* This can QUIT. */
3318 write_string ("(", -1); 3569 write_string ("(", -1);
3319 if (backlist->nargs == MANY) 3570 if (backlist->nargs == MANY)
3320 { 3571 { /* FIXME: Can this happen? */
3572 int i;
3321 for (tail = *backlist->args, i = 0; 3573 for (tail = *backlist->args, i = 0;
3322 !NILP (tail); 3574 !NILP (tail);
3323 tail = Fcdr (tail), i++) 3575 tail = Fcdr (tail), i = 1)
3324 { 3576 {
3325 if (i) write_string (" ", -1); 3577 if (i) write_string (" ", -1);
3326 Fprin1 (Fcar (tail), Qnil); 3578 Fprin1 (Fcar (tail), Qnil);
@@ -3328,6 +3580,7 @@ Output stream used is value of `standard-output'. */)
3328 } 3580 }
3329 else 3581 else
3330 { 3582 {
3583 ptrdiff_t i;
3331 for (i = 0; i < backlist->nargs; i++) 3584 for (i = 0; i < backlist->nargs; i++)
3332 { 3585 {
3333 if (i) write_string (" ", -1); 3586 if (i) write_string (" ", -1);
@@ -3357,7 +3610,7 @@ If NFRAMES is more than the number of frames, the value is nil. */)
3357 (Lisp_Object nframes) 3610 (Lisp_Object nframes)
3358{ 3611{
3359 register struct backtrace *backlist = backtrace_list; 3612 register struct backtrace *backlist = backtrace_list;
3360 register int i; 3613 register EMACS_INT i;
3361 Lisp_Object tem; 3614 Lisp_Object tem;
3362 3615
3363 CHECK_NATNUM (nframes); 3616 CHECK_NATNUM (nframes);
@@ -3372,7 +3625,7 @@ If NFRAMES is more than the number of frames, the value is nil. */)
3372 return Fcons (Qnil, Fcons (*backlist->function, *backlist->args)); 3625 return Fcons (Qnil, Fcons (*backlist->function, *backlist->args));
3373 else 3626 else
3374 { 3627 {
3375 if (backlist->nargs == MANY) 3628 if (backlist->nargs == MANY) /* FIXME: Can this happen? */
3376 tem = *backlist->args; 3629 tem = *backlist->args;
3377 else 3630 else
3378 tem = Flist (backlist->nargs, backlist->args); 3631 tem = Flist (backlist->nargs, backlist->args);
@@ -3382,24 +3635,27 @@ If NFRAMES is more than the number of frames, the value is nil. */)
3382} 3635}
3383 3636
3384 3637
3638#if BYTE_MARK_STACK
3385void 3639void
3386mark_backtrace (void) 3640mark_backtrace (void)
3387{ 3641{
3388 register struct backtrace *backlist; 3642 register struct backtrace *backlist;
3389 register int i; 3643 ptrdiff_t i;
3390 3644
3391 for (backlist = backtrace_list; backlist; backlist = backlist->next) 3645 for (backlist = backtrace_list; backlist; backlist = backlist->next)
3392 { 3646 {
3393 mark_object (*backlist->function); 3647 mark_object (*backlist->function);
3394 3648
3395 if (backlist->nargs == UNEVALLED || backlist->nargs == MANY) 3649 if (backlist->nargs == UNEVALLED
3396 i = 0; 3650 || backlist->nargs == MANY) /* FIXME: Can this happen? */
3651 i = 1;
3397 else 3652 else
3398 i = backlist->nargs - 1; 3653 i = backlist->nargs;
3399 for (; i >= 0; i--) 3654 while (i--)
3400 mark_object (backlist->args[i]); 3655 mark_object (backlist->args[i]);
3401 } 3656 }
3402} 3657}
3658#endif
3403 3659
3404void 3660void
3405syms_of_eval (void) 3661syms_of_eval (void)
@@ -3473,6 +3729,9 @@ before making `inhibit-quit' nil. */);
3473 Qand_optional = intern_c_string ("&optional"); 3729 Qand_optional = intern_c_string ("&optional");
3474 staticpro (&Qand_optional); 3730 staticpro (&Qand_optional);
3475 3731
3732 Qclosure = intern_c_string ("closure");
3733 staticpro (&Qclosure);
3734
3476 Qdebug = intern_c_string ("debug"); 3735 Qdebug = intern_c_string ("debug");
3477 staticpro (&Qdebug); 3736 staticpro (&Qdebug);
3478 3737
@@ -3540,6 +3799,28 @@ DECL is a list `(declare ...)' containing the declarations.
3540The value the function returns is not used. */); 3799The value the function returns is not used. */);
3541 Vmacro_declaration_function = Qnil; 3800 Vmacro_declaration_function = Qnil;
3542 3801
3802 /* When lexical binding is being used,
3803 vinternal_interpreter_environment is non-nil, and contains an alist
3804 of lexically-bound variable, or (t), indicating an empty
3805 environment. The lisp name of this variable would be
3806 `internal-interpreter-environment' if it weren't hidden.
3807 Every element of this list can be either a cons (VAR . VAL)
3808 specifying a lexical binding, or a single symbol VAR indicating
3809 that this variable should use dynamic scoping. */
3810 Qinternal_interpreter_environment
3811 = intern_c_string ("internal-interpreter-environment");
3812 staticpro (&Qinternal_interpreter_environment);
3813 DEFVAR_LISP ("internal-interpreter-environment",
3814 Vinternal_interpreter_environment,
3815 doc: /* If non-nil, the current lexical environment of the lisp interpreter.
3816When lexical binding is not being used, this variable is nil.
3817A value of `(t)' indicates an empty environment, otherwise it is an
3818alist of active lexical bindings. */);
3819 Vinternal_interpreter_environment = Qnil;
3820 /* Don't export this variable to Elisp, so noone can mess with it
3821 (Just imagine if someone makes it buffer-local). */
3822 Funintern (Qinternal_interpreter_environment, Qnil);
3823
3543 Vrun_hooks = intern_c_string ("run-hooks"); 3824 Vrun_hooks = intern_c_string ("run-hooks");
3544 staticpro (&Vrun_hooks); 3825 staticpro (&Vrun_hooks);
3545 3826
@@ -3584,9 +3865,11 @@ The value the function returns is not used. */);
3584 defsubr (&Srun_hook_with_args); 3865 defsubr (&Srun_hook_with_args);
3585 defsubr (&Srun_hook_with_args_until_success); 3866 defsubr (&Srun_hook_with_args_until_success);
3586 defsubr (&Srun_hook_with_args_until_failure); 3867 defsubr (&Srun_hook_with_args_until_failure);
3868 defsubr (&Srun_hook_wrapped);
3587 defsubr (&Sfetch_bytecode); 3869 defsubr (&Sfetch_bytecode);
3588 defsubr (&Sbacktrace_debug); 3870 defsubr (&Sbacktrace_debug);
3589 defsubr (&Sbacktrace); 3871 defsubr (&Sbacktrace);
3590 defsubr (&Sbacktrace_frame); 3872 defsubr (&Sbacktrace_frame);
3873 defsubr (&Sspecial_variable_p);
3874 defsubr (&Sfunctionp);
3591} 3875}
3592
generated by cgit v1.2.1 (git 2.18.0) at 2026-03-01 09:31:23 +0000