diff options
author | Paul Eggert <eggert@cs.ucla.edu> | 2011-04-01 13:19:36 -0700 |
---|---|---|
committer | Paul Eggert <eggert@cs.ucla.edu> | 2011-04-01 13:19:36 -0700 |
commit | 6ddae4efd9e8a3035eb610c39fb2c8f79e7f9893 (patch) | |
tree | 1b704b34e4f2f2bd4a6f13e4d1dd058c61c8a6ff /src | |
parent | 0b918413f336dbfa9a9c266ae857bce103556c57 (diff) | |
parent | 034086489cff2a23cb4d9f8c536e18456be617ef (diff) |
Merge from mainline.
Diffstat (limited to 'src')
-rw-r--r-- | src/ChangeLog | 58 | ||||
-rw-r--r-- | src/alloc.c | 14 | ||||
-rw-r--r-- | src/buffer.c | 1 | ||||
-rw-r--r-- | src/bytecode.c | 163 | ||||
-rw-r--r-- | src/callint.c | 13 | ||||
-rw-r--r-- | src/data.c | 8 | ||||
-rw-r--r-- | src/doc.c | 7 | ||||
-rw-r--r-- | src/eval.c | 382 | ||||
-rw-r--r-- | src/fns.c | 4 | ||||
-rw-r--r-- | src/image.c | 4 | ||||
-rw-r--r-- | src/keyboard.c | 12 | ||||
-rw-r--r-- | src/lisp.h | 12 | ||||
-rw-r--r-- | src/lread.c | 162 | ||||
-rw-r--r-- | src/minibuf.c | 3 | ||||
-rw-r--r-- | src/print.c | 57 | ||||
-rw-r--r-- | src/window.c | 34 | ||||
-rw-r--r-- | src/window.h | 1 |
17 files changed, 729 insertions, 206 deletions
diff --git a/src/ChangeLog b/src/ChangeLog index 99447fd874..56400fbb08 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -35,6 +35,64 @@ * deps.mk (sysdep.o): Depend on ../lib/allocator.h and on ../lib/careadlinkat.h. +2011-04-01 Stefan Monnier <monnier@iro.umontreal.ca> + + Add lexical binding. + + * window.c (Ftemp_output_buffer_show): New fun. + (Fsave_window_excursion): + * print.c (Fwith_output_to_temp_buffer): Move to subr.el. + + * lread.c (lisp_file_lexically_bound_p): New function. + (Fload): Bind Qlexical_binding. + (readevalloop): Remove `evalfun' arg. + Bind Qinternal_interpreter_environment. + (Feval_buffer): Bind Qlexical_binding. + (defvar_int, defvar_bool, defvar_lisp_nopro, defvar_kboard): + Mark as dynamic. + (syms_of_lread): Declare `lexical-binding'. + + * lisp.h (struct Lisp_Symbol): New field `declared_special'. + + * keyboard.c (eval_dyn): New fun. + (menu_item_eval_property): Use it. + + * image.c (parse_image_spec): Use Ffunctionp. + + * fns.c (concat, mapcar1): Accept byte-code-functions. + + * eval.c (Fsetq): Handle lexical vars. + (Fdefun, Fdefmacro, Ffunction): Make closures when needed. + (Fdefconst, Fdefvaralias, Fdefvar): Mark as dynamic. + (FletX, Flet): Obey lexical binding. + (Fcommandp): Handle closures. + (Feval): New `lexical' arg. + (eval_sub): New function extracted from Feval. Use it almost + everywhere where Feval was used. Look up vars in lexical env. + Handle closures. + (Ffunctionp): Move from subr.el. + (Ffuncall): Handle closures. + (apply_lambda): Remove `eval_flags'. + (funcall_lambda): Handle closures and new byte-code-functions. + (Fspecial_variable_p): New function. + (syms_of_eval): Initialize the Vinternal_interpreter_environment var, + but without exporting it to Lisp. + + * doc.c (Fdocumentation, store_function_docstring): + * data.c (Finteractive_form): Handle closures. + + * callint.c (Fcall_interactively): Preserve lexical-binding mode for + interactive spec. + + * bytecode.c (Bstack_ref, Bstack_set, Bstack_set2, BdiscardN): New + byte-codes. + (exec_byte_code): New function extracted from Fbyte_code to handle new + calling convention for byte-code-functions. Add new byte-codes. + + * buffer.c (defvar_per_buffer): Set new `declared_special' field. + + * alloc.c (Fmake_symbol): Init new `declared_special' field. + 2011-03-31 Juanma Barranquero <lekktu@gmail.com> * xdisp.c (redisplay_internal): Fix prototype. diff --git a/src/alloc.c b/src/alloc.c index 177a2266fb..07f1caae46 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -2940,10 +2940,19 @@ usage: (vector &rest OBJECTS) */) DEFUN ("make-byte-code", Fmake_byte_code, Smake_byte_code, 4, MANY, 0, doc: /* Create a byte-code object with specified arguments as elements. -The arguments should be the arglist, bytecode-string, constant vector, -stack size, (optional) doc string, and (optional) interactive spec. +The arguments should be the ARGLIST, bytecode-string BYTE-CODE, constant +vector CONSTANTS, maximum stack size DEPTH, (optional) DOCSTRING, +and (optional) INTERACTIVE-SPEC. The first four arguments are required; at most six have any significance. +The ARGLIST can be either like the one of `lambda', in which case the arguments +will be dynamically bound before executing the byte code, or it can be an +integer of the form NNNNNNNRMMMMMMM where the 7bit MMMMMMM specifies the +minimum number of arguments, the 7-bit NNNNNNN specifies the maximum number +of arguments (ignoring &rest) and the R bit specifies whether there is a &rest +argument to catch the left-over arguments. If such an integer is used, the +arguments will not be dynamically bound but will be instead pushed on the +stack before executing the byte-code. usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */) (register size_t nargs, Lisp_Object *args) { @@ -3071,6 +3080,7 @@ Its value and function definition are void, and its property list is nil. */) p->gcmarkbit = 0; p->interned = SYMBOL_UNINTERNED; p->constant = 0; + p->declared_special = 0; consing_since_gc += sizeof (struct Lisp_Symbol); symbols_consed++; return val; diff --git a/src/buffer.c b/src/buffer.c index 8b56b285e4..cdcd2ccecf 100644 --- a/src/buffer.c +++ b/src/buffer.c @@ -5240,6 +5240,7 @@ defvar_per_buffer (struct Lisp_Buffer_Objfwd *bo_fwd, const char *namestring, bo_fwd->type = Lisp_Fwd_Buffer_Obj; bo_fwd->offset = offset; bo_fwd->slottype = type; + sym->declared_special = 1; sym->redirect = SYMBOL_FORWARDED; { /* I tried to do the job without a cast, but it seems impossible. diff --git a/src/bytecode.c b/src/bytecode.c index 5a62c913a4..5879d312b0 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -80,9 +80,11 @@ Lisp_Object Qbyte_code_meter; Lisp_Object Qbytecode; +extern Lisp_Object Qand_optional, Qand_rest; /* Byte codes: */ +#define Bstack_ref 0 /* Actually, Bstack_ref+0 is not implemented: use dup. */ #define Bvarref 010 #define Bvarset 020 #define Bvarbind 030 @@ -132,7 +134,7 @@ Lisp_Object Qbytecode; #define Bpoint 0140 /* Was Bmark in v17. */ -#define Bsave_current_buffer 0141 +#define Bsave_current_buffer 0141 /* Obsolete. */ #define Bgoto_char 0142 #define Binsert 0143 #define Bpoint_max 0144 @@ -158,7 +160,7 @@ Lisp_Object Qbytecode; #ifdef BYTE_CODE_SAFE #define Bset_mark 0163 /* this loser is no longer generated as of v18 */ #endif -#define Binteractive_p 0164 /* Needed since interactive-p takes unevalled args */ +#define Binteractive_p 0164 /* Obsolete since Emacs-24.1. */ #define Bforward_char 0165 #define Bforward_word 0166 @@ -183,16 +185,16 @@ Lisp_Object Qbytecode; #define Bdup 0211 #define Bsave_excursion 0212 -#define Bsave_window_excursion 0213 +#define Bsave_window_excursion 0213 /* Obsolete since Emacs-24.1. */ #define Bsave_restriction 0214 #define Bcatch 0215 #define Bunwind_protect 0216 #define Bcondition_case 0217 -#define Btemp_output_buffer_setup 0220 -#define Btemp_output_buffer_show 0221 +#define Btemp_output_buffer_setup 0220 /* Obsolete since Emacs-24.1. */ +#define Btemp_output_buffer_show 0221 /* Obsolete since Emacs-24.1. */ -#define Bunbind_all 0222 +#define Bunbind_all 0222 /* Obsolete. Never used. */ #define Bset_marker 0223 #define Bmatch_beginning 0224 @@ -228,6 +230,11 @@ Lisp_Object Qbytecode; #define BconcatN 0260 #define BinsertN 0261 +/* Bstack_ref is code 0. */ +#define Bstack_set 0262 +#define Bstack_set2 0263 +#define BdiscardN 0266 + #define Bconstant 0300 /* Whether to maintain a `top' and `bottom' field in the stack frame. */ @@ -414,6 +421,21 @@ the third, MAXDEPTH, the maximum stack depth used in this function. If the third argument is incorrect, Emacs may crash. */) (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth) { + return exec_byte_code (bytestr, vector, maxdepth, Qnil, 0, NULL); +} + +/* Execute the byte-code in BYTESTR. VECTOR is the constant vector, and + MAXDEPTH is the maximum stack depth used (if MAXDEPTH is incorrect, + emacs may crash!). If ARGS_TEMPLATE is non-nil, it should be a lisp + argument list (including &rest, &optional, etc.), and ARGS, of size + NARGS, should be a vector of the actual arguments. The arguments in + ARGS are pushed on the stack according to ARGS_TEMPLATE before + executing BYTESTR. */ + +Lisp_Object +exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, + Lisp_Object args_template, int nargs, Lisp_Object *args) +{ int count = SPECPDL_INDEX (); #ifdef BYTE_CODE_METER int this_op = 0; @@ -475,6 +497,52 @@ If the third argument is incorrect, Emacs may crash. */) stacke = stack.bottom - 1 + XFASTINT (maxdepth); #endif + if (INTEGERP (args_template)) + { + int at = XINT (args_template); + int rest = at & 128; + int mandatory = at & 127; + int nonrest = at >> 8; + eassert (mandatory <= nonrest); + if (nargs <= nonrest) + { + int i; + for (i = 0 ; i < nargs; i++, args++) + PUSH (*args); + if (nargs < mandatory) + /* Too few arguments. */ + Fsignal (Qwrong_number_of_arguments, + Fcons (Fcons (make_number (mandatory), + rest ? Qand_rest : make_number (nonrest)), + Fcons (make_number (nargs), Qnil))); + else + { + for (; i < nonrest; i++) + PUSH (Qnil); + if (rest) + PUSH (Qnil); + } + } + else if (rest) + { + int i; + for (i = 0 ; i < nonrest; i++, args++) + PUSH (*args); + PUSH (Flist (nargs - nonrest, args)); + } + else + /* Too many arguments. */ + Fsignal (Qwrong_number_of_arguments, + Fcons (Fcons (make_number (mandatory), + make_number (nonrest)), + Fcons (make_number (nargs), Qnil))); + } + else if (! NILP (args_template)) + /* We should push some arguments on the stack. */ + { + error ("Unknown args template!"); + } + while (1) { #ifdef BYTE_CODE_SAFE @@ -735,7 +803,7 @@ If the third argument is incorrect, Emacs may crash. */) AFTER_POTENTIAL_GC (); break; - case Bunbind_all: + case Bunbind_all: /* Obsolete. Never used. */ /* To unbind back to the beginning of this frame. Not used yet, but will be needed for tail-recursion elimination. */ BEFORE_POTENTIAL_GC (); @@ -863,37 +931,43 @@ If the third argument is incorrect, Emacs may crash. */) save_excursion_save ()); break; - case Bsave_current_buffer: + case Bsave_current_buffer: /* Obsolete since ??. */ case Bsave_current_buffer_1: record_unwind_protect (set_buffer_if_live, Fcurrent_buffer ()); break; - case Bsave_window_excursion: - BEFORE_POTENTIAL_GC (); - TOP = Fsave_window_excursion (TOP); - AFTER_POTENTIAL_GC (); - break; + case Bsave_window_excursion: /* Obsolete since 24.1. */ + { + register int count = SPECPDL_INDEX (); + record_unwind_protect (Fset_window_configuration, + Fcurrent_window_configuration (Qnil)); + BEFORE_POTENTIAL_GC (); + TOP = Fprogn (TOP); + unbind_to (count, TOP); + AFTER_POTENTIAL_GC (); + break; + } case Bsave_restriction: record_unwind_protect (save_restriction_restore, save_restriction_save ()); break; - case Bcatch: + case Bcatch: /* FIXME: ill-suited for lexbind */ { Lisp_Object v1; BEFORE_POTENTIAL_GC (); v1 = POP; - TOP = internal_catch (TOP, Feval, v1); + TOP = internal_catch (TOP, eval_sub, v1); AFTER_POTENTIAL_GC (); break; } - case Bunwind_protect: + case Bunwind_protect: /* FIXME: avoid closure for lexbind */ record_unwind_protect (Fprogn, POP); break; - case Bcondition_case: + case Bcondition_case: /* FIXME: ill-suited for lexbind */ { Lisp_Object handlers, body; handlers = POP; @@ -904,7 +978,7 @@ If the third argument is incorrect, Emacs may crash. */) break; } - case Btemp_output_buffer_setup: + case Btemp_output_buffer_setup: /* Obsolete since 24.1. */ BEFORE_POTENTIAL_GC (); CHECK_STRING (TOP); temp_output_buffer_setup (SSDATA (TOP)); @@ -912,7 +986,7 @@ If the third argument is incorrect, Emacs may crash. */) TOP = Vstandard_output; break; - case Btemp_output_buffer_show: + case Btemp_output_buffer_show: /* Obsolete since 24.1. */ { Lisp_Object v1; BEFORE_POTENTIAL_GC (); @@ -1384,7 +1458,7 @@ If the third argument is incorrect, Emacs may crash. */) AFTER_POTENTIAL_GC (); break; - case Binteractive_p: + case Binteractive_p: /* Obsolete since 24.1. */ PUSH (Finteractive_p ()); break; @@ -1674,8 +1748,57 @@ If the third argument is incorrect, Emacs may crash. */) #endif case 0: + /* Actually this is Bstack_ref with offset 0, but we use Bdup + for that instead. */ + /* case Bstack_ref: */ abort (); + /* Handy byte-codes for lexical binding. */ + case Bstack_ref+1: + case Bstack_ref+2: + case Bstack_ref+3: + case Bstack_ref+4: + case Bstack_ref+5: + { + Lisp_Object *ptr = top - (op - Bstack_ref); + PUSH (*ptr); + break; + } + case Bstack_ref+6: + { + Lisp_Object *ptr = top - (FETCH); + PUSH (*ptr); + break; + } + case Bstack_ref+7: + { + Lisp_Object *ptr = top - (FETCH2); + PUSH (*ptr); + break; + } + /* stack-set-0 = discard; stack-set-1 = discard-1-preserve-tos. */ + case Bstack_set: + { + Lisp_Object *ptr = top - (FETCH); + *ptr = POP; + break; + } + case Bstack_set2: + { + Lisp_Object *ptr = top - (FETCH2); + *ptr = POP; + break; + } + case BdiscardN: + op = FETCH; + if (op & 0x80) + { + op &= 0x7F; + top[-op] = TOP; + } + DISCARD (op); + break; + case 255: default: #ifdef BYTE_CODE_SAFE diff --git a/src/callint.c b/src/callint.c index 40d89acd16..60570369d9 100644 --- a/src/callint.c +++ b/src/callint.c @@ -121,8 +121,9 @@ usage: (interactive &optional ARGS) */) static Lisp_Object quotify_arg (register Lisp_Object exp) { - if (!INTEGERP (exp) && !STRINGP (exp) - && !NILP (exp) && !EQ (exp, Qt)) + if (CONSP (exp) + || (SYMBOLP (exp) + && !NILP (exp) && !EQ (exp, Qt))) return Fcons (Qquote, Fcons (exp, Qnil)); return exp; @@ -169,6 +170,9 @@ check_mark (int for_region) static void fix_command (Lisp_Object input, Lisp_Object values) { + /* FIXME: Instead of this ugly hack, we should provide a way for an + interactive spec to return an expression/function that will re-build the + args without user intervention. */ if (CONSP (input)) { Lisp_Object car; @@ -332,11 +336,14 @@ invoke it. If KEYS is omitted or nil, the return value of else { Lisp_Object input; + Lisp_Object funval = Findirect_function (function, Qt); i = num_input_events; input = specs; /* Compute the arg values using the user's expression. */ GCPRO2 (input, filter_specs); - specs = Feval (specs); + specs = Feval (specs, + CONSP (funval) && EQ (Qclosure, XCAR (funval)) + ? Qt : Qnil); UNGCPRO; if (i != num_input_events || !NILP (record_flag)) { diff --git a/src/data.c b/src/data.c index ba7ae58d7b..4b9d2ec038 100644 --- a/src/data.c +++ b/src/data.c @@ -745,7 +745,9 @@ Value, if non-nil, is a list \(interactive SPEC). */) else if (CONSP (fun)) { Lisp_Object funcar = XCAR (fun); - if (EQ (funcar, Qlambda)) + if (EQ (funcar, Qclosure)) + return Fassq (Qinteractive, Fcdr (Fcdr (XCDR (fun)))); + else if (EQ (funcar, Qlambda)) return Fassq (Qinteractive, Fcdr (XCDR (fun))); else if (EQ (funcar, Qautoload)) { @@ -1431,7 +1433,7 @@ usage: (setq-default [VAR VALUE]...) */) do { - val = Feval (Fcar (Fcdr (args_left))); + val = eval_sub (Fcar (Fcdr (args_left))); symbol = XCAR (args_left); Fset_default (symbol, val); args_left = Fcdr (XCDR (args_left)); @@ -2101,7 +2103,7 @@ or a byte-code object. IDX starts at 0. */) if (idxval < 0 || idxval >= size) args_out_of_range (array, idx); - return XVECTOR (array)->contents[idxval]; + return AREF (array, idxval); } } @@ -36,6 +36,7 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ Lisp_Object Qfunction_documentation; +extern Lisp_Object Qclosure; /* Buffer used for reading from documentation file. */ static char *get_doc_string_buffer; static int get_doc_string_buffer_size; @@ -374,6 +375,7 @@ string is passed through `substitute-command-keys'. */) else if (EQ (funcar, Qkeymap)) return build_string ("Prefix command (definition is a keymap associating keystrokes with commands)."); else if (EQ (funcar, Qlambda) + || (EQ (funcar, Qclosure) && (fun = XCDR (fun), 1)) || EQ (funcar, Qautoload)) { Lisp_Object tem1 = Fcdr (Fcdr (fun)); @@ -480,7 +482,7 @@ aren't strings. */) } else if (!STRINGP (tem)) /* Feval protects its argument. */ - tem = Feval (tem); + tem = Feval (tem, Qnil); if (NILP (raw) && STRINGP (tem)) tem = Fsubstitute_command_keys (tem); @@ -507,7 +509,8 @@ store_function_docstring (Lisp_Object fun, EMACS_INT offset) Lisp_Object tem; tem = XCAR (fun); - if (EQ (tem, Qlambda) || EQ (tem, Qautoload)) + if (EQ (tem, Qlambda) || EQ (tem, Qautoload) + || (EQ (tem, Qclosure) && (fun = XCDR (fun), 1))) { tem = Fcdr (Fcdr (fun)); if (CONSP (tem) && INTEGERP (XCAR (tem))) diff --git a/src/eval.c b/src/eval.c index 718e58c693..948c2e4d15 100644 --- a/src/eval.c +++ b/src/eval.c @@ -64,6 +64,8 @@ Lisp_Object Qinhibit_quit; Lisp_Object Qand_rest, Qand_optional; Lisp_Object Qdebug_on_error; Lisp_Object Qdeclare; +Lisp_Object Qinternal_interpreter_environment, Qclosure; + Lisp_Object Qdebug; /* This holds either the symbol `run-hooks' or nil. @@ -115,10 +117,10 @@ Lisp_Object Vsignaling_function; int handling_signal; -static Lisp_Object funcall_lambda (Lisp_Object, size_t, Lisp_Object*); +static Lisp_Object funcall_lambda (Lisp_Object, size_t, Lisp_Object *); static void unwind_to_catch (struct catchtag *, Lisp_Object) NO_RETURN; static int interactive_p (int); -static Lisp_Object apply_lambda (Lisp_Object, Lisp_Object, int); +static Lisp_Object apply_lambda (Lisp_Object fun, Lisp_Object args); void init_eval_once (void) @@ -127,7 +129,7 @@ init_eval_once (void) specpdl = (struct specbinding *) xmalloc (specpdl_size * sizeof (struct specbinding)); specpdl_ptr = specpdl; /* Don't forget to update docs (lispref node "Local Variables"). */ - max_specpdl_size = 1000; + max_specpdl_size = 1300; /* 1000 is not enough for CEDET's c-by.el. */ max_lisp_eval_depth = 600; Vrun_hooks = Qnil; @@ -244,7 +246,7 @@ usage: (or CONDITIONS...) */) while (CONSP (args)) { - val = Feval (XCAR (args)); + val = eval_sub (XCAR (args)); if (!NILP (val)) break; args = XCDR (args); @@ -268,7 +270,7 @@ usage: (and CONDITIONS...) */) while (CONSP (args)) { - val = Feval (XCAR (args)); + val = eval_sub (XCAR (args)); if (NILP (val)) break; args = XCDR (args); @@ -290,11 +292,11 @@ usage: (if COND THEN ELSE...) */) struct gcpro gcpro1; GCPRO1 (args); - cond = Feval (Fcar (args)); + cond = eval_sub (Fcar (args)); UNGCPRO; if (!NILP (cond)) - return Feval (Fcar (Fcdr (args))); + return eval_sub (Fcar (Fcdr (args))); return Fprogn (Fcdr (Fcdr (args))); } @@ -318,7 +320,7 @@ usage: (cond CLAUSES...) */) while (!NILP (args)) { clause = Fcar (args); - val = Feval (Fcar (clause)); + val = eval_sub (Fcar (clause)); if (!NILP (val)) { if (!EQ (XCDR (clause), Qnil)) @@ -344,7 +346,7 @@ usage: (progn BODY...) */) while (CONSP (args)) { - val = Feval (XCAR (args)); + val = eval_sub (XCAR (args)); args = XCDR (args); } @@ -373,13 +375,12 @@ usage: (prog1 FIRST BODY...) */) do { + Lisp_Object tem = eval_sub (XCAR (args_left)); if (!(argnum++)) - val = Feval (Fcar (args_left)); - else - Feval (Fcar (args_left)); - args_left = Fcdr (args_left); + val = tem; + args_left = XCDR (args_left); } - while (!NILP(args_left)); + while (CONSP (args_left)); UNGCPRO; return val; @@ -408,13 +409,12 @@ usage: (prog2 FORM1 FORM2 BODY...) */) do { + Lisp_Object tem = eval_sub (XCAR (args_left)); if (!(argnum++)) - val = Feval (Fcar (args_left)); - else - Feval (Fcar (args_left)); - args_left = Fcdr (args_left); + val = tem; + args_left = XCDR (args_left); } - while (!NILP (args_left)); + while (CONSP (args_left)); UNGCPRO; return val; @@ -432,7 +432,7 @@ usage: (setq [SYM VAL]...) */) (Lisp_Object args) { register Lisp_Object args_left; - register Lisp_Object val, sym; + register Lisp_Object val, sym, lex_binding; struct gcpro gcpro1; if (NILP (args)) @@ -443,9 +443,19 @@ usage: (setq [SYM VAL]...) */) do { - val = Feval (Fcar (Fcdr (args_left))); + val = eval_sub (Fcar (Fcdr (args_left))); sym = Fcar (args_left); - Fset (sym, val); + + /* Like for eval_sub, we do not check declared_special here since + it's been done when let-binding. */ + if (!NILP (Vinternal_interpreter_environment) /* Mere optimization! */ + && SYMBOLP (sym) + && !NILP (lex_binding + = Fassq (sym, Vinternal_interpreter_environment))) + XSETCDR (lex_binding, val); /* SYM is lexically bound. */ + else + Fset (sym, val); /* SYM is dynamically bound. */ + args_left = Fcdr (Fcdr (args_left)); } while (!NILP(args_left)); @@ -471,9 +481,21 @@ In byte compilation, `function' causes its argument to be compiled. usage: (function ARG) */) (Lisp_Object args) { + Lisp_Object quoted = XCAR (args); + if (!NILP (Fcdr (args))) xsignal2 (Qwrong_number_of_arguments, Qfunction, Flength (args)); - return Fcar (args); + + if (!NILP (Vinternal_interpreter_environment) + && CONSP (quoted) + && EQ (XCAR (quoted), Qlambda)) + /* This is a lambda expression within a lexical environment; + return an interpreted closure instead of a simple lambda. */ + return Fcons (Qclosure, Fcons (Vinternal_interpreter_environment, + XCDR (quoted))); + else + /* Simply quote the argument. */ + return quoted; } @@ -496,7 +518,7 @@ spec that specifies non-nil unconditionally (such as \"p\"); or (ii) use `called-interactively-p'. */) (void) { - return (INTERACTIVE && interactive_p (1)) ? Qt : Qnil; + return interactive_p (1) ? Qt : Qnil; } @@ -589,6 +611,8 @@ usage: (defun NAME ARGLIST [DOCSTRING] BODY...) */) fn_name = Fcar (args); CHECK_SYMBOL (fn_name); defn = Fcons (Qlambda, Fcdr (args)); + if (!NILP (Vinternal_interpreter_environment)) /* Mere optimization! */ + defn = Ffunction (Fcons (defn, Qnil)); if (!NILP (Vpurify_flag)) defn = Fpurecopy (defn); if (CONSP (XSYMBOL (fn_name)->function) @@ -660,7 +684,11 @@ usage: (defmacro NAME ARGLIST [DOCSTRING] [DECL] BODY...) */) tail = Fcons (lambda_list, tail); else tail = Fcons (lambda_list, Fcons (doc, tail)); - defn = Fcons (Qmacro, Fcons (Qlambda, tail)); + + defn = Fcons (Qlambda, tail); + if (!NILP (Vinternal_interpreter_environment)) /* Mere optimization! */ + defn = Ffunction (Fcons (defn, Qnil)); + defn = Fcons (Qmacro, defn); if (!NILP (Vpurify_flag)) defn = Fpurecopy (defn); @@ -720,6 +748,7 @@ The return value is BASE-VARIABLE. */) error ("Don't know how to make a let-bound variable an alias"); } + sym->declared_special = 1; sym->redirect = SYMBOL_VARALIAS; SET_SYMBOL_ALIAS (sym, XSYMBOL (base_variable)); sym->constant = SYMBOL_CONSTANT_P (base_variable); @@ -765,6 +794,9 @@ usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */) tem = Fdefault_boundp (sym); if (!NILP (tail)) { + /* Do it before evaluating the initial value, for self-references. */ + XSYMBOL (sym)->declared_special = 1; + if (SYMBOL_CONSTANT_P (sym)) { /* For upward compatibility, allow (defvar :foo (quote :foo)). */ @@ -778,7 +810,7 @@ usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */) } if (NILP (tem)) - Fset_default (sym, Feval (Fcar (tail))); + Fset_default (sym, eval_sub (Fcar (tail))); else { /* Check if there is really a global binding rather than just a let binding that shadows the global unboundness of the var. */ @@ -804,6 +836,13 @@ usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */) } LOADHIST_ATTACH (sym); } + else if (!NILP (Vinternal_interpreter_environment) + && !XSYMBOL (sym)->declared_special) + /* A simple (defvar foo) with lexical scoping does "nothing" except + declare that var to be dynamically scoped *locally* (i.e. within + the current file or let-block). */ + Vinternal_interpreter_environment = + Fcons (sym, Vinternal_interpreter_environment); else { /* Simple (defvar <var>) should not count as a definition at all. @@ -834,10 +873,11 @@ usage: (defconst SYMBOL INITVALUE [DOCSTRING]) */) if (!NILP (Fcdr (Fcdr (Fcdr (args))))) error ("Too many arguments"); - tem = Feval (Fcar (Fcdr (args))); + tem = eval_sub (Fcar (Fcdr (args))); if (!NILP (Vpurify_flag)) tem = Fpurecopy (tem); Fset_default (sym, tem); + XSYMBOL (sym)->declared_special = 1; tem = Fcar (Fcdr (Fcdr (args))); if (!NILP (tem)) { @@ -924,27 +964,53 @@ Each VALUEFORM can refer to the symbols already bound by this VARLIST. usage: (let* VARLIST BODY...) */) (Lisp_Object args) { - Lisp_Object varlist, val, elt; + Lisp_Object varlist, var, val, elt, lexenv; int count = SPECPDL_INDEX (); struct gcpro gcpro1, gcpro2, gcpro3; GCPRO3 (args, elt, varlist); + lexenv = Vinternal_interpreter_environment; + varlist = Fcar (args); - while (!NILP (varlist)) + while (CONSP (varlist)) { QUIT; - elt = Fcar (varlist); + + elt = XCAR (varlist); if (SYMBOLP (elt)) - specbind (elt, Qnil); + { + var = elt; + val = Qnil; + } else if (! NILP (Fcdr (Fcdr (elt)))) signal_error ("`let' bindings can have only one value-form", elt); else { - val = Feval (Fcar (Fcdr (elt))); - specbind (Fcar (elt), val); + var = Fcar (elt); + val = eval_sub (Fcar (Fcdr (elt))); + } + + if (!NILP (lexenv) && SYMBOLP (var) + && !XSYMBOL (var)->declared_special + && NILP (Fmemq (var, Vinternal_interpreter_environment))) + /* Lexically bind VAR by adding it to the interpreter's binding + alist. */ + { + Lisp_Object newenv + = Fcons (Fcons (var, val), Vinternal_interpreter_environment); + if (EQ (Vinternal_interpreter_environment, lexenv)) + /* Save the old lexical environment on the specpdl stack, + but only for the first lexical binding, since we'll never + need to revert to one of the intermediate ones. */ + specbind (Qinternal_interpreter_environment, newenv); + else + Vinternal_interpreter_environment = newenv; } - varlist = Fcdr (varlist); + else + specbind (var, val); + + varlist = XCDR (varlist); } UNGCPRO; val = Fprogn (Fcdr (args)); @@ -960,7 +1026,7 @@ All the VALUEFORMs are evalled before any symbols are bound. usage: (let VARLIST BODY...) */) (Lisp_Object args) { - Lisp_Object *temps, tem; + Lisp_Object *temps, tem, lexenv; register Lisp_Object elt, varlist; int count = SPECPDL_INDEX (); register size_t argnum; @@ -987,22 +1053,36 @@ usage: (let VARLIST BODY...) */) else if (! NILP (Fcdr (Fcdr (elt)))) signal_error ("`let' bindings can have only one value-form", elt); else - temps [argnum++] = Feval (Fcar (Fcdr (elt))); + temps [argnum++] = eval_sub (Fcar (Fcdr (elt))); gcpro2.nvars = argnum; } UNGCPRO; + lexenv = Vinternal_interpreter_environment; + varlist = Fcar (args); for (argnum = 0; CONSP (varlist); varlist = XCDR (varlist)) { + Lisp_Object var; + elt = XCAR (varlist); + var = SYMBOLP (elt) ? elt : Fcar (elt); tem = temps[argnum++]; - if (SYMBOLP (elt)) - specbind (elt, tem); + + if (!NILP (lexenv) && SYMBOLP (var) + && !XSYMBOL (var)->declared_special + && NILP (Fmemq (var, Vinternal_interpreter_environment))) + /* Lexically bind VAR by adding it to the lexenv alist. */ + lexenv = Fcons (Fcons (var, tem), lexenv); else - specbind (Fcar (elt), tem); + /* Dynamically bind VAR. */ + specbind (var, tem); } + if (!EQ (lexenv, Vinternal_interpreter_environment)) + /* Instantiate a new lexical environment. */ + specbind (Qinternal_interpreter_environment, lexenv); + elt = Fprogn (Fcdr (args)); SAFE_FREE (); return unbind_to (count, elt); @@ -1022,7 +1102,7 @@ usage: (while TEST BODY...) */) test = Fcar (args); body = Fcdr (args); - while (!NILP (Feval (test))) + while (!NILP (eval_sub (test))) { QUIT; Fprogn (body); @@ -1124,7 +1204,7 @@ usage: (catch TAG BODY...) */) struct gcpro gcpro1; GCPRO1 (args); - tag = Feval (Fcar (args)); + tag = eval_sub (Fcar (args)); UNGCPRO; return internal_catch (tag, Fprogn, Fcdr (args)); } @@ -1254,7 +1334,7 @@ usage: (unwind-protect BODYFORM UNWINDFORMS...) */) int count = SPECPDL_INDEX (); record_unwind_protect (Fprogn, Fcdr (args)); - val = Feval (Fcar (args)); + val = eval_sub (Fcar (args)); return unbind_to (count, val); } @@ -1355,7 +1435,7 @@ internal_lisp_condition_case (volatile Lisp_Object var, Lisp_Object bodyform, h.tag = &c; handlerlist = &h; - val = Feval (bodyform); + val = eval_sub (bodyform); catchlist = c.next; handlerlist = h.next; return val; @@ -1999,9 +2079,12 @@ then strings and vectors are not accepted. */) if (!CONSP (fun)) return Qnil; funcar = XCAR (fun); - if (EQ (funcar, Qlambda)) + if (EQ (funcar, Qclosure)) + return (!NILP (Fassq (Qinteractive, Fcdr (Fcdr (XCDR (fun))))) + ? Qt : if_prop); + else if (EQ (funcar, Qlambda)) return !NILP (Fassq (Qinteractive, Fcdr (XCDR (fun)))) ? Qt : if_prop; - if (EQ (funcar, Qautoload)) + else if (EQ (funcar, Qautoload)) return !NILP (Fcar (Fcdr (Fcdr (XCDR (fun))))) ? Qt : if_prop; else return Qnil; @@ -2119,9 +2202,21 @@ do_autoload (Lisp_Object fundef, Lisp_Object funname) } -DEFUN ("eval", Feval, Seval, 1, 1, 0, - doc: /* Evaluate FORM and return its value. */) - (Lisp_Object form) +DEFUN ("eval", Feval, Seval, 1, 2, 0, + doc: /* Evaluate FORM and return its value. +If LEXICAL is t, evaluate using lexical scoping. */) + (Lisp_Object form, Lisp_Object lexical) +{ + int count = SPECPDL_INDEX (); + specbind (Qinternal_interpreter_environment, + NILP (lexical) ? Qnil : Fcons (Qt, Qnil)); + return unbind_to (count, eval_sub (form)); +} + +/* Eval a sub-expression of the current expression (i.e. in the same + lexical scope). */ +Lisp_Object +eval_sub (Lisp_Object form) { Lisp_Object fun, val, original_fun, original_args; Lisp_Object funcar; @@ -2132,7 +2227,20 @@ DEFUN ("eval", Feval, Seval, 1, 1, 0, abort (); if (SYMBOLP (form)) - return Fsymbol_value (form); + { + /* Look up its binding in the lexical environment. + We do not pay attention to the declared_special flag here, since we + already did that when let-binding the variable. */ + Lisp_Object lex_binding + = !NILP (Vinternal_interpreter_environment) /* Mere optimization! */ + ? Fassq (form, Vinternal_interpreter_environment) + : Qnil; + if (CONSP (lex_binding)) + return XCDR (lex_binding); + else + return Fsymbol_value (form); + } + if (!CONSP (form)) return form; @@ -2216,7 +2324,7 @@ DEFUN ("eval", Feval, Seval, 1, 1, 0, while (!NILP (args_left)) { - vals[argnum++] = Feval (Fcar (args_left)); + vals[argnum++] = eval_sub (Fcar (args_left)); args_left = Fcdr (args_left); gcpro3.nvars = argnum; } @@ -2237,7 +2345,7 @@ DEFUN ("eval", Feval, Seval, 1, 1, 0, maxargs = XSUBR (fun)->max_args; for (i = 0; i < maxargs; args_left = Fcdr (args_left)) { - argvals[i] = Feval (Fcar (args_left)); + argvals[i] = eval_sub (Fcar (args_left)); gcpro3.nvars = ++i; } @@ -2297,7 +2405,7 @@ DEFUN ("eval", Feval, Seval, 1, 1, 0, } } else if (COMPILEDP (fun)) - val = apply_lambda (fun, original_args, 1); + val = apply_lambda (fun, original_args); else { if (EQ (fun, Qunbound)) @@ -2313,9 +2421,10 @@ DEFUN ("eval", Feval, Seval, 1, 1, 0, goto retry; } if (EQ (funcar, Qmacro)) - val = Feval (apply1 (Fcdr (fun), original_args)); - else if (EQ (funcar, Qlambda)) - val = apply_lambda (fun, original_args, 1); + val = eval_sub (apply1 (Fcdr (fun), original_args)); + else if (EQ (funcar, Qlambda) + || EQ (funcar, Qclosure)) + val = apply_lambda (fun, original_args); else xsignal1 (Qinvalid_function, original_fun); } @@ -2786,6 +2895,39 @@ call7 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, /* The caller should GCPRO all the elements of ARGS. */ +DEFUN ("functionp", Ffunctionp, Sfunctionp, 1, 1, 0, + doc: /* Non-nil if OBJECT is a function. */) + (Lisp_Object object) +{ + if (SYMBOLP (object) && !NILP (Ffboundp (object))) + { + object = Findirect_function (object, Qt); + + if (CONSP (object) && EQ (XCAR (object), Qautoload)) + { + /* Autoloaded symbols are functions, except if they load + macros or keymaps. */ + int i; + for (i = 0; i < 4 && CONSP (object); i++) + object = XCDR (object); + + return (CONSP (object) && !NILP (XCAR (object))) ? Qnil : Qt; + } + } + + if (SUBRP (object)) + return (XSUBR (object)->max_args != UNEVALLED) ? Qt : Qnil; + else if (COMPILEDP (object)) + return Qt; + else if (CONSP (object)) + { + Lisp_Object car = XCAR (object); + return (EQ (car, Qlambda) || EQ (car, Qclosure)) ? Qt : Qnil; + } + else + return Qnil; +} + DEFUN ("funcall", Ffuncall, Sfuncall, 1, MANY, 0, doc: /* Call first argument as a function, passing remaining arguments to it. Return the value that function returns. @@ -2930,7 +3072,8 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */) funcar = XCAR (fun); if (!SYMBOLP (funcar)) xsignal1 (Qinvalid_function, original_fun); - if (EQ (funcar, Qlambda)) + if (EQ (funcar, Qlambda) + || EQ (funcar, Qclosure)) val = funcall_lambda (fun, numargs, args + 1); else if (EQ (funcar, Qautoload)) { @@ -2950,7 +3093,7 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */) } static Lisp_Object -apply_lambda (Lisp_Object fun, Lisp_Object args, int eval_flag) +apply_lambda (Lisp_Object fun, Lisp_Object args) { Lisp_Object args_left; size_t numargs; @@ -2970,18 +3113,15 @@ apply_lambda (Lisp_Object fun, Lisp_Object args, int eval_flag) for (i = 0; i < numargs; ) { tem = Fcar (args_left), args_left = Fcdr (args_left); - if (eval_flag) tem = Feval (tem); + tem = eval_sub (tem); arg_vector[i++] = tem; gcpro1.nvars = i; } UNGCPRO; - if (eval_flag) - { - backtrace_list->args = arg_vector; - backtrace_list->nargs = i; - } + backtrace_list->args = arg_vector; + backtrace_list->nargs = i; backtrace_list->evalargs = 0; tem = funcall_lambda (fun, numargs, arg_vector); @@ -3002,13 +3142,21 @@ static Lisp_Object funcall_lambda (Lisp_Object fun, size_t nargs, register Lisp_Object *arg_vector) { - Lisp_Object val, syms_left, next; + Lisp_Object val, syms_left, next, lexenv; int count = SPECPDL_INDEX (); size_t i; int optional, rest; if (CONSP (fun)) { + if (EQ (XCAR (fun), Qclosure)) + { + fun = XCDR (fun); /* Drop `closure'. */ + lexenv = XCAR (fun); + CHECK_LIST_CONS (fun, fun); + } + else + lexenv = Qnil; syms_left = XCDR (fun); if (CONSP (syms_left)) syms_left = XCAR (syms_left); @@ -3016,7 +3164,30 @@ funcall_lambda (Lisp_Object fun, size_t nargs, xsignal1 (Qinvalid_function, fun); } else if (COMPILEDP (fun)) - syms_left = AREF (fun, COMPILED_ARGLIST); + { + syms_left = AREF (fun, COMPILED_ARGLIST); + if (INTEGERP (syms_left)) + /* A byte-code object with a non-nil `push args' slot means we + shouldn't bind any arguments, instead just call the byte-code + interpreter directly; it will push arguments as necessary. + + Byte-code objects with either a non-existant, or a nil value for + the `push args' slot (the default), have dynamically-bound + arguments, and use the argument-binding code below instead (as do + all interpreted functions, even lexically bound ones). */ + { + /* If we have not actually read the bytecode string + and constants vector yet, fetch them from the file. */ + if (CONSP (AREF (fun, COMPILED_BYTECODE))) + Ffetch_bytecode (fun); + return exec_byte_code (AREF (fun, COMPILED_BYTECODE), + AREF (fun, COMPILED_CONSTANTS), + AREF (fun, COMPILED_STACK_DEPTH), + syms_left, + nargs, arg_vector); + } + lexenv = Qnil; + } else abort (); @@ -3033,17 +3204,29 @@ funcall_lambda (Lisp_Object fun, size_t nargs, rest = 1; else if (EQ (next, Qand_optional)) optional = 1; - else if (rest) + else { - specbind (next, Flist (nargs - i, &arg_vector[i])); - i = nargs; + Lisp_Object val; + if (rest) + { + val = Flist (nargs - i, &arg_vector[i]); + i = nargs; + } + else if (i < nargs) + val = arg_vector[i++]; + else if (!optional) + xsignal2 (Qwrong_number_of_arguments, fun, make_number (nargs)); + else + val = Qnil; + + /* Bind the argument. */ + if (!NILP (lexenv) && SYMBOLP (next)) + /* Lexically bind NEXT by adding it to the lexenv alist. */ + lexenv = Fcons (Fcons (next, val), lexenv); + else + /* Dynamically bind NEXT. */ + specbind (next, val); } - else if (i < nargs) - specbind (next, arg_vector[i++]); - else if (!optional) - xsignal2 (Qwrong_number_of_arguments, fun, make_number (nargs)); - else - specbind (next, Qnil); } if (!NILP (syms_left)) @@ -3051,6 +3234,10 @@ funcall_lambda (Lisp_Object fun, size_t nargs, else if (i < nargs) xsignal2 (Qwrong_number_of_arguments, fun, make_number (nargs)); + if (!EQ (lexenv, Vinternal_interpreter_environment)) + /* Instantiate a new lexical environment. */ + specbind (Qinternal_interpreter_environment, lexenv); + if (CONSP (fun)) val = Fprogn (XCDR (XCDR (fun))); else @@ -3059,9 +3246,10 @@ funcall_lambda (Lisp_Object fun, size_t nargs, and constants vector yet, fetch them from the file. */ if (CONSP (AREF (fun, COMPILED_BYTECODE))) Ffetch_bytecode (fun); - val = Fbyte_code (AREF (fun, COMPILED_BYTECODE), - AREF (fun, COMPILED_CONSTANTS), - AREF (fun, COMPILED_STACK_DEPTH)); + val = exec_byte_code (AREF (fun, COMPILED_BYTECODE), + AREF (fun, COMPILED_CONSTANTS), + AREF (fun, COMPILED_STACK_DEPTH), + Qnil, 0, 0); } return unbind_to (count, val); @@ -3297,6 +3485,17 @@ unbind_to (int count, Lisp_Object value) UNGCPRO; return value; } + +DEFUN ("special-variable-p", Fspecial_variable_p, Sspecial_variable_p, 1, 1, 0, + doc: /* Return non-nil if SYMBOL's global binding has been declared special. +A special variable is one that will be bound dynamically, even in a +context where binding is lexical by default. */) + (Lisp_Object symbol) +{ + CHECK_SYMBOL (symbol); + return XSYMBOL (symbol)->declared_special ? Qt : Qnil; +} + DEFUN ("backtrace-debug", Fbacktrace_debug, Sbacktrace_debug, 2, 2, 0, doc: /* Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG. @@ -3437,6 +3636,8 @@ mark_backtrace (void) } } +EXFUN (Funintern, 2); + void syms_of_eval (void) { @@ -3509,6 +3710,9 @@ before making `inhibit-quit' nil. */); Qand_optional = intern_c_string ("&optional"); staticpro (&Qand_optional); + Qclosure = intern_c_string ("closure"); + staticpro (&Qclosure); + Qdebug = intern_c_string ("debug"); staticpro (&Qdebug); @@ -3576,6 +3780,28 @@ DECL is a list `(declare ...)' containing the declarations. The value the function returns is not used. */); Vmacro_declaration_function = Qnil; + /* When lexical binding is being used, + vinternal_interpreter_environment is non-nil, and contains an alist + of lexically-bound variable, or (t), indicating an empty + environment. The lisp name of this variable would be + `internal-interpreter-environment' if it weren't hidden. + Every element of this list can be either a cons (VAR . VAL) + specifying a lexical binding, or a single symbol VAR indicating + that this variable should use dynamic scoping. */ + Qinternal_interpreter_environment + = intern_c_string ("internal-interpreter-environment"); + staticpro (&Qinternal_interpreter_environment); + DEFVAR_LISP ("internal-interpreter-environment", + Vinternal_interpreter_environment, + doc: /* If non-nil, the current lexical environment of the lisp interpreter. +When lexical binding is not being used, this variable is nil. +A value of `(t)' indicates an empty environment, otherwise it is an +alist of active lexical bindings. */); + Vinternal_interpreter_environment = Qnil; + /* Don't export this variable to Elisp, so noone can mess with it + (Just imagine if someone makes it buffer-local). */ + Funintern (Qinternal_interpreter_environment, Qnil); + Vrun_hooks = intern_c_string ("run-hooks"); staticpro (&Vrun_hooks); @@ -3625,4 +3851,6 @@ The value the function returns is not used. */); defsubr (&Sbacktrace_debug); defsubr (&Sbacktrace); defsubr (&Sbacktrace_frame); + defsubr (&Sspecial_variable_p); + defsubr (&Sfunctionp); } @@ -510,7 +510,7 @@ concat (size_t nargs, Lisp_Object *args, Lisp_Object ch; EMACS_INT this_len_byte; - if (VECTORP (this)) + if (VECTORP (this) || COMPILEDP (this)) for (i = 0; i < len; i++) { ch = AREF (this, i); @@ -2297,7 +2297,7 @@ mapcar1 (EMACS_INT leni, Lisp_Object *vals, Lisp_Object fn, Lisp_Object seq) 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */ - if (VECTORP (seq)) + if (VECTORP (seq) || COMPILEDP (seq)) { for (i = 0; i < leni; i++) { diff --git a/src/image.c b/src/image.c index 25929d1004..b37ba398d8 100644 --- a/src/image.c +++ b/src/image.c @@ -831,9 +831,7 @@ parse_image_spec (Lisp_Object spec, struct image_keyword *keywords, case IMAGE_FUNCTION_VALUE: value = indirect_function (value); - if (SUBRP (value) - || COMPILEDP (value) - || (CONSP (value) && EQ (XCAR (value), Qlambda))) + if (!NILP (Ffunctionp (value))) break; return 0; diff --git a/src/keyboard.c b/src/keyboard.c index 70098d46eb..d307250b86 100644 --- a/src/keyboard.c +++ b/src/keyboard.c @@ -1134,7 +1134,7 @@ command_loop_2 (Lisp_Object ignore) static Lisp_Object top_level_2 (void) { - return Feval (Vtop_level); + return Feval (Vtop_level, Qnil); } Lisp_Object @@ -3095,7 +3095,7 @@ read_char (int commandflag, int nmaps, Lisp_Object *maps, Lisp_Object prev_event help_form_saved_window_configs); record_unwind_protect (read_char_help_form_unwind, Qnil); - tem0 = Feval (Vhelp_form); + tem0 = Feval (Vhelp_form, Qnil); if (STRINGP (tem0)) internal_with_output_to_temp_buffer ("*Help*", print_help, tem0); @@ -7571,6 +7571,12 @@ menu_item_eval_property_1 (Lisp_Object arg) return Qnil; } +static Lisp_Object +eval_dyn (Lisp_Object form) +{ + return Feval (form, Qnil); +} + /* Evaluate an expression and return the result (or nil if something went wrong). Used to evaluate dynamic parts of menu items. */ Lisp_Object @@ -7579,7 +7585,7 @@ menu_item_eval_property (Lisp_Object sexpr) int count = SPECPDL_INDEX (); Lisp_Object val; specbind (Qinhibit_redisplay, Qt); - val = internal_condition_case_1 (Feval, sexpr, Qerror, + val = internal_condition_case_1 (eval_dyn, sexpr, Qerror, menu_item_eval_property_1); return unbind_to (count, val); } diff --git a/src/lisp.h b/src/lisp.h index 63f346f6a2..dfaa3fd01f 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -1016,6 +1016,10 @@ struct Lisp_Symbol /* Interned state of the symbol. This is an enumerator from enum symbol_interned. */ unsigned interned : 2; + + /* Non-zero means that this variable has been explicitly declared + special (with `defvar' etc), and shouldn't be lexically bound. */ + unsigned declared_special : 1; /* The symbol's name, as a Lisp string. @@ -2814,7 +2818,7 @@ extern void syms_of_lread (void); /* Defined in eval.c. */ extern Lisp_Object Qautoload, Qexit, Qinteractive, Qcommandp, Qdefun, Qmacro; -extern Lisp_Object Qinhibit_quit; +extern Lisp_Object Qinhibit_quit, Qclosure; extern Lisp_Object Vautoload_queue; extern Lisp_Object Vsignaling_function; extern int handling_signal; @@ -2844,7 +2848,9 @@ extern void xsignal2 (Lisp_Object, Lisp_Object, Lisp_Object) NO_RETURN; extern void xsignal3 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object) NO_RETURN; extern void signal_error (const char *, Lisp_Object) NO_RETURN; EXFUN (Fcommandp, 2); -EXFUN (Feval, 1); +EXFUN (Ffunctionp, 1); +EXFUN (Feval, 2); +extern Lisp_Object eval_sub (Lisp_Object form); EXFUN (Fapply, MANY); EXFUN (Ffuncall, MANY); EXFUN (Fbacktrace, 0); @@ -3264,6 +3270,8 @@ extern struct byte_stack *byte_stack_list; extern void mark_byte_stack (void); #endif extern void unmark_byte_stack (void); +extern Lisp_Object exec_byte_code (Lisp_Object, Lisp_Object, Lisp_Object, + Lisp_Object, int, Lisp_Object *); /* Defined in macros.c */ extern Lisp_Object Qexecute_kbd_macro; diff --git a/src/lread.c b/src/lread.c index a5fd1513c3..6a24569f55 100644 --- a/src/lread.c +++ b/src/lread.c @@ -73,6 +73,7 @@ Lisp_Object Qascii_character, Qload, Qload_file_name; Lisp_Object Qbackquote, Qcomma, Qcomma_at, Qcomma_dot, Qfunction; Lisp_Object Qinhibit_file_name_operation; Lisp_Object Qeval_buffer_list; +Lisp_Object Qlexical_binding; Lisp_Object Qfile_truename, Qdo_after_load_evaluation; /* ACM 2006/5/16 */ /* Used instead of Qget_file_char while loading *.elc files compiled @@ -81,6 +82,8 @@ static Lisp_Object Qget_emacs_mule_file_char; static Lisp_Object Qload_force_doc_strings; +extern Lisp_Object Qinternal_interpreter_environment; + static Lisp_Object Qload_in_progress; /* The association list of objects read with the #n=object form. @@ -147,8 +150,7 @@ static Lisp_Object Vloads_in_progress; static int read_emacs_mule_char (int, int (*) (int, Lisp_Object), Lisp_Object); -static void readevalloop (Lisp_Object, FILE*, Lisp_Object, - Lisp_Object (*) (Lisp_Object), int, +static void readevalloop (Lisp_Object, FILE*, Lisp_Object, int, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object); static Lisp_Object load_unwind (Lisp_Object); @@ -769,6 +771,116 @@ DEFUN ("get-file-char", Fget_file_char, Sget_file_char, 0, 0, 0, + +/* Return true if the lisp code read using READCHARFUN defines a non-nil + `lexical-binding' file variable. After returning, the stream is + positioned following the first line, if it is a comment, otherwise + nothing is read. */ + +static int +lisp_file_lexically_bound_p (Lisp_Object readcharfun) +{ + int ch = READCHAR; + if (ch != ';') + /* The first line isn't a comment, just give up. */ + { + UNREAD (ch); + return 0; + } + else + /* Look for an appropriate file-variable in the first line. */ + { + int rv = 0; + enum { + NOMINAL, AFTER_FIRST_DASH, AFTER_ASTERIX, + } beg_end_state = NOMINAL; + int in_file_vars = 0; + +#define UPDATE_BEG_END_STATE(ch) \ + if (beg_end_state == NOMINAL) \ + beg_end_state = (ch == '-' ? AFTER_FIRST_DASH : NOMINAL); \ + else if (beg_end_state == AFTER_FIRST_DASH) \ + beg_end_state = (ch == '*' ? AFTER_ASTERIX : NOMINAL); \ + else if (beg_end_state == AFTER_ASTERIX) \ + { \ + if (ch == '-') \ + in_file_vars = !in_file_vars; \ + beg_end_state = NOMINAL; \ + } + + /* Skip until we get to the file vars, if any. */ + do + { + ch = READCHAR; + UPDATE_BEG_END_STATE (ch); + } + while (!in_file_vars && ch != '\n' && ch != EOF); + + while (in_file_vars) + { + char var[100], *var_end, val[100], *val_end; + + ch = READCHAR; + + /* Read a variable name. */ + while (ch == ' ' || ch == '\t') + ch = READCHAR; + + var_end = var; + while (ch != ':' && ch != '\n' && ch != EOF) + { + if (var_end < var + sizeof var - 1) + *var_end++ = ch; + UPDATE_BEG_END_STATE (ch); + ch = READCHAR; + } + + while (var_end > var + && (var_end[-1] == ' ' || var_end[-1] == '\t')) + var_end--; + *var_end = '\0'; + + if (ch == ':') + { + /* Read a variable value. */ + ch = READCHAR; + + while (ch == ' ' || ch == '\t') + ch = READCHAR; + + val_end = val; + while (ch != ';' && ch != '\n' && ch != EOF && in_file_vars) + { + if (val_end < val + sizeof val - 1) + *val_end++ = ch; + UPDATE_BEG_END_STATE (ch); + ch = READCHAR; + } + if (! in_file_vars) + /* The value was terminated by an end-marker, which + remove. */ + val_end -= 3; + while (val_end > val + && (val_end[-1] == ' ' || val_end[-1] == '\t')) + val_end--; + *val_end = '\0'; + + if (strcmp (var, "lexical-binding") == 0) + /* This is it... */ + { + rv = (strcmp (val, "nil") != 0); + break; + } + } + } + + while (ch != '\n' && ch != EOF) + ch = READCHAR; + + return rv; + } +} + /* Value is a version number of byte compiled code if the file associated with file descriptor FD is a compiled Lisp file that's safe to load. Only files compiled with Emacs are safe to load. @@ -1033,6 +1145,12 @@ Return t if the file exists and loads successfully. */) Vloads_in_progress = Fcons (found, Vloads_in_progress); } + /* All loads are by default dynamic, unless the file itself specifies + otherwise using a file-variable in the first line. This is bound here + so that it takes effect whether or not we use + Vload_source_file_function. */ + specbind (Qlexical_binding, Qnil); + /* Get the name for load-history. */ hist_file_name = (! NILP (Vpurify_flag) ? Fconcat (2, (tmp[0] = Ffile_name_directory (file), @@ -1157,15 +1275,20 @@ Return t if the file exists and loads successfully. */) load_descriptor_list = Fcons (make_number (fileno (stream)), load_descriptor_list); specbind (Qload_in_progress, Qt); + + instream = stream; + if (lisp_file_lexically_bound_p (Qget_file_char)) + Fset (Qlexical_binding, Qt); + if (! version || version >= 22) readevalloop (Qget_file_char, stream, hist_file_name, - Feval, 0, Qnil, Qnil, Qnil, Qnil); + 0, Qnil, Qnil, Qnil, Qnil); else { /* We can't handle a file which was compiled with byte-compile-dynamic by older version of Emacs. */ specbind (Qload_force_doc_strings, Qt); - readevalloop (Qget_emacs_mule_file_char, stream, hist_file_name, Feval, + readevalloop (Qget_emacs_mule_file_char, stream, hist_file_name, 0, Qnil, Qnil, Qnil, Qnil); } unbind_to (count, Qnil); @@ -1535,7 +1658,6 @@ static void readevalloop (Lisp_Object readcharfun, FILE *stream, Lisp_Object sourcename, - Lisp_Object (*evalfun) (Lisp_Object), int printflag, Lisp_Object unibyte, Lisp_Object readfun, Lisp_Object start, Lisp_Object end) @@ -1546,6 +1668,7 @@ readevalloop (Lisp_Object readcharfun, struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; struct buffer *b = 0; int continue_reading_p; + Lisp_Object lex_bound; /* Nonzero if reading an entire buffer. */ int whole_buffer = 0; /* 1 on the first time around. */ @@ -1571,6 +1694,14 @@ readevalloop (Lisp_Object readcharfun, record_unwind_protect (readevalloop_1, load_convert_to_unibyte ? Qt : Qnil); load_convert_to_unibyte = !NILP (unibyte); + /* If lexical binding is active (either because it was specified in + the file's header, or via a buffer-local variable), create an empty + lexical environment, otherwise, turn off lexical binding. */ + lex_bound = find_symbol_value (Qlexical_binding); + specbind (Qinternal_interpreter_environment, + NILP (lex_bound) || EQ (lex_bound, Qunbound) + ? Qnil : Fcons (Qt, Qnil)); + GCPRO4 (sourcename, readfun, start, end); /* Try to ensure sourcename is a truename, except whilst preloading. */ @@ -1672,7 +1803,7 @@ readevalloop (Lisp_Object readcharfun, unbind_to (count1, Qnil); /* Now eval what we just read. */ - val = (*evalfun) (val); + val = eval_sub (val); if (printflag) { @@ -1732,7 +1863,8 @@ This function preserves the position of point. */) specbind (Qstandard_output, tem); record_unwind_protect (save_excursion_restore, save_excursion_save ()); BUF_TEMP_SET_PT (XBUFFER (buf), BUF_BEGV (XBUFFER (buf))); - readevalloop (buf, 0, filename, Feval, + specbind (Qlexical_binding, lisp_file_lexically_bound_p (buf) ? Qt : Qnil); + readevalloop (buf, 0, filename, !NILP (printflag), unibyte, Qnil, Qnil, Qnil); unbind_to (count, Qnil); @@ -1753,6 +1885,7 @@ which is the input stream for reading characters. This function does not move point. */) (Lisp_Object start, Lisp_Object end, Lisp_Object printflag, Lisp_Object read_function) { + /* FIXME: Do the eval-sexp-add-defvars danse! */ int count = SPECPDL_INDEX (); Lisp_Object tem, cbuf; @@ -1766,7 +1899,7 @@ This function does not move point. */) specbind (Qeval_buffer_list, Fcons (cbuf, Veval_buffer_list)); /* readevalloop calls functions which check the type of start and end. */ - readevalloop (cbuf, 0, BVAR (XBUFFER (cbuf), filename), Feval, + readevalloop (cbuf, 0, BVAR (XBUFFER (cbuf), filename), !NILP (printflag), Qnil, read_function, start, end); @@ -3838,6 +3971,7 @@ defvar_int (struct Lisp_Intfwd *i_fwd, sym = intern_c_string (namestring); i_fwd->type = Lisp_Fwd_Int; i_fwd->intvar = address; + XSYMBOL (sym)->declared_special = 1; XSYMBOL (sym)->redirect = SYMBOL_FORWARDED; SET_SYMBOL_FWD (XSYMBOL (sym), (union Lisp_Fwd *)i_fwd); } @@ -3852,6 +3986,7 @@ defvar_bool (struct Lisp_Boolfwd *b_fwd, sym = intern_c_string (namestring); b_fwd->type = Lisp_Fwd_Bool; b_fwd->boolvar = address; + XSYMBOL (sym)->declared_special = 1; XSYMBOL (sym)->redirect = SYMBOL_FORWARDED; SET_SYMBOL_FWD (XSYMBOL (sym), (union Lisp_Fwd *)b_fwd); Vbyte_boolean_vars = Fcons (sym, Vbyte_boolean_vars); @@ -3870,6 +4005,7 @@ defvar_lisp_nopro (struct Lisp_Objfwd *o_fwd, sym = intern_c_string (namestring); o_fwd->type = Lisp_Fwd_Obj; o_fwd->objvar = address; + XSYMBOL (sym)->declared_special = 1; XSYMBOL (sym)->redirect = SYMBOL_FORWARDED; SET_SYMBOL_FWD (XSYMBOL (sym), (union Lisp_Fwd *)o_fwd); } @@ -3893,6 +4029,7 @@ defvar_kboard (struct Lisp_Kboard_Objfwd *ko_fwd, sym = intern_c_string (namestring); ko_fwd->type = Lisp_Fwd_Kboard_Obj; ko_fwd->offset = offset; + XSYMBOL (sym)->declared_special = 1; XSYMBOL (sym)->redirect = SYMBOL_FORWARDED; SET_SYMBOL_FWD (XSYMBOL (sym), (union Lisp_Fwd *)ko_fwd); } @@ -4320,6 +4457,15 @@ to load. See also `load-dangerous-libraries'. */); Vbytecomp_version_regexp = make_pure_c_string ("^;;;.\\(in Emacs version\\|bytecomp version FSF\\)"); + Qlexical_binding = intern ("lexical-binding"); + staticpro (&Qlexical_binding); + DEFVAR_LISP ("lexical-binding", Vlexical_binding, + doc: /* If non-nil, use lexical binding when evaluating code. +This only applies to code evaluated by `eval-buffer' and `eval-region'. +This variable is automatically set from the file variables of an interpreted + Lisp file read using `load'. */); + Fmake_variable_buffer_local (Qlexical_binding); + DEFVAR_LISP ("eval-buffer-list", Veval_buffer_list, doc: /* List of buffers being read from by calls to `eval-buffer' and `eval-region'. */); Veval_buffer_list = Qnil; diff --git a/src/minibuf.c b/src/minibuf.c index 7bed9bb2f2..4adf665f8f 100644 --- a/src/minibuf.c +++ b/src/minibuf.c @@ -971,7 +971,8 @@ Such arguments are used as in `read-from-minibuffer'.) */) { return Feval (read_minibuf (Vread_expression_map, initial_contents, prompt, Qnil, 1, Qread_expression_history, - make_number (0), Qnil, 0, 0)); + make_number (0), Qnil, 0, 0), + Qnil); } /* Functions that use the minibuffer to read various things. */ diff --git a/src/print.c b/src/print.c index dd3d1c9bbb..3e0e168381 100644 --- a/src/print.c +++ b/src/print.c @@ -521,6 +521,7 @@ temp_output_buffer_setup (const char *bufname) specbind (Qstandard_output, buf); } +/* FIXME: Use Lisp's with-output-to-temp-buffer instead! */ Lisp_Object internal_with_output_to_temp_buffer (const char *bufname, Lisp_Object (*function) (Lisp_Object), Lisp_Object args) { @@ -542,60 +543,6 @@ internal_with_output_to_temp_buffer (const char *bufname, Lisp_Object (*function return unbind_to (count, val); } - -DEFUN ("with-output-to-temp-buffer", - Fwith_output_to_temp_buffer, Swith_output_to_temp_buffer, - 1, UNEVALLED, 0, - doc: /* Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer. - -This construct makes buffer BUFNAME empty before running BODY. -It does not make the buffer current for BODY. -Instead it binds `standard-output' to that buffer, so that output -generated with `prin1' and similar functions in BODY goes into -the buffer. - -At the end of BODY, this marks buffer BUFNAME unmodifed and displays -it in a window, but does not select it. The normal way to do this is -by calling `display-buffer', then running `temp-buffer-show-hook'. -However, if `temp-buffer-show-function' is non-nil, it calls that -function instead (and does not run `temp-buffer-show-hook'). The -function gets one argument, the buffer to display. - -The return value of `with-output-to-temp-buffer' is the value of the -last form in BODY. If BODY does not finish normally, the buffer -BUFNAME is not displayed. - -This runs the hook `temp-buffer-setup-hook' before BODY, -with the buffer BUFNAME temporarily current. It runs the hook -`temp-buffer-show-hook' after displaying buffer BUFNAME, with that -buffer temporarily current, and the window that was used to display it -temporarily selected. But it doesn't run `temp-buffer-show-hook' -if it uses `temp-buffer-show-function'. - -usage: (with-output-to-temp-buffer BUFNAME BODY...) */) - (Lisp_Object args) -{ - struct gcpro gcpro1; - Lisp_Object name; - int count = SPECPDL_INDEX (); - Lisp_Object buf, val; - - GCPRO1(args); - name = Feval (Fcar (args)); - CHECK_STRING (name); - temp_output_buffer_setup (SSDATA (name)); - buf = Vstandard_output; - UNGCPRO; - - val = Fprogn (XCDR (args)); - - GCPRO1 (val); - temp_output_buffer_show (buf); - UNGCPRO; - - return unbind_to (count, val); -} - static void print (Lisp_Object obj, register Lisp_Object printcharfun, int escapeflag); static void print_preprocess (Lisp_Object obj); @@ -2289,6 +2236,4 @@ priorities. */); print_prune_charset_plist = Qnil; staticpro (&print_prune_charset_plist); - - defsubr (&Swith_output_to_temp_buffer); } diff --git a/src/window.c b/src/window.c index 0d299b7cd9..5ca46dd331 100644 --- a/src/window.c +++ b/src/window.c @@ -3705,6 +3705,16 @@ temp_output_buffer_show (register Lisp_Object buf) } } } + +DEFUN ("internal-temp-output-buffer-show", + Ftemp_output_buffer_show, Stemp_output_buffer_show, + 1, 1, 0, + doc: /* Internal function for `with-output-to-temp-buffer''. */) + (Lisp_Object buf) +{ + temp_output_buffer_show (buf); + return Qnil; +} static void make_dummy_parent (Lisp_Object window) @@ -6390,28 +6400,6 @@ redirection (see `redirect-frame-focus'). */) return (tem); } -DEFUN ("save-window-excursion", Fsave_window_excursion, Ssave_window_excursion, - 0, UNEVALLED, 0, - doc: /* Execute BODY, preserving window sizes and contents. -Return the value of the last form in BODY. -Restore which buffer appears in which window, where display starts, -and the value of point and mark for each window. -Also restore the choice of selected window. -Also restore which buffer is current. -Does not restore the value of point in current buffer. -usage: (save-window-excursion BODY...) */) - (Lisp_Object args) -{ - register Lisp_Object val; - register int count = SPECPDL_INDEX (); - - record_unwind_protect (Fset_window_configuration, - Fcurrent_window_configuration (Qnil)); - val = Fprogn (args); - return unbind_to (count, val); -} - - /*********************************************************************** Window Split Tree @@ -7167,6 +7155,7 @@ frame to be redrawn only if it is a tty frame. */); defsubr (&Sset_window_buffer); defsubr (&Sselect_window); defsubr (&Sforce_window_update); + defsubr (&Stemp_output_buffer_show); defsubr (&Ssplit_window); defsubr (&Senlarge_window); defsubr (&Sshrink_window); @@ -7185,7 +7174,6 @@ frame to be redrawn only if it is a tty frame. */); defsubr (&Swindow_configuration_frame); defsubr (&Sset_window_configuration); defsubr (&Scurrent_window_configuration); - defsubr (&Ssave_window_excursion); defsubr (&Swindow_tree); defsubr (&Sset_window_margins); defsubr (&Swindow_margins); diff --git a/src/window.h b/src/window.h index f788e126d6..ad627aca34 100644 --- a/src/window.h +++ b/src/window.h @@ -853,7 +853,6 @@ EXFUN (Fwindow_minibuffer_p, 1); EXFUN (Fdelete_window, 1); EXFUN (Fwindow_buffer, 1); EXFUN (Fget_buffer_window, 2); -EXFUN (Fsave_window_excursion, UNEVALLED); EXFUN (Fset_window_configuration, 1); EXFUN (Fcurrent_window_configuration, 1); extern int compare_window_configurations (Lisp_Object, Lisp_Object, int); |