From b9598260f96ddc652cd82ab64bbe922ccfc48a29 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Sun, 13 Jun 2010 16:36:17 -0400 Subject: New branch for lexbind, losing all history. This initial patch is based on 2002-06-27T22:39:10Z!storm@cua.dk of the original lexbind branch. --- src/bytecode.c | 128 ++++++++++++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 122 insertions(+), 6 deletions(-) (limited to 'src/bytecode.c') diff --git a/src/bytecode.c b/src/bytecode.c index c53c5acdbb3..fec855c0b83 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -87,9 +87,11 @@ int byte_metering_on; Lisp_Object Qbytecode; +extern Lisp_Object Qand_optional, Qand_rest; /* Byte codes: */ +#define Bstack_ref 0 #define Bvarref 010 #define Bvarset 020 #define Bvarbind 030 @@ -229,6 +231,13 @@ Lisp_Object Qbytecode; #define BconcatN 0260 #define BinsertN 0261 +/* Bstack_ref is code 0. */ +#define Bstack_set 0262 +#define Bstack_set2 0263 +#define Bvec_ref 0264 +#define Bvec_set 0265 +#define BdiscardN 0266 + #define Bconstant 0300 #define CONSTANTLIM 0100 @@ -397,14 +406,41 @@ unmark_byte_stack () } while (0) -DEFUN ("byte-code", Fbyte_code, Sbyte_code, 3, 3, 0, +DEFUN ("byte-code", Fbyte_code, Sbyte_code, 3, MANY, 0, doc: /* Function used internally in byte-compiled code. The first argument, BYTESTR, is a string of byte code; the second, VECTOR, a vector of constants; the third, MAXDEPTH, the maximum stack depth used in this function. -If the third argument is incorrect, Emacs may crash. */) - (bytestr, vector, maxdepth) - Lisp_Object bytestr, vector, maxdepth; +If the third argument is incorrect, Emacs may crash. + +If ARGS-TEMPLATE is specified, it is an argument list specification, +according to which any remaining arguments are pushed on the stack +before executing BYTESTR. + +usage: (byte-code BYTESTR VECTOR MAXDEP &optional ARGS-TEMPLATE &rest ARGS) */) + (nargs, args) + int nargs; + Lisp_Object *args; +{ + Lisp_Object args_tmpl = nargs >= 4 ? args[3] : Qnil; + int pnargs = nargs >= 4 ? nargs - 4 : 0; + Lisp_Object *pargs = nargs >= 4 ? args + 4 : 0; + return exec_byte_code (args[0], args[1], args[2], args_tmpl, pnargs, pargs); +} + +/* 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 (bytestr, vector, maxdepth, args_template, nargs, args) + Lisp_Object bytestr, vector, maxdepth, args_template; + int nargs; + Lisp_Object *args; { int count = SPECPDL_INDEX (); #ifdef BYTE_CODE_METER @@ -462,6 +498,37 @@ If the third argument is incorrect, Emacs may crash. */) stacke = stack.bottom - 1 + XFASTINT (maxdepth); #endif + if (! NILP (args_template)) + /* We should push some arguments on the stack. */ + { + Lisp_Object at; + int pushed = 0, optional = 0; + + for (at = args_template; CONSP (at); at = XCDR (at)) + if (EQ (XCAR (at), Qand_optional)) + optional = 1; + else if (EQ (XCAR (at), Qand_rest)) + { + PUSH (Flist (nargs, args)); + pushed = nargs; + at = Qnil; + break; + } + else if (pushed < nargs) + { + PUSH (*args++); + pushed++; + } + else if (optional) + PUSH (Qnil); + else + break; + + if (pushed != nargs || !NILP (at)) + Fsignal (Qwrong_number_of_arguments, + Fcons (args_template, Fcons (make_number (nargs), Qnil))); + } + while (1) { #ifdef BYTE_CODE_SAFE @@ -1641,8 +1708,57 @@ If the third argument is incorrect, Emacs may crash. */) break; #endif - case 0: - abort (); + /* Handy byte-codes for lexical binding. */ + case Bstack_ref: + case Bstack_ref+1: + case Bstack_ref+2: + case Bstack_ref+3: + case Bstack_ref+4: + case Bstack_ref+5: + PUSH (stack.bottom[op - Bstack_ref]); + break; + case Bstack_ref+6: + PUSH (stack.bottom[FETCH]); + break; + case Bstack_ref+7: + PUSH (stack.bottom[FETCH2]); + break; + case Bstack_set: + stack.bottom[FETCH] = POP; + break; + case Bstack_set2: + stack.bottom[FETCH2] = POP; + break; + case Bvec_ref: + case Bvec_set: + /* These byte-codes used mostly for variable references to + lexically bound variables that are in an environment vector + instead of on the byte-interpreter stack (generally those + variables which might be shared with a closure). */ + { + int index = FETCH; + Lisp_Object vec = POP; + + if (! VECTORP (vec)) + wrong_type_argument (Qvectorp, vec); + else if (index < 0 || index >= XVECTOR (vec)->size) + args_out_of_range (vec, index); + + if (op == Bvec_ref) + PUSH (XVECTOR (vec)->contents[index]); + else + XVECTOR (vec)->contents[index] = POP; + } + break; + case BdiscardN: + op = FETCH; + if (op & 0x80) + { + op &= 0x7F; + top[-op] = TOP; + } + DISCARD (op); + break; case 255: default: -- cgit v1.3 From 3c3ddb9833996729545bb4909bea359e5dbaa02e Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Mon, 14 Jun 2010 22:51:25 -0400 Subject: * lisp/emacs-lisp/bytecomp.el (byte-compile-initial-macro-environment): Don't macroexpand before evaluating in eval-and-compile, in case `body's macro expansion uses macros and functions defined in itself. * src/bytecode.c (exec_byte_code): * src/eval.c (Ffunctionp): Fix up int/Lisp_Object confusions. --- lisp/ChangeLog | 6 ++++++ lisp/emacs-lisp/bytecomp.el | 5 +---- src/ChangeLog | 5 +++++ src/bytecode.c | 2 +- src/eval.c | 7 ++----- 5 files changed, 15 insertions(+), 10 deletions(-) (limited to 'src/bytecode.c') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index af456bd5d2e..856d4ea3898 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,9 @@ +2010-06-15 Stefan Monnier + + * emacs-lisp/bytecomp.el (byte-compile-initial-macro-environment): + Don't macroexpand before evaluating in eval-and-compile, in case + `body's macro expansion uses macros and functions defined in itself. + 2010-06-14 Stefan Monnier * emacs-lisp/bytecomp.el (byte-compile-check-variable): diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 490d928c5a0..df93528683c 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -479,10 +479,7 @@ This list lives partly on the stack.") (cons 'progn body) byte-compile-initial-macro-environment)))))) (eval-and-compile . (lambda (&rest body) - (byte-compile-eval-before-compile - (macroexpand-all - (cons 'progn body) - byte-compile-initial-macro-environment)) + (byte-compile-eval-before-compile (cons 'progn body)) (cons 'progn body)))) "The default macro-environment passed to macroexpand by the compiler. Placing a macro here will cause a macro to have different semantics when diff --git a/src/ChangeLog b/src/ChangeLog index 3e6c8f24398..017b3eb2553 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,8 @@ +2010-06-15 Stefan Monnier + + * bytecode.c (exec_byte_code): + * eval.c (Ffunctionp): Fix up int/Lisp_Object confusions. + 2010-06-12 Eli Zaretskii * makefile.w32-in ($(BLD)/bidi.$(O)): Depend on biditype.h and diff --git a/src/bytecode.c b/src/bytecode.c index fec855c0b83..192d397c45f 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -1742,7 +1742,7 @@ exec_byte_code (bytestr, vector, maxdepth, args_template, nargs, args) if (! VECTORP (vec)) wrong_type_argument (Qvectorp, vec); else if (index < 0 || index >= XVECTOR (vec)->size) - args_out_of_range (vec, index); + args_out_of_range (vec, make_number (index)); if (op == Bvec_ref) PUSH (XVECTOR (vec)->contents[index]); diff --git a/src/eval.c b/src/eval.c index 875b4498a61..71a0b111849 100644 --- a/src/eval.c +++ b/src/eval.c @@ -62,7 +62,7 @@ Lisp_Object Qinhibit_quit, Vinhibit_quit, Vquit_flag; Lisp_Object Qand_rest, Qand_optional; Lisp_Object Qdebug_on_error; Lisp_Object Qdeclare; -Lisp_Object Qcurry, Qunevalled; +Lisp_Object Qcurry; Lisp_Object Qinternal_interpreter_environment, Qclosure; Lisp_Object Qdebug; @@ -3109,7 +3109,7 @@ DEFUN ("functionp", Ffunctionp, Sfunctionp, 1, 1, 0, } if (SUBRP (object)) - return (XSUBR (object)->max_args != Qunevalled) ? Qt : Qnil; + return (XSUBR (object)->max_args != UNEVALLED) ? Qt : Qnil; else if (FUNVECP (object)) return Qt; else if (CONSP (object)) @@ -4002,9 +4002,6 @@ before making `inhibit-quit' nil. */); Qcurry = intern_c_string ("curry"); staticpro (&Qcurry); - Qunevalled = intern_c_string ("unevalled"); - staticpro (&Qunevalled); - Qdebug = intern_c_string ("debug"); staticpro (&Qdebug); -- cgit v1.3 From defb141157dfa37c33cdcbfa4b29c702a8fc9edf Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Mon, 13 Dec 2010 22:37:44 -0500 Subject: Try and be more careful about propagation of lexical environment. * src/eval.c (apply_lambda, funcall_lambda): Remove lexenv arg. (Feval): Always eval in the empty environment. (eval_sub): New function. Use it for all calls to Feval that should evaluate in the lexical environment of the caller. Pass `closure's as is to apply_lambda. (Ffuncall): Pass `closure's as is to funcall_lambda. (funcall_lambda): Extract lexenv for `closure's, when applicable. Also use lexical scoping for the &rest argument, if applicable. * src/lisp.h (eval_sub): Declare. * src/lread.c (readevalloop): Remove `evalfun' argument. * src/print.c (Fwith_output_to_temp_buffer): * src/data.c (Fsetq_default): Use eval_sub. * lisp/emacs-lisp/bytecomp.el (byte-compile-condition-case): Use push. --- lisp/ChangeLog | 4 ++ lisp/emacs-lisp/bytecomp.el | 16 +++--- src/ChangeLog | 16 ++++++ src/bytecode.c | 8 +-- src/callint.c | 2 +- src/data.c | 2 +- src/eval.c | 133 ++++++++++++++++++++++---------------------- src/lisp.h | 1 + src/lread.c | 14 ++--- src/minibuf.c | 1 + src/print.c | 2 +- 11 files changed, 110 insertions(+), 89 deletions(-) (limited to 'src/bytecode.c') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 5a5b7ef44dc..053eb95329c 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,7 @@ +2010-12-14 Stefan Monnier + + * emacs-lisp/bytecomp.el (byte-compile-condition-case): Use push. + 2010-12-13 Stefan Monnier * subr.el (with-lexical-binding): Remove. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 90fcf7fb8a6..0f7018b9b64 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -2979,6 +2979,7 @@ If FORM is a lambda or a macro, byte-compile it as a function." ;; Given BYTECOMP-BODY, compile it and return a new body. (defun byte-compile-top-level-body (bytecomp-body &optional for-effect) + ;; FIXME: lexbind. Check all callers! (setq bytecomp-body (byte-compile-top-level (cons 'progn bytecomp-body) for-effect t)) (cond ((eq (car-safe bytecomp-body) 'progn) @@ -4083,8 +4084,8 @@ if LFORMINFO is nil (meaning all bindings are dynamic)." (defun byte-compile-track-mouse (form) (byte-compile-form - `(funcall '(lambda nil - (track-mouse ,@(byte-compile-top-level-body (cdr form))))))) + `(funcall #'(lambda nil + (track-mouse ,@(byte-compile-top-level-body (cdr form))))))) (defun byte-compile-condition-case (form) (let* ((var (nth 1 form)) @@ -4121,11 +4122,10 @@ if LFORMINFO is nil (meaning all bindings are dynamic)." ;; "`%s' is not a known condition name (in condition-case)" ;; condition)) ) - (setq compiled-clauses - (cons (cons condition - (byte-compile-top-level-body - (cdr clause) for-effect)) - compiled-clauses))) + (push (cons condition + (byte-compile-top-level-body + (cdr clause) for-effect)) + compiled-clauses)) (setq clauses (cdr clauses))) (byte-compile-push-constant (nreverse compiled-clauses))) (byte-compile-out 'byte-condition-case 0))) @@ -4244,7 +4244,7 @@ if LFORMINFO is nil (meaning all bindings are dynamic)." `(if (not (default-boundp ',var)) (setq-default ,var ,value)))) (when (eq fun 'defconst) ;; This will signal an appropriate error at runtime. - `(eval ',form))) + `(eval ',form))) ;FIXME: lexbind `',var)))) (defun byte-compile-autoload (form) diff --git a/src/ChangeLog b/src/ChangeLog index 6abdf583b00..c333b6388c6 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,19 @@ +2010-12-14 Stefan Monnier + + Try and be more careful about propagation of lexical environment. + * eval.c (apply_lambda, funcall_lambda): Remove lexenv arg. + (Feval): Always eval in the empty environment. + (eval_sub): New function. Use it for all calls to Feval that should + evaluate in the lexical environment of the caller. + Pass `closure's as is to apply_lambda. + (Ffuncall): Pass `closure's as is to funcall_lambda. + (funcall_lambda): Extract lexenv for `closure's, when applicable. + Also use lexical scoping for the &rest argument, if applicable. + * lisp.h (eval_sub): Declare. + * lread.c (readevalloop): Remove `evalfun' argument. + * print.c (Fwith_output_to_temp_buffer): + * data.c (Fsetq_default): Use eval_sub. + 2010-12-13 Stefan Monnier Make the effect of (defvar foo) local. diff --git a/src/bytecode.c b/src/bytecode.c index d94b19b2d07..01fce0577b0 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -901,7 +901,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, case Bsave_window_excursion: BEFORE_POTENTIAL_GC (); - TOP = Fsave_window_excursion (TOP); + TOP = Fsave_window_excursion (TOP); /* FIXME: lexbind */ AFTER_POTENTIAL_GC (); break; @@ -915,13 +915,13 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, Lisp_Object v1; BEFORE_POTENTIAL_GC (); v1 = POP; - TOP = internal_catch (TOP, Feval, v1); + TOP = internal_catch (TOP, Feval, v1); /* FIXME: lexbind */ AFTER_POTENTIAL_GC (); break; } case Bunwind_protect: - record_unwind_protect (Fprogn, POP); + record_unwind_protect (Fprogn, POP); /* FIXME: lexbind */ break; case Bcondition_case: @@ -930,7 +930,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, handlers = POP; body = POP; BEFORE_POTENTIAL_GC (); - TOP = internal_lisp_condition_case (TOP, body, handlers); + TOP = internal_lisp_condition_case (TOP, body, handlers); /* FIXME: lexbind */ AFTER_POTENTIAL_GC (); break; } diff --git a/src/callint.c b/src/callint.c index ae11c7cb24d..960158029c3 100644 --- a/src/callint.c +++ b/src/callint.c @@ -342,7 +342,7 @@ invoke it. If KEYS is omitted or nil, the return value of input = specs; /* Compute the arg values using the user's expression. */ GCPRO2 (input, filter_specs); - specs = Feval (specs); + specs = Feval (specs); /* FIXME: lexbind */ UNGCPRO; if (i != num_input_events || !NILP (record_flag)) { diff --git a/src/data.c b/src/data.c index 924a717cf3d..42d9e076e80 100644 --- a/src/data.c +++ b/src/data.c @@ -1452,7 +1452,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)); diff --git a/src/eval.c b/src/eval.c index 74dd7e63aa1..485ba00c1e4 100644 --- a/src/eval.c +++ b/src/eval.c @@ -178,10 +178,8 @@ int handling_signal; Lisp_Object Vmacro_declaration_function; -static Lisp_Object apply_lambda (Lisp_Object fun, Lisp_Object args, - Lisp_Object lexenv); -static Lisp_Object funcall_lambda (Lisp_Object, int, Lisp_Object *, - Lisp_Object); +static Lisp_Object apply_lambda (Lisp_Object fun, Lisp_Object args); +static Lisp_Object funcall_lambda (Lisp_Object, int, Lisp_Object *); static void unwind_to_catch (struct catchtag *, Lisp_Object) NO_RETURN; void @@ -308,7 +306,7 @@ usage: (or CONDITIONS...) */) while (CONSP (args)) { - val = Feval (XCAR (args)); + val = eval_sub (XCAR (args)); if (!NILP (val)) break; args = XCDR (args); @@ -332,7 +330,7 @@ usage: (and CONDITIONS...) */) while (CONSP (args)) { - val = Feval (XCAR (args)); + val = eval_sub (XCAR (args)); if (NILP (val)) break; args = XCDR (args); @@ -354,11 +352,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))); } @@ -382,7 +380,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)) @@ -408,7 +406,7 @@ usage: (progn BODY...) */) while (CONSP (args)) { - val = Feval (XCAR (args)); + val = eval_sub (XCAR (args)); args = XCDR (args); } @@ -438,9 +436,9 @@ usage: (prog1 FIRST BODY...) */) do { if (!(argnum++)) - val = Feval (Fcar (args_left)); + val = eval_sub (Fcar (args_left)); else - Feval (Fcar (args_left)); + eval_sub (Fcar (args_left)); args_left = Fcdr (args_left); } while (!NILP(args_left)); @@ -473,9 +471,9 @@ usage: (prog2 FORM1 FORM2 BODY...) */) do { if (!(argnum++)) - val = Feval (Fcar (args_left)); + val = eval_sub (Fcar (args_left)); else - Feval (Fcar (args_left)); + eval_sub (Fcar (args_left)); args_left = Fcdr (args_left); } while (!NILP (args_left)); @@ -507,10 +505,10 @@ usage: (setq [SYM VAL]...) */) do { - val = Feval (Fcar (Fcdr (args_left))); + val = eval_sub (Fcar (Fcdr (args_left))); sym = Fcar (args_left); - /* Like for Feval, we do not check declared_special here since + /* 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) @@ -870,7 +868,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. */ @@ -935,7 +933,7 @@ 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); @@ -1049,7 +1047,7 @@ usage: (let* VARLIST BODY...) */) else { var = Fcar (elt); - val = Feval (Fcar (Fcdr (elt))); + val = eval_sub (Fcar (Fcdr (elt))); } if (!NILP (lexenv) && SYMBOLP (var) @@ -1117,7 +1115,7 @@ 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; @@ -1166,7 +1164,7 @@ usage: (while TEST BODY...) */) test = Fcar (args); body = Fcdr (args); - while (!NILP (Feval (test))) + while (!NILP (eval_sub (test))) { QUIT; Fprogn (body); @@ -1268,7 +1266,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)); } @@ -1401,7 +1399,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); } @@ -1502,7 +1500,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; @@ -2316,6 +2314,16 @@ 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) +{ + int count = SPECPDL_INDEX (); + specbind (Qinternal_interpreter_environment, 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; @@ -2424,7 +2432,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; } @@ -2445,7 +2453,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; } @@ -2502,7 +2510,7 @@ DEFUN ("eval", Feval, Seval, 1, 1, 0, } } if (FUNVECP (fun)) - val = apply_lambda (fun, original_args, Qnil); + val = apply_lambda (fun, original_args); else { if (EQ (fun, Qunbound)) @@ -2518,20 +2526,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, - /* Only pass down the current lexical environment - if FUN is lexically embedded in FORM. */ - (CONSP (original_fun) - ? Vinternal_interpreter_environment - : Qnil)); - else if (EQ (funcar, Qclosure) - && CONSP (XCDR (fun)) - && CONSP (XCDR (XCDR (fun))) - && EQ (XCAR (XCDR (XCDR (fun))), Qlambda)) - val = apply_lambda (XCDR (XCDR (fun)), original_args, - XCAR (XCDR (fun))); + 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); } @@ -3189,7 +3187,7 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */) } if (FUNVECP (fun)) - val = funcall_lambda (fun, numargs, args + 1, Qnil); + val = funcall_lambda (fun, numargs, args + 1); else { if (EQ (fun, Qunbound)) @@ -3199,14 +3197,9 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */) funcar = XCAR (fun); if (!SYMBOLP (funcar)) xsignal1 (Qinvalid_function, original_fun); - if (EQ (funcar, Qlambda)) - val = funcall_lambda (fun, numargs, args + 1, Qnil); - else if (EQ (funcar, Qclosure) - && CONSP (XCDR (fun)) - && CONSP (XCDR (XCDR (fun))) - && EQ (XCAR (XCDR (XCDR (fun))), Qlambda)) - val = funcall_lambda (XCDR (XCDR (fun)), numargs, args + 1, - XCAR (XCDR (fun))); + if (EQ (funcar, Qlambda) + || EQ (funcar, Qclosure)) + val = funcall_lambda (fun, numargs, args + 1); else if (EQ (funcar, Qautoload)) { do_autoload (fun, original_fun); @@ -3226,7 +3219,7 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */) } static Lisp_Object -apply_lambda (Lisp_Object fun, Lisp_Object args, Lisp_Object lexenv) +apply_lambda (Lisp_Object fun, Lisp_Object args) { Lisp_Object args_left; Lisp_Object numargs; @@ -3246,7 +3239,7 @@ apply_lambda (Lisp_Object fun, Lisp_Object args, Lisp_Object lexenv) for (i = 0; i < XINT (numargs);) { tem = Fcar (args_left), args_left = Fcdr (args_left); - tem = Feval (tem); + tem = eval_sub (tem); arg_vector[i++] = tem; gcpro1.nvars = i; } @@ -3256,7 +3249,7 @@ apply_lambda (Lisp_Object fun, Lisp_Object args, Lisp_Object lexenv) backtrace_list->args = arg_vector; backtrace_list->nargs = i; backtrace_list->evalargs = 0; - tem = funcall_lambda (fun, XINT (numargs), arg_vector, lexenv); + tem = funcall_lambda (fun, XINT (numargs), arg_vector); /* Do the debug-on-exit now, while arg_vector still exists. */ if (backtrace_list->debug_on_exit) @@ -3321,10 +3314,9 @@ funcall_funvec (Lisp_Object fun, int nargs, Lisp_Object *args) static Lisp_Object funcall_lambda (Lisp_Object fun, int nargs, - register Lisp_Object *arg_vector, - Lisp_Object lexenv) + register Lisp_Object *arg_vector) { - Lisp_Object val, syms_left, next; + Lisp_Object val, syms_left, next, lexenv; int count = SPECPDL_INDEX (); int i, optional, rest; @@ -3358,6 +3350,14 @@ funcall_lambda (Lisp_Object fun, int nargs, if (CONSP (fun)) { + if (EQ (XCAR (fun), Qclosure)) + { + fun = XCDR (fun); /* Drop `closure'. */ + lexenv = XCAR (fun); + fun = XCDR (fun); /* Drop the lexical environment. */ + } + else + lexenv = Qnil; syms_left = XCDR (fun); if (CONSP (syms_left)) syms_left = XCAR (syms_left); @@ -3365,7 +3365,10 @@ funcall_lambda (Lisp_Object fun, int nargs, xsignal1 (Qinvalid_function, fun); } else if (COMPILEDP (fun)) - syms_left = AREF (fun, COMPILED_ARGLIST); + { + syms_left = AREF (fun, COMPILED_ARGLIST); + lexenv = Qnil; + } else abort (); @@ -3382,23 +3385,21 @@ funcall_lambda (Lisp_Object fun, int nargs, rest = 1; else if (EQ (next, Qand_optional)) optional = 1; - else if (rest) - { - specbind (next, Flist (nargs - i, &arg_vector[i])); - i = nargs; - } else { Lisp_Object val; - - /* Get the argument's actual value. */ - if (i < nargs) + 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) /* FIXME: there's no good reason to allow dynamic-scoping diff --git a/src/lisp.h b/src/lisp.h index aafa3884273..20b50632c49 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2972,6 +2972,7 @@ extern void signal_error (const char *, Lisp_Object) NO_RETURN; EXFUN (Fautoload, 5); EXFUN (Fcommandp, 2); EXFUN (Feval, 1); +extern Lisp_Object eval_sub (Lisp_Object form); EXFUN (Fapply, MANY); EXFUN (Ffuncall, MANY); EXFUN (Fbacktrace, 0); diff --git a/src/lread.c b/src/lread.c index d85d146b157..550b5f076f9 100644 --- a/src/lread.c +++ b/src/lread.c @@ -220,8 +220,7 @@ static Lisp_Object Vbytecomp_version_regexp; 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); @@ -1355,13 +1354,13 @@ Return t if the file exists and loads successfully. */) 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); @@ -1726,7 +1725,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) @@ -1872,7 +1870,7 @@ readevalloop (Lisp_Object readcharfun, unbind_to (count1, Qnil); /* Now eval what we just read. */ - val = (*evalfun) (val); + val = eval_sub (val); if (printflag) { @@ -1935,7 +1933,7 @@ This function preserves the position of point. */) BUF_TEMP_SET_PT (XBUFFER (buf), BUF_BEGV (XBUFFER (buf))); if (lisp_file_lexically_bound_p (buf)) Fset (Qlexical_binding, Qt); - readevalloop (buf, 0, filename, Feval, + readevalloop (buf, 0, filename, !NILP (printflag), unibyte, Qnil, Qnil, Qnil); unbind_to (count, Qnil); @@ -1969,7 +1967,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, XBUFFER (cbuf)->filename, Feval, + readevalloop (cbuf, 0, XBUFFER (cbuf)->filename, !NILP (printflag), Qnil, read_function, start, end); diff --git a/src/minibuf.c b/src/minibuf.c index 0f3def614f2..409f8a9a9ef 100644 --- a/src/minibuf.c +++ b/src/minibuf.c @@ -1026,6 +1026,7 @@ is a string to insert in the minibuffer before reading. Such arguments are used as in `read-from-minibuffer'.) */) (Lisp_Object prompt, Lisp_Object initial_contents) { + /* FIXME: lexbind. */ return Feval (read_minibuf (Vread_expression_map, initial_contents, prompt, Qnil, 1, Qread_expression_history, make_number (0), Qnil, 0, 0)); diff --git a/src/print.c b/src/print.c index 77cc2916952..41aa7fc4387 100644 --- a/src/print.c +++ b/src/print.c @@ -652,7 +652,7 @@ usage: (with-output-to-temp-buffer BUFNAME BODY...) */) Lisp_Object buf, val; GCPRO1(args); - name = Feval (Fcar (args)); + name = eval_sub (Fcar (args)); CHECK_STRING (name); temp_output_buffer_setup (SDATA (name)); buf = Vstandard_output; -- cgit v1.3 From a0ee6f2751acba71df443d4d795bb350eb6421dd Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 15 Dec 2010 12:46:59 -0500 Subject: Obey lexical-binding in interactive evaluation commands. * lisp/emacs-lisp/edebug.el (edebug-eval-defun, edebug-eval): * lisp/emacs-lisp/lisp-mode.el (eval-last-sexp-1, eval-defun-1): * lisp/ielm.el (ielm-eval-input): * lisp/simple.el (eval-expression): Use new eval arg to obey lexical-binding. * src/eval.c (Feval): Add `lexical' argument. Adjust callers. (Ffuncall, eval_sub): Avoid goto. --- lisp/ChangeLog | 7 ++ lisp/emacs-lisp/edebug.el | 17 +-- lisp/emacs-lisp/lisp-mode.el | 26 ++--- lisp/ielm.el | 3 +- lisp/simple.el | 4 +- src/ChangeLog | 5 + src/bytecode.c | 2 +- src/callint.c | 2 +- src/doc.c | 2 +- src/eval.c | 267 +++++++++++++++++++++---------------------- src/keyboard.c | 12 +- src/lisp.h | 2 +- src/minibuf.c | 4 +- 13 files changed, 184 insertions(+), 169 deletions(-) (limited to 'src/bytecode.c') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 053eb95329c..87794ceb5d2 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,10 @@ +2010-12-15 Stefan Monnier + + * emacs-lisp/edebug.el (edebug-eval-defun, edebug-eval): + * emacs-lisp/lisp-mode.el (eval-last-sexp-1, eval-defun-1): + * ielm.el (ielm-eval-input): + * simple.el (eval-expression): Use new eval arg to obey lexical-binding. + 2010-12-14 Stefan Monnier * emacs-lisp/bytecomp.el (byte-compile-condition-case): Use push. diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 77953b37021..4dfccb4c5b4 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -521,7 +521,7 @@ the minibuffer." ((and (eq (car form) 'defcustom) (default-boundp (nth 1 form))) ;; Force variable to be bound. - (set-default (nth 1 form) (eval (nth 2 form)))) + (set-default (nth 1 form) (eval (nth 2 form) lexical-binding))) ((eq (car form) 'defface) ;; Reset the face. (setq face-new-frame-defaults @@ -534,7 +534,7 @@ the minibuffer." (put ',(nth 1 form) 'customized-face ,(nth 2 form))) (put (nth 1 form) 'saved-face nil))))) - (setq edebug-result (eval form)) + (setq edebug-result (eval form lexical-binding)) (if (not edebugging) (princ edebug-result) edebug-result))) @@ -2466,6 +2466,7 @@ MSG is printed after `::::} '." (if edebug-global-break-condition (condition-case nil (setq edebug-global-break-result + ;; FIXME: lexbind. (eval edebug-global-break-condition)) (error nil)))) (edebug-break)) @@ -2477,6 +2478,7 @@ MSG is printed after `::::} '." (and edebug-break-data (or (not edebug-break-condition) (setq edebug-break-result + ;; FIXME: lexbind. (eval edebug-break-condition)))))) (if (and edebug-break (nth 2 edebug-break-data)) ; is it temporary? @@ -3637,9 +3639,10 @@ Return the result of the last expression." (defun edebug-eval (edebug-expr) ;; Are there cl lexical variables active? - (if (bound-and-true-p cl-debug-env) - (eval (cl-macroexpand-all edebug-expr cl-debug-env)) - (eval edebug-expr))) + (eval (if (bound-and-true-p cl-debug-env) + (cl-macroexpand-all edebug-expr cl-debug-env) + edebug-expr) + lexical-binding)) ;; FIXME: lexbind. (defun edebug-safe-eval (edebug-expr) ;; Evaluate EXPR safely. @@ -4241,8 +4244,8 @@ It is removed when you hit any char." ;;; Menus (defun edebug-toggle (variable) - (set variable (not (eval variable))) - (message "%s: %s" variable (eval variable))) + (set variable (not (symbol-value variable))) + (message "%s: %s" variable (symbol-value variable))) ;; We have to require easymenu (even for Emacs 18) just so ;; the easy-menu-define macro call is compiled correctly. diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index c90d1394978..2cdbd115928 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -699,16 +699,9 @@ If CHAR is not a character, return nil." (defun eval-last-sexp-1 (eval-last-sexp-arg-internal) "Evaluate sexp before point; print value in minibuffer. With argument, print output into current buffer." - (let ((standard-output (if eval-last-sexp-arg-internal (current-buffer) t)) - ;; preserve the current lexical environment - (internal-interpreter-environment internal-interpreter-environment)) + (let ((standard-output (if eval-last-sexp-arg-internal (current-buffer) t))) ;; Setup the lexical environment if lexical-binding is enabled. - ;; Note that `internal-interpreter-environment' _can't_ be both - ;; assigned and let-bound above -- it's treated specially (and - ;; oddly) by the interpreter! - (when lexical-binding - (setq internal-interpreter-environment '(t))) - (eval-last-sexp-print-value (eval (preceding-sexp))))) + (eval-last-sexp-print-value (eval (preceding-sexp) lexical-binding)))) (defun eval-last-sexp-print-value (value) @@ -772,16 +765,18 @@ Reinitialize the face according to the `defface' specification." ;; `defcustom' is now macroexpanded to ;; `custom-declare-variable' with a quoted value arg. ((and (eq (car form) 'custom-declare-variable) - (default-boundp (eval (nth 1 form)))) + (default-boundp (eval (nth 1 form) lexical-binding))) ;; Force variable to be bound. - (set-default (eval (nth 1 form)) (eval (nth 1 (nth 2 form)))) + (set-default (eval (nth 1 form) lexical-binding) + (eval (nth 1 (nth 2 form)) lexical-binding)) form) ;; `defface' is macroexpanded to `custom-declare-face'. ((eq (car form) 'custom-declare-face) ;; Reset the face. (setq face-new-frame-defaults - (assq-delete-all (eval (nth 1 form)) face-new-frame-defaults)) - (put (eval (nth 1 form)) 'face-defface-spec nil) + (assq-delete-all (eval (nth 1 form) lexical-binding) + face-new-frame-defaults)) + (put (eval (nth 1 form) lexical-binding) 'face-defface-spec nil) ;; Setting `customized-face' to the new spec after calling ;; the form, but preserving the old saved spec in `saved-face', ;; imitates the situation when the new face spec is set @@ -792,10 +787,11 @@ Reinitialize the face according to the `defface' specification." ;; `defface' change the spec, regardless of a saved spec. (prog1 `(prog1 ,form (put ,(nth 1 form) 'saved-face - ',(get (eval (nth 1 form)) 'saved-face)) + ',(get (eval (nth 1 form) lexical-binding) + 'saved-face)) (put ,(nth 1 form) 'customized-face ,(nth 2 form))) - (put (eval (nth 1 form)) 'saved-face nil))) + (put (eval (nth 1 form) lexical-binding) 'saved-face nil))) ((eq (car form) 'progn) (cons 'progn (mapcar 'eval-defun-1 (cdr form)))) (t form))) diff --git a/lisp/ielm.el b/lisp/ielm.el index 40e87cd6709..e1f8dc78d32 100644 --- a/lisp/ielm.el +++ b/lisp/ielm.el @@ -372,7 +372,8 @@ simply inserts a newline." (*** *3)) (kill-buffer (current-buffer)) (set-buffer ielm-wbuf) - (setq ielm-result (eval ielm-form)) + (setq ielm-result + (eval ielm-form lexical-binding)) (setq ielm-wbuf (current-buffer)) (setq ielm-temp-buffer diff --git a/lisp/simple.el b/lisp/simple.el index da8ac55c01d..a977be7cf8e 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -1212,12 +1212,12 @@ this command arranges for all errors to enter the debugger." current-prefix-arg)) (if (null eval-expression-debug-on-error) - (setq values (cons (eval eval-expression-arg) values)) + (push (eval eval-expression-arg lexical-binding) values) (let ((old-value (make-symbol "t")) new-value) ;; Bind debug-on-error to something unique so that we can ;; detect when evaled code changes it. (let ((debug-on-error old-value)) - (setq values (cons (eval eval-expression-arg) values)) + (push (eval eval-expression-arg lexical-binding) values) (setq new-value debug-on-error)) ;; If evaled code has changed the value of debug-on-error, ;; propagate that change to the global binding. diff --git a/src/ChangeLog b/src/ChangeLog index c333b6388c6..2de6a5ed66c 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,8 @@ +2010-12-15 Stefan Monnier + + * eval.c (Feval): Add `lexical' argument. Adjust callers. + (Ffuncall, eval_sub): Avoid goto. + 2010-12-14 Stefan Monnier Try and be more careful about propagation of lexical environment. diff --git a/src/bytecode.c b/src/bytecode.c index 01fce0577b0..eb12b9c4963 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -915,7 +915,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, Lisp_Object v1; BEFORE_POTENTIAL_GC (); v1 = POP; - TOP = internal_catch (TOP, Feval, v1); /* FIXME: lexbind */ + TOP = internal_catch (TOP, eval_sub, v1); /* FIXME: lexbind */ AFTER_POTENTIAL_GC (); break; } diff --git a/src/callint.c b/src/callint.c index 960158029c3..5eb65b31cbf 100644 --- a/src/callint.c +++ b/src/callint.c @@ -342,7 +342,7 @@ invoke it. If KEYS is omitted or nil, the return value of input = specs; /* Compute the arg values using the user's expression. */ GCPRO2 (input, filter_specs); - specs = Feval (specs); /* FIXME: lexbind */ + specs = Feval (specs, Qnil); /* FIXME: lexbind */ UNGCPRO; if (i != num_input_events || !NILP (record_flag)) { diff --git a/src/doc.c b/src/doc.c index b887b3149bc..8ae152dca9a 100644 --- a/src/doc.c +++ b/src/doc.c @@ -490,7 +490,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); diff --git a/src/eval.c b/src/eval.c index 485ba00c1e4..7104a8a8396 100644 --- a/src/eval.c +++ b/src/eval.c @@ -2311,12 +2311,14 @@ 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, Qnil); + specbind (Qinternal_interpreter_environment, + NILP (lexical) ? Qnil : Fcons (Qt, Qnil)); return unbind_to (count, eval_sub (form)); } @@ -2414,10 +2416,8 @@ eval_sub (Lisp_Object form) { backtrace.evalargs = 0; val = (XSUBR (fun)->function.aUNEVALLED) (args_left); - goto done; } - - if (XSUBR (fun)->max_args == MANY) + else if (XSUBR (fun)->max_args == MANY) { /* Pass a vector of evaluated arguments */ Lisp_Object *vals; @@ -2443,73 +2443,74 @@ eval_sub (Lisp_Object form) val = (XSUBR (fun)->function.aMANY) (XINT (numargs), vals); UNGCPRO; SAFE_FREE (); - goto done; } - - GCPRO3 (args_left, fun, fun); - gcpro3.var = argvals; - gcpro3.nvars = 0; - - maxargs = XSUBR (fun)->max_args; - for (i = 0; i < maxargs; args_left = Fcdr (args_left)) + else { - argvals[i] = eval_sub (Fcar (args_left)); - gcpro3.nvars = ++i; - } - - UNGCPRO; + GCPRO3 (args_left, fun, fun); + gcpro3.var = argvals; + gcpro3.nvars = 0; + + maxargs = XSUBR (fun)->max_args; + for (i = 0; i < maxargs; args_left = Fcdr (args_left)) + { + argvals[i] = eval_sub (Fcar (args_left)); + gcpro3.nvars = ++i; + } + + UNGCPRO; - backtrace.args = argvals; - backtrace.nargs = XINT (numargs); + backtrace.args = argvals; + backtrace.nargs = XINT (numargs); - switch (i) - { - case 0: - val = (XSUBR (fun)->function.a0) (); - goto done; - case 1: - val = (XSUBR (fun)->function.a1) (argvals[0]); - goto done; - case 2: - val = (XSUBR (fun)->function.a2) (argvals[0], argvals[1]); - goto done; - case 3: - val = (XSUBR (fun)->function.a3) (argvals[0], argvals[1], - argvals[2]); - goto done; - case 4: - val = (XSUBR (fun)->function.a4) (argvals[0], argvals[1], - argvals[2], argvals[3]); - goto done; - case 5: - val = (XSUBR (fun)->function.a5) (argvals[0], argvals[1], argvals[2], - argvals[3], argvals[4]); - goto done; - case 6: - val = (XSUBR (fun)->function.a6) (argvals[0], argvals[1], argvals[2], - argvals[3], argvals[4], argvals[5]); - goto done; - case 7: - val = (XSUBR (fun)->function.a7) (argvals[0], argvals[1], argvals[2], - argvals[3], argvals[4], argvals[5], - argvals[6]); - goto done; - - case 8: - val = (XSUBR (fun)->function.a8) (argvals[0], argvals[1], argvals[2], - argvals[3], argvals[4], argvals[5], - argvals[6], argvals[7]); - goto done; - - default: - /* Someone has created a subr that takes more arguments than - is supported by this code. We need to either rewrite the - subr to use a different argument protocol, or add more - cases to this switch. */ - abort (); + switch (i) + { + case 0: + val = (XSUBR (fun)->function.a0) (); + break; + case 1: + val = (XSUBR (fun)->function.a1) (argvals[0]); + break; + case 2: + val = (XSUBR (fun)->function.a2) (argvals[0], argvals[1]); + break; + case 3: + val = (XSUBR (fun)->function.a3) (argvals[0], argvals[1], + argvals[2]); + break; + case 4: + val = (XSUBR (fun)->function.a4) (argvals[0], argvals[1], + argvals[2], argvals[3]); + break; + case 5: + val = (XSUBR (fun)->function.a5) (argvals[0], argvals[1], argvals[2], + argvals[3], argvals[4]); + break; + case 6: + val = (XSUBR (fun)->function.a6) (argvals[0], argvals[1], argvals[2], + argvals[3], argvals[4], argvals[5]); + break; + case 7: + val = (XSUBR (fun)->function.a7) (argvals[0], argvals[1], argvals[2], + argvals[3], argvals[4], argvals[5], + argvals[6]); + + break; + case 8: + val = (XSUBR (fun)->function.a8) (argvals[0], argvals[1], argvals[2], + argvals[3], argvals[4], argvals[5], + argvals[6], argvals[7]); + + break; + default: + /* Someone has created a subr that takes more arguments than + is supported by this code. We need to either rewrite the + subr to use a different argument protocol, or add more + cases to this switch. */ + abort (); + } } } - if (FUNVECP (fun)) + else if (FUNVECP (fun)) val = apply_lambda (fun, original_args); else { @@ -2533,7 +2534,6 @@ eval_sub (Lisp_Object form) else xsignal1 (Qinvalid_function, original_fun); } - done: CHECK_CONS_LIST (); lisp_eval_depth--; @@ -3109,7 +3109,7 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */) if (SUBRP (fun)) { - if (numargs < XSUBR (fun)->min_args + if (numargs < XSUBR (fun)->min_args || (XSUBR (fun)->max_args >= 0 && XSUBR (fun)->max_args < numargs)) { XSETFASTINT (lisp_numargs, numargs); @@ -3119,74 +3119,72 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */) if (XSUBR (fun)->max_args == UNEVALLED) xsignal1 (Qinvalid_function, original_fun); - if (XSUBR (fun)->max_args == MANY) - { - val = (XSUBR (fun)->function.aMANY) (numargs, args + 1); - goto done; - } - - if (XSUBR (fun)->max_args > numargs) - { - internal_args = (Lisp_Object *) alloca (XSUBR (fun)->max_args * sizeof (Lisp_Object)); - memcpy (internal_args, args + 1, numargs * sizeof (Lisp_Object)); - for (i = numargs; i < XSUBR (fun)->max_args; i++) - internal_args[i] = Qnil; - } + else if (XSUBR (fun)->max_args == MANY) + val = (XSUBR (fun)->function.aMANY) (numargs, args + 1); else - internal_args = args + 1; - switch (XSUBR (fun)->max_args) { - case 0: - val = (XSUBR (fun)->function.a0) (); - goto done; - case 1: - val = (XSUBR (fun)->function.a1) (internal_args[0]); - goto done; - case 2: - val = (XSUBR (fun)->function.a2) (internal_args[0], internal_args[1]); - goto done; - case 3: - val = (XSUBR (fun)->function.a3) (internal_args[0], internal_args[1], - internal_args[2]); - goto done; - case 4: - val = (XSUBR (fun)->function.a4) (internal_args[0], internal_args[1], - internal_args[2], internal_args[3]); - goto done; - case 5: - val = (XSUBR (fun)->function.a5) (internal_args[0], internal_args[1], - internal_args[2], internal_args[3], - internal_args[4]); - goto done; - case 6: - val = (XSUBR (fun)->function.a6) (internal_args[0], internal_args[1], - internal_args[2], internal_args[3], - internal_args[4], internal_args[5]); - goto done; - case 7: - val = (XSUBR (fun)->function.a7) (internal_args[0], internal_args[1], - internal_args[2], internal_args[3], - internal_args[4], internal_args[5], - internal_args[6]); - goto done; - - case 8: - val = (XSUBR (fun)->function.a8) (internal_args[0], internal_args[1], - internal_args[2], internal_args[3], - internal_args[4], internal_args[5], - internal_args[6], internal_args[7]); - goto done; - - default: - - /* If a subr takes more than 8 arguments without using MANY - or UNEVALLED, we need to extend this function to support it. - Until this is done, there is no way to call the function. */ - abort (); + if (XSUBR (fun)->max_args > numargs) + { + internal_args = (Lisp_Object *) alloca (XSUBR (fun)->max_args * sizeof (Lisp_Object)); + memcpy (internal_args, args + 1, numargs * sizeof (Lisp_Object)); + for (i = numargs; i < XSUBR (fun)->max_args; i++) + internal_args[i] = Qnil; + } + else + internal_args = args + 1; + switch (XSUBR (fun)->max_args) + { + case 0: + val = (XSUBR (fun)->function.a0) (); + break; + case 1: + val = (XSUBR (fun)->function.a1) (internal_args[0]); + break; + case 2: + val = (XSUBR (fun)->function.a2) (internal_args[0], internal_args[1]); + break; + case 3: + val = (XSUBR (fun)->function.a3) (internal_args[0], internal_args[1], + internal_args[2]); + break; + case 4: + val = (XSUBR (fun)->function.a4) (internal_args[0], internal_args[1], + internal_args[2], internal_args[3]); + break; + case 5: + val = (XSUBR (fun)->function.a5) (internal_args[0], internal_args[1], + internal_args[2], internal_args[3], + internal_args[4]); + break; + case 6: + val = (XSUBR (fun)->function.a6) (internal_args[0], internal_args[1], + internal_args[2], internal_args[3], + internal_args[4], internal_args[5]); + break; + case 7: + val = (XSUBR (fun)->function.a7) (internal_args[0], internal_args[1], + internal_args[2], internal_args[3], + internal_args[4], internal_args[5], + internal_args[6]); + break; + + case 8: + val = (XSUBR (fun)->function.a8) (internal_args[0], internal_args[1], + internal_args[2], internal_args[3], + internal_args[4], internal_args[5], + internal_args[6], internal_args[7]); + break; + + default: + + /* If a subr takes more than 8 arguments without using MANY + or UNEVALLED, we need to extend this function to support it. + Until this is done, there is no way to call the function. */ + abort (); + } } } - - if (FUNVECP (fun)) + else if (FUNVECP (fun)) val = funcall_lambda (fun, numargs, args + 1); else { @@ -3209,7 +3207,6 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */) else xsignal1 (Qinvalid_function, original_fun); } - done: CHECK_CONS_LIST (); lisp_eval_depth--; if (backtrace.debug_on_exit) diff --git a/src/keyboard.c b/src/keyboard.c index 17819170640..df69c526f71 100644 --- a/src/keyboard.c +++ b/src/keyboard.c @@ -1327,7 +1327,7 @@ command_loop_2 (Lisp_Object ignore) Lisp_Object top_level_2 (void) { - return Feval (Vtop_level); + return Feval (Vtop_level, Qnil); } Lisp_Object @@ -3255,7 +3255,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); @@ -7696,6 +7696,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 @@ -7704,7 +7710,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 20b50632c49..db78996be55 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2971,7 +2971,7 @@ extern void xsignal3 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object) NO_RET extern void signal_error (const char *, Lisp_Object) NO_RETURN; EXFUN (Fautoload, 5); EXFUN (Fcommandp, 2); -EXFUN (Feval, 1); +EXFUN (Feval, 2); extern Lisp_Object eval_sub (Lisp_Object form); EXFUN (Fapply, MANY); EXFUN (Ffuncall, MANY); diff --git a/src/minibuf.c b/src/minibuf.c index 409f8a9a9ef..9dd32a8bab4 100644 --- a/src/minibuf.c +++ b/src/minibuf.c @@ -1026,10 +1026,10 @@ is a string to insert in the minibuffer before reading. Such arguments are used as in `read-from-minibuffer'.) */) (Lisp_Object prompt, Lisp_Object initial_contents) { - /* FIXME: lexbind. */ 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. */ -- cgit v1.3 From ce5b520a3758e22c6516e0d864d8c1a3512bf457 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Sat, 12 Feb 2011 00:53:30 -0500 Subject: * lisp/emacs-lisp/byte-lexbind.el: Delete. * lisp/emacs-lisp/bytecomp.el (byte-compile-current-heap-environment) (byte-compile-current-num-closures): Remove vars. (byte-vec-ref, byte-vec-set): Remove byte codes. (byte-compile-arglist-vars, byte-compile-make-lambda-lexenv): Move from byte-lexbind.el. (byte-compile-lambda): Never build a closure. (byte-compile-closure-code-p, byte-compile-make-closure): Remove. (byte-compile-closure): Simplify. (byte-compile-top-level): Don't mess with heap environments. (byte-compile-dynamic-variable-bind): Always maintain byte-compile-bound-variables. (byte-compile-variable-ref, byte-compile-variable-set): Always just use the stack for lexical vars. (byte-compile-push-binding-init): Simplify. (byte-compile-not-lexical-var-p): New function, moved from cconv.el. (byte-compile-bind, byte-compile-unbind): New functions, moved and simplified from byte-lexbind.el. (byte-compile-let, byte-compile-let*): Simplify. (byte-compile-condition-case): Don't add :fun-body to the bound vars. (byte-compile-defmacro): Simplify. * lisp/emacs-lisp/byte-opt.el (byte-compile-side-effect-free-ops) (byte-optimize-lapcode): Remove byte-vec-ref and byte-vec-set. * lisp/emacs-lisp/cconv.el (cconv-not-lexical-var-p): Remove. (cconv-freevars, cconv-analyse-function, cconv-analyse-form): Use byte-compile-not-lexical-var-p instead. * src/bytecode.c (Bvec_ref, Bvec_set): Remove. (exec_byte_code): Don't handle them. * lisp/help-fns.el (describe-function-1): Fix paren typo. --- lisp/ChangeLog | 34 ++ lisp/emacs-lisp/byte-lexbind.el | 699 ---------------------------------------- lisp/emacs-lisp/byte-opt.el | 4 +- lisp/emacs-lisp/bytecomp.el | 553 +++++++++++++------------------ lisp/emacs-lisp/cconv.el | 19 +- lisp/help-fns.el | 34 +- src/ChangeLog | 5 + src/bytecode.c | 23 -- 8 files changed, 283 insertions(+), 1088 deletions(-) delete mode 100644 lisp/emacs-lisp/byte-lexbind.el (limited to 'src/bytecode.c') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index c3451d9b269..b972f17909a 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,37 @@ +2011-02-12 Stefan Monnier + + * emacs-lisp/byte-lexbind.el: Delete. + + * emacs-lisp/bytecomp.el (byte-compile-current-heap-environment) + (byte-compile-current-num-closures): Remove vars. + (byte-vec-ref, byte-vec-set): Remove byte codes. + (byte-compile-arglist-vars, byte-compile-make-lambda-lexenv): Move from + byte-lexbind.el. + (byte-compile-lambda): Never build a closure. + (byte-compile-closure-code-p, byte-compile-make-closure): Remove. + (byte-compile-closure): Simplify. + (byte-compile-top-level): Don't mess with heap environments. + (byte-compile-dynamic-variable-bind): Always maintain + byte-compile-bound-variables. + (byte-compile-variable-ref, byte-compile-variable-set): Always just use + the stack for lexical vars. + (byte-compile-push-binding-init): Simplify. + (byte-compile-not-lexical-var-p): New function, moved from cconv.el. + (byte-compile-bind, byte-compile-unbind): New functions, moved and + simplified from byte-lexbind.el. + (byte-compile-let, byte-compile-let*): Simplify. + (byte-compile-condition-case): Don't add :fun-body to the bound vars. + (byte-compile-defmacro): Simplify. + + * emacs-lisp/cconv.el (cconv-not-lexical-var-p): Remove. + (cconv-freevars, cconv-analyse-function, cconv-analyse-form): + Use byte-compile-not-lexical-var-p instead. + + * help-fns.el (describe-function-1): Fix paren typo. + + * emacs-lisp/byte-opt.el (byte-compile-side-effect-free-ops) + (byte-optimize-lapcode): Remove byte-vec-ref and byte-vec-set. + 2011-02-11 Stefan Monnier * emacs-lisp/cconv.el (cconv-closure-convert): Drop `toplevel' arg. diff --git a/lisp/emacs-lisp/byte-lexbind.el b/lisp/emacs-lisp/byte-lexbind.el deleted file mode 100644 index 06353e2eea8..00000000000 --- a/lisp/emacs-lisp/byte-lexbind.el +++ /dev/null @@ -1,699 +0,0 @@ -;;; byte-lexbind.el --- Lexical binding support for byte-compiler -;; -;; Copyright (C) 2001, 2002, 2010, 2011 Free Software Foundation, Inc. -;; -;; Author: Miles Bader -;; Keywords: lisp, compiler, lexical binding - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 3, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: -;; - -;;; Code: - -(require 'bytecomp-preload "bytecomp") - -;; Downward closures aren't implemented yet, so this should always be nil -(defconst byte-compile-use-downward-closures nil - "If true, use `downward closures', which are closures that don't cons.") - -(defconst byte-compile-save-window-excursion-uses-eval t - "If true, the bytecode for `save-window-excursion' uses eval. -This means that the body of the form must be put into a closure.") - -(defun byte-compile-arglist-vars (arglist) - "Return a list of the variables in the lambda argument list ARGLIST." - (remq '&rest (remq '&optional arglist))) - - -;;; Variable extent analysis. - -;; A `lforminfo' holds information about lexical bindings in a form, and some -;; other info for analysis. It is a cons-cell, where the car is a list of -;; `lvarinfo' stuctures, which form an alist indexed by variable name, and the -;; cdr is the number of closures found in the form: -;; -;; LFORMINFO : ((LVARINFO ...) . NUM-CLOSURES)" -;; -;; A `lvarinfo' holds information about a single lexical variable. It is a -;; list whose car is the variable name (so an lvarinfo is suitable as an alist -;; entry), and the rest of the of which holds information about the variable: -;; -;; LVARINFO : (VAR NUM-REFS NUM-SETS CLOSED-OVER) -;; -;; NUM-REFS is the number of times the variable's value is used -;; NUM-SETS is the number of times the variable's value is set -;; CLOSED-OVER is non-nil if the variable is referenced -;; anywhere but in its original function-level" - -;;; lvarinfo: - -;; constructor -(defsubst byte-compile-make-lvarinfo (var &optional already-set) - (list var 0 (if already-set 1 0) 0 nil)) -;; accessors -(defsubst byte-compile-lvarinfo-var (vinfo) (car vinfo)) -(defsubst byte-compile-lvarinfo-num-refs (vinfo) (cadr vinfo)) -(defsubst byte-compile-lvarinfo-num-sets (vinfo) (nth 3 vinfo)) -(defsubst byte-compile-lvarinfo-closed-over-p (vinfo) (nth 4 vinfo)) -;; setters -(defsubst byte-compile-lvarinfo-note-ref (vinfo) - (setcar (cdr vinfo) (1+ (cadr vinfo)))) -(defsubst byte-compile-lvarinfo-note-set (vinfo) - (setcar (cddr vinfo) (1+ (nth 3 vinfo)))) -(defsubst byte-compile-lvarinfo-note-closure (vinfo) - (setcar (nthcdr 4 vinfo) t)) - -;;; lforminfo: - -;; constructor -(defsubst byte-compile-make-lforminfo () - (cons nil 0)) -;; accessors -(defalias 'byte-compile-lforminfo-vars 'car) -(defalias 'byte-compile-lforminfo-num-closures 'cdr) -;; setters -(defsubst byte-compile-lforminfo-add-var (finfo var &optional already-set) - (setcar finfo (cons (byte-compile-make-lvarinfo var already-set) - (car finfo)))) - -(defun byte-compile-lforminfo-make-closure-flag () - "Return a new `closure-flag'." - (cons nil nil)) - -(defsubst byte-compile-lforminfo-note-closure (lforminfo lvarinfo closure-flag) - "If a variable reference or definition is inside a closure, record that fact. -LFORMINFO describes the form currently being analyzed, and LVARINFO -describes the variable. CLOSURE-FLAG is either nil, if currently _not_ -inside a closure, and otherwise a `closure flag' returned by -`byte-compile-lforminfo-make-closure-flag'." - (when closure-flag - (byte-compile-lvarinfo-note-closure lvarinfo) - (unless (car closure-flag) - (setcdr lforminfo (1+ (cdr lforminfo))) - (setcar closure-flag t)))) - -(defun byte-compile-compute-lforminfo (form &optional special) - "Return information about variables lexically bound by FORM. -SPECIAL is a list of variables that are special, and so shouldn't be -bound lexically (in addition to variable that are considered special -because they are declared with `defvar', et al). - -The result is an `lforminfo' data structure." - (and - (consp form) - (let ((lforminfo (byte-compile-make-lforminfo))) - (cond ((eq (car form) 'let) - ;; Find the bound variables - (dolist (clause (cadr form)) - (let ((var (if (consp clause) (car clause) clause))) - (unless (or (special-variable-p var) (memq var special)) - (byte-compile-lforminfo-add-var lforminfo var t)))) - ;; Analyze the body - (unless (null (byte-compile-lforminfo-vars lforminfo)) - (byte-compile-lforminfo-analyze-forms lforminfo form 2 - special nil))) - ((eq (car form) 'let*) - (dolist (clause (cadr form)) - (let ((var (if (consp clause) (car clause) clause))) - ;; Analyze each initializer based on the previously - ;; bound variables. - (when (and (consp clause) lforminfo) - (byte-compile-lforminfo-analyze lforminfo (cadr clause) - special nil)) - (unless (or (special-variable-p var) (memq var special)) - (byte-compile-lforminfo-add-var lforminfo var t)))) - ;; Analyze the body - (unless (null (byte-compile-lforminfo-vars lforminfo)) - (byte-compile-lforminfo-analyze-forms lforminfo form 2 - special nil))) - ((eq (car form) 'condition-case) - ;; `condition-case' currently must dynamically bind the - ;; error variable, so do nothing. - ) - ((memq (car form) '(defun defmacro)) - (byte-compile-lforminfo-from-lambda lforminfo (cdr form) special)) - ((eq (car form) 'lambda) - (byte-compile-lforminfo-from-lambda lforminfo form special)) - ((and (consp (car form)) (eq (caar form) 'lambda)) - ;; An embedded lambda, which is basically just a `let' - (byte-compile-lforminfo-from-lambda lforminfo (cdr form) special))) - (if (byte-compile-lforminfo-vars lforminfo) - lforminfo - nil)))) - -(defun byte-compile-lforminfo-from-lambda (lforminfo lambda special) - "Initialize LFORMINFO from the lambda expression LAMBDA. -SPECIAL is a list of variables to ignore. -The first element of LAMBDA is ignored; it need not actually be `lambda'." - ;; Add the arguments - (dolist (arg (byte-compile-arglist-vars (cadr lambda))) - (byte-compile-lforminfo-add-var lforminfo arg t)) - ;; Analyze the body - (unless (null (byte-compile-lforminfo-vars lforminfo)) - (byte-compile-lforminfo-analyze-forms lforminfo lambda 2 special nil))) - -(defun byte-compile-lforminfo-analyze (lforminfo form &optional ignore closure-flag) - "Update variable information in LFORMINFO by analyzing FORM. -IGNORE is a list of variables that shouldn't be analyzed (usually because -they're special, or because some inner binding shadows the version in -LFORMINFO). CLOSURE-FLAG should be either nil or a `closure flag' created -with `byte-compile-lforminfo-make-closure-flag'; the latter indicates that -FORM is inside a lambda expression that may close over some variable in -LFORMINFO." - (cond ((symbolp form) - ;; variable reference - (unless (member form ignore) - (let ((vinfo (assq form (byte-compile-lforminfo-vars lforminfo)))) - (when vinfo - (byte-compile-lvarinfo-note-ref vinfo) - (byte-compile-lforminfo-note-closure lforminfo vinfo - closure-flag))))) - ;; function call/special form - ((consp form) - (let ((fun (car form))) - (cond - ((eq fun 'setq) - (pop form) - (while form - (let ((var (pop form))) - (byte-compile-lforminfo-analyze lforminfo (pop form) - ignore closure-flag) - (unless (member var ignore) - (let ((vinfo - (assq var (byte-compile-lforminfo-vars lforminfo)))) - (when vinfo - (byte-compile-lvarinfo-note-set vinfo) - (byte-compile-lforminfo-note-closure lforminfo vinfo - closure-flag))))))) - ((and (eq fun 'catch) (not (eq :fun-body (nth 2 form)))) - ;; tag - (byte-compile-lforminfo-analyze lforminfo (cadr form) - ignore closure-flag) - ;; `catch' uses a closure for the body - (byte-compile-lforminfo-analyze-forms - lforminfo form 2 - ignore - (or closure-flag - (and (not byte-compile-use-downward-closures) - (byte-compile-lforminfo-make-closure-flag))))) - ((eq fun 'cond) - (byte-compile-lforminfo-analyze-clauses lforminfo (cdr form) 0 - ignore closure-flag)) - ((eq fun 'condition-case) - ;; `condition-case' separates its body/handlers into - ;; separate closures. - (unless (or (eq (nth 1 form) :fun-body) - closure-flag byte-compile-use-downward-closures) - ;; condition case is implemented by calling a function - (setq closure-flag (byte-compile-lforminfo-make-closure-flag))) - ;; value form - (byte-compile-lforminfo-analyze lforminfo (nth 2 form) - ignore closure-flag) - ;; the error variable is always bound dynamically (because - ;; of the implementation) - (when (cadr form) - (push (cadr form) ignore)) - ;; handlers - (byte-compile-lforminfo-analyze-clauses lforminfo - (nthcdr 2 form) 1 - ignore closure-flag)) - ((eq fun '(defvar defconst)) - (byte-compile-lforminfo-analyze lforminfo (nth 2 form) - ignore closure-flag)) - ((memq fun '(defun defmacro)) - (byte-compile-lforminfo-analyze-forms lforminfo form 3 - ignore closure-flag)) - ((eq fun 'function) - ;; Analyze an embedded lambda expression [note: we only recognize - ;; it within (function ...) as the (lambda ...) for is actually a - ;; macro returning (function (lambda ...))]. - (when (and (consp (cadr form)) (eq (car (cadr form)) 'lambda)) - ;; shadow bound variables - (setq ignore - (append (byte-compile-arglist-vars (cadr (cadr form))) - ignore)) - ;; analyze body of lambda - (byte-compile-lforminfo-analyze-forms - lforminfo (cadr form) 2 - ignore - (or closure-flag - (byte-compile-lforminfo-make-closure-flag))))) - ((eq fun 'let) - ;; analyze variable inits - (byte-compile-lforminfo-analyze-clauses lforminfo (cadr form) 1 - ignore closure-flag) - ;; shadow bound variables - (dolist (clause (cadr form)) - (push (if (symbolp clause) clause (car clause)) - ignore)) - ;; analyze body - (byte-compile-lforminfo-analyze-forms lforminfo form 2 - ignore closure-flag)) - ((eq fun 'let*) - (dolist (clause (cadr form)) - (if (symbolp clause) - ;; shadow bound (to nil) variable - (push clause ignore) - ;; analyze variable init - (byte-compile-lforminfo-analyze lforminfo (cadr clause) - ignore closure-flag) - ;; shadow bound variable - (push (car clause) ignore))) - ;; analyze body - (byte-compile-lforminfo-analyze-forms lforminfo form 2 - ignore closure-flag)) - ((eq fun 'quote) - ;; do nothing - ) - ((and (eq fun 'save-window-excursion) - (not (eq :fun-body (nth 1 form)))) - ;; `save-window-excursion' currently uses a funny implementation - ;; that requires its body forms be put into a closure (it should - ;; be fixed to work more like `save-excursion' etc., do). - (byte-compile-lforminfo-analyze-forms - lforminfo form 2 - ignore - (or closure-flag - (and byte-compile-save-window-excursion-uses-eval - (not byte-compile-use-downward-closures) - (byte-compile-lforminfo-make-closure-flag))))) - ((and (consp fun) (eq (car fun) 'lambda)) - ;; Embedded lambda. These are inlined by the compiler, so - ;; we don't treat them like a real closure, more like `let'. - ;; analyze inits - (byte-compile-lforminfo-analyze-forms lforminfo form 2 - ignore closure-flag) - - ;; shadow bound variables - (setq ignore (nconc (byte-compile-arglist-vars (cadr fun)) - ignore)) - ;; analyze body - (byte-compile-lforminfo-analyze-forms lforminfo fun 2 - ignore closure-flag)) - (t - ;; For everything else, we just expand each argument (for - ;; setq/setq-default this works alright because the - ;; variable names are symbols). - (byte-compile-lforminfo-analyze-forms lforminfo form 1 - ignore closure-flag))))))) - -(defun byte-compile-lforminfo-analyze-forms - (lforminfo forms skip ignore closure-flag) - "Update variable information in LFORMINFO by analyzing each form in FORMS. -The first SKIP elements of FORMS are skipped without analysis. IGNORE -is a list of variables that shouldn't be analyzed (usually because -they're special, or because some inner binding shadows the version in -LFORMINFO). CLOSURE-FLAG should be either nil or a `closure flag' created with -`byte-compile-lforminfo-make-closure-flag'; the latter indicates that FORM is -inside a lambda expression that may close over some variable in LFORMINFO." - (when skip - (setq forms (nthcdr skip forms))) - (while forms - (byte-compile-lforminfo-analyze lforminfo (pop forms) - ignore closure-flag))) - -(defun byte-compile-lforminfo-analyze-clauses - (lforminfo clauses skip ignore closure-flag) - "Update variable information in LFORMINFO by analyzing each clause in CLAUSES. -Each clause is a list of forms; any clause that's not a list is ignored. The -first SKIP elements of each clause are skipped without analysis. IGNORE is a -list of variables that shouldn't be analyzed (usually because they're special, -or because some inner binding shadows the version in LFORMINFO). -CLOSURE-FLAG should be either nil or a `closure flag' created with -`byte-compile-lforminfo-make-closure-flag'; the latter indicates that FORM is -inside a lambda expression that may close over some variable in LFORMINFO." - (while clauses - (let ((clause (pop clauses))) - (when (consp clause) - (byte-compile-lforminfo-analyze-forms lforminfo clause skip - ignore closure-flag))))) - - -;;; Lexical environments - -;; A lexical environment is an alist, where each element is of the form -;; (VAR . (OFFSET . ENV)) where VAR is either a symbol, for normal -;; variables, or an `heapenv' descriptor for references to heap environment -;; vectors. ENV is either an atom, meaning a `stack allocated' variable -;; (the particular atom serves to indicate the particular function context -;; on whose stack it's allocated), or an `heapenv' descriptor (see above), -;; meaning a variable allocated in a heap environment vector. For the -;; later case, an anonymous `variable' holding a pointer to the environment -;; vector may be located by recursively looking up ENV in the environment -;; as if it were a variable (so the entry for that `variable' will have a -;; non-symbol VAR). - -;; We call a lexical environment a `lexenv', and an entry in it a `lexvar'. - -;; constructor -(defsubst byte-compile-make-lexvar (name offset &optional env) - (cons name (cons offset env))) -;; accessors -(defsubst byte-compile-lexvar-name (lexvar) (car lexvar)) -(defsubst byte-compile-lexvar-offset (lexvar) (cadr lexvar)) -(defsubst byte-compile-lexvar-environment (lexvar) (cddr lexvar)) -(defsubst byte-compile-lexvar-variable-p (lexvar) (symbolp (car lexvar))) -(defsubst byte-compile-lexvar-environment-p (lexvar) - (not (symbolp (car lexvar)))) -(defsubst byte-compile-lexvar-on-stack-p (lexvar) - (atom (byte-compile-lexvar-environment lexvar))) -(defsubst byte-compile-lexvar-in-heap-p (lexvar) - (not (byte-compile-lexvar-on-stack-p lexvar))) - -(defun byte-compile-make-lambda-lexenv (form closed-over-lexenv) - "Return a new lexical environment for a lambda expression FORM. -CLOSED-OVER-LEXENV is the lexical environment in which FORM occurs. -The returned lexical environment contains two sets of variables: - * Variables that were in CLOSED-OVER-LEXENV and used by FORM - (all of these will be `heap' variables) - * Arguments to FORM (all of these will be `stack' variables)." - ;; See if this is a closure or not - (let ((closure nil) - (lforminfo (byte-compile-make-lforminfo)) - (args (byte-compile-arglist-vars (cadr form)))) - ;; Add variables from surrounding lexical environment to analysis set - (dolist (lexvar closed-over-lexenv) - (when (and (byte-compile-lexvar-in-heap-p lexvar) - (not (memq (car lexvar) args))) - ;; The variable is located in a heap-allocated environment - ;; vector, so FORM may use it. Add it to the set of variables - ;; that we'll search for in FORM. - (byte-compile-lforminfo-add-var lforminfo (car lexvar)))) - ;; See how FORM uses these potentially closed-over variables. - (byte-compile-lforminfo-analyze lforminfo form args) - (let ((lexenv nil)) - (dolist (vinfo (byte-compile-lforminfo-vars lforminfo)) - (when (> (byte-compile-lvarinfo-num-refs vinfo) 0) - ;; FORM uses VINFO's variable, so it must be a closure. - (setq closure t) - ;; Make sure that the environment in which the variable is - ;; located is accessible (since we only ever pass the - ;; innermost environment to closures, if it's in some other - ;; envionment, there must be path to it from the innermost - ;; one). - (unless (byte-compile-lexvar-in-heap-p vinfo) - ;; To access the variable from FORM, it must be in the heap. - (error - "Compiler error: lexical variable `%s' should be heap-allocated but is not" - (car vinfo))) - (let ((closed-over-lexvar (assq (car vinfo) closed-over-lexenv))) - (byte-compile-heapenv-ensure-access - byte-compile-current-heap-environment - (byte-compile-lexvar-environment closed-over-lexvar)) - ;; Put this variable in the new lexical environment - (push closed-over-lexvar lexenv)))) - ;; Fill in the initial stack contents - (let ((stackpos 0)) - (when closure - ;; Add the magic first argument that holds the environment pointer - (push (byte-compile-make-lexvar byte-compile-current-heap-environment - 0) - lexenv) - (setq stackpos (1+ stackpos))) - ;; Add entries for each argument - (dolist (arg args) - (push (byte-compile-make-lexvar arg stackpos) lexenv) - (setq stackpos (1+ stackpos))) - ;; Return the new lexical environment - lexenv)))) - -(defun byte-compile-closure-initial-lexenv-p (lexenv) - "Return non-nil if LEXENV is the initial lexical environment for a closure. -This only works correctly when passed a new lexical environment as -returned by `byte-compile-make-lambda-lexenv' (it works by checking to -see whether there are any heap-allocated lexical variables in LEXENV)." - (let ((closure nil)) - (while (and lexenv (not closure)) - (when (byte-compile-lexvar-environment-p (pop lexenv)) - (setq closure t))) - closure)) - - -;;; Heap environment vectors - -;; A `heap environment vector' is heap-allocated vector used to store -;; variable that can't be put onto the stack. -;; -;; They are represented in the compiler by a list of the form -;; -;; (SIZE SIZE-CONST-ID INIT-POSITION . ENVS) -;; -;; SIZE is the current size of the vector (which may be -;; incremented if another variable or environment-reference is added to -;; the end). SIZE-CONST-ID is an `unknown constant id' (as returned by -;; `byte-compile-push-unknown-constant') representing the constant used -;; in the vector initialization code, and INIT-POSITION is a position -;; in the byte-code output (as returned by `byte-compile-delay-out') -;; at which more initialization code can be added. -;; ENVS is a list of other environment vectors accessible form this one, -;; where each element is of the form (ENV . OFFSET). - -;; constructor -(defsubst byte-compile-make-heapenv (size-const-id init-position) - (list 0 size-const-id init-position)) -;; accessors -(defsubst byte-compile-heapenv-size (heapenv) (car heapenv)) -(defsubst byte-compile-heapenv-size-const-id (heapenv) (cadr heapenv)) -(defsubst byte-compile-heapenv-init-position (heapenv) (nth 2 heapenv)) -(defsubst byte-compile-heapenv-accessible-envs (heapenv) (nthcdr 3 heapenv)) - -(defun byte-compile-heapenv-add-slot (heapenv) - "Add a slot to the heap environment HEAPENV and return its offset." - (prog1 (car heapenv) (setcar heapenv (1+ (car heapenv))))) - -(defun byte-compile-heapenv-add-accessible-env (heapenv env offset) - "Add to HEAPENV's list of accessible environments, ENV at OFFSET." - (setcdr (nthcdr 2 heapenv) - (cons (cons env offset) - (byte-compile-heapenv-accessible-envs heapenv)))) - -(defun byte-compile-push-heapenv () - "Generate byte-code to push a new heap environment vector. -Sets `byte-compile-current-heap-environment' to the compiler descriptor -for the new heap environment. -Return a `lexvar' descriptor for the new heap environment." - (let ((env-stack-pos byte-compile-depth) - size-const-id init-position) - ;; Generate code to push the vector - (byte-compile-push-constant 'make-vector) - (setq size-const-id (byte-compile-push-unknown-constant)) - (byte-compile-push-constant nil) - (byte-compile-out 'byte-call 2) - (setq init-position (byte-compile-delay-out 3)) - ;; Now make a heap-environment for the compiler to use - (setq byte-compile-current-heap-environment - (byte-compile-make-heapenv size-const-id init-position)) - (byte-compile-make-lexvar byte-compile-current-heap-environment - env-stack-pos))) - -(defun byte-compile-heapenv-ensure-access (heapenv other-heapenv) - "Make sure that HEAPENV can be used to access OTHER-HEAPENV. -If not, then add a new slot to HEAPENV pointing to OTHER-HEAPENV." - (unless (memq heapenv (byte-compile-heapenv-accessible-envs heapenv)) - (let ((offset (byte-compile-heapenv-add-slot heapenv))) - (byte-compile-heapenv-add-accessible-env heapenv other-heapenv offset)))) - - -;;; Variable binding/unbinding - -(defun byte-compile-non-stack-bindings-p (clauses lforminfo) - "Return non-nil if any lexical bindings in CLAUSES are not stack-allocated. -LFORMINFO should be information about lexical variables being bound." - (let ((vars (byte-compile-lforminfo-vars lforminfo))) - (or (not (= (length clauses) (length vars))) - (progn - (while (and vars clauses) - (when (byte-compile-lvarinfo-closed-over-p (pop vars)) - (setq clauses nil))) - (not clauses))))) - -(defun byte-compile-let-clauses-trivial-init-p (clauses) - "Return true if let binding CLAUSES all have a `trivial' init value. -Trivial means either a constant value, or a simple variable initialization." - (or (null clauses) - (and (or (atom (car clauses)) - (atom (cadr (car clauses))) - (eq (car (cadr (car clauses))) 'quote)) - (byte-compile-let-clauses-trivial-init-p (cdr clauses))))) - -(defun byte-compile-rearrange-let-clauses (clauses lforminfo) - "Return CLAUSES rearranged so non-stack variables come last if possible. -Care is taken to only do so when it's clear that the meaning is the same. -LFORMINFO should be information about lexical variables being bound." - ;; We currently do a very simple job by only exchanging clauses when - ;; one has a constant init, or one has a variable init and the other - ;; doesn't have a function call init (because that could change the - ;; value of the variable). This could be more clever and actually - ;; attempt to analyze which variables could possible be changed, etc. - (let ((unchanged nil) - (lex-non-stack nil) - (dynamic nil)) - (while clauses - (let* ((clause (pop clauses)) - (var (if (consp clause) (car clause) clause)) - (init (and (consp clause) (cadr clause))) - (vinfo (assq var (byte-compile-lforminfo-vars lforminfo)))) - (cond - ((or (and vinfo - (not (byte-compile-lvarinfo-closed-over-p vinfo))) - (not - (or (eq init nil) (eq init t) - (and (atom init) (not (symbolp init))) - (and (consp init) (eq (car init) 'quote)) - (byte-compile-let-clauses-trivial-init-p clauses)))) - (push clause unchanged)) - (vinfo - (push clause lex-non-stack)) - (t - (push clause dynamic))))) - (nconc (nreverse unchanged) (nreverse lex-non-stack) (nreverse dynamic)))) - -(defun byte-compile-maybe-push-heap-environment (&optional lforminfo) - "Push a new heap environment if necessary. -LFORMINFO should be information about lexical variables being bound. -Return a lexical environment containing only the heap vector (or -nil if nothing was pushed). -Also, `byte-compile-current-heap-environment' and -`byte-compile-current-num-closures' are updated to reflect any change (so they -should probably be bound by the caller to ensure that the new values have the -proper scope)." - ;; We decide whether a new heap environment is required by seeing if - ;; the number of closures inside the form described by LFORMINFO is - ;; the same as the number inside the binding form that created the - ;; currently active heap environment. - (let ((nclosures - (and lforminfo (byte-compile-lforminfo-num-closures lforminfo)))) - (if (or (null lforminfo) - (zerop nclosures) - (= nclosures byte-compile-current-num-closures)) - ;; No need to push a heap environment. - nil - (error "Should have been handled by cconv") - ;; Have to push one. A heap environment is really just a vector, so - ;; we emit bytecodes to create a vector. However, the size is not - ;; fixed yet (the vector can grow if subforms use it to store - ;; values, and if `access points' to parent heap environments are - ;; added), so we use `byte-compile-push-unknown-constant' to push the - ;; vector size. - (setq byte-compile-current-num-closures nclosures) - (list (byte-compile-push-heapenv))))) - -(defun byte-compile-bind (var init-lexenv &optional lforminfo) - "Emit byte-codes to bind VAR and update `byte-compile-lexical-environment'. -INIT-LEXENV should be a lexical-environment alist describing the -positions of the init value that have been pushed on the stack, and -LFORMINFO should be information about lexical variables being bound. -Return non-nil if the TOS value was popped." - ;; The presence of lexical bindings mean that we may have to - ;; juggle things on the stack, either to move them to TOS for - ;; dynamic binding, or to put them in a non-stack environment - ;; vector. - (let ((vinfo (assq var (byte-compile-lforminfo-vars lforminfo)))) - (cond ((and (null vinfo) (eq var (caar init-lexenv))) - ;; VAR is dynamic and is on the top of the - ;; stack, so we can just bind it like usual - (byte-compile-dynamic-variable-bind var) - t) - ((null vinfo) - ;; VAR is dynamic, but we have to get its - ;; value out of the middle of the stack - (let ((stack-pos (cdr (assq var init-lexenv)))) - (byte-compile-stack-ref stack-pos) - (byte-compile-dynamic-variable-bind var) - ;; Now we have to store nil into its temporary - ;; stack position to avoid problems with GC - (byte-compile-push-constant nil) - (byte-compile-stack-set stack-pos)) - nil) - ((byte-compile-lvarinfo-closed-over-p vinfo) - ;; VAR is lexical, but needs to be in a - ;; heap-allocated environment. - (unless byte-compile-current-heap-environment - (error "No current heap-environment to allocate `%s' in!" var)) - (let ((init-stack-pos - ;; nil if the init value is on the top of the stack, - ;; otherwise the position of the init value on the stack. - (and (not (eq var (caar init-lexenv))) - (byte-compile-lexvar-offset (assq var init-lexenv)))) - (env-vec-pos - ;; Position of VAR in the environment vector - (byte-compile-lexvar-offset - (assq var byte-compile-lexical-environment))) - (env-vec-stack-pos - ;; Position of the the environment vector on the stack - ;; (the heap-environment must _always_ be available on - ;; the stack!) - (byte-compile-lexvar-offset - (assq byte-compile-current-heap-environment - byte-compile-lexical-environment)))) - (unless env-vec-stack-pos - (error "Couldn't find location of current heap environment!")) - (when init-stack-pos - ;; VAR is not on the top of the stack, so get it - (byte-compile-stack-ref init-stack-pos)) - (byte-compile-stack-ref env-vec-stack-pos) - ;; Store the variable into the vector - (byte-compile-out 'byte-vec-set env-vec-pos) - (when init-stack-pos - ;; Store nil into VAR's temporary stack - ;; position to avoid problems with GC - (byte-compile-push-constant nil) - (byte-compile-stack-set init-stack-pos)) - ;; Push a record of VAR's new lexical binding - (push (byte-compile-make-lexvar - var env-vec-pos byte-compile-current-heap-environment) - byte-compile-lexical-environment) - (not init-stack-pos))) - (t - ;; VAR is a simple stack-allocated lexical variable - (push (assq var init-lexenv) - byte-compile-lexical-environment) - nil)))) - -(defun byte-compile-unbind (clauses init-lexenv - &optional lforminfo preserve-body-value) - "Emit byte-codes to unbind the variables bound by CLAUSES. -CLAUSES is a `let'-style variable binding list. INIT-LEXENV should be a -lexical-environment alist describing the positions of the init value that -have been pushed on the stack, and LFORMINFO should be information about -the lexical variables that were bound. If PRESERVE-BODY-VALUE is true, -then an additional value on the top of the stack, above any lexical binding -slots, is preserved, so it will be on the top of the stack after all -binding slots have been popped." - ;; Unbind dynamic variables - (let ((num-dynamic-bindings 0)) - (if lforminfo - (dolist (clause clauses) - (unless (assq (if (consp clause) (car clause) clause) - (byte-compile-lforminfo-vars lforminfo)) - (setq num-dynamic-bindings (1+ num-dynamic-bindings)))) - (setq num-dynamic-bindings (length clauses))) - (unless (zerop num-dynamic-bindings) - (byte-compile-out 'byte-unbind num-dynamic-bindings))) - ;; Pop lexical variables off the stack, possibly preserving the - ;; return value of the body. - (when init-lexenv - ;; INIT-LEXENV contains all init values left on the stack - (byte-compile-discard (length init-lexenv) preserve-body-value))) - - -(provide 'byte-lexbind) - -;;; byte-lexbind.el ends here diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 97ed6a01c2f..71960ad54dc 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -1483,7 +1483,7 @@ byte-eqlsign byte-gtr byte-lss byte-leq byte-geq byte-diff byte-negate byte-plus byte-max byte-min byte-mult byte-char-after byte-char-syntax byte-buffer-substring byte-string= byte-string< byte-nthcdr byte-elt - byte-member byte-assq byte-quo byte-rem byte-vec-ref) + byte-member byte-assq byte-quo byte-rem) byte-compile-side-effect-and-error-free-ops)) ;; This crock is because of the way DEFVAR_BOOL variables work. @@ -1671,7 +1671,7 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; ((and (eq 'byte-dup (car lap0)) (eq 'byte-discard (car lap2)) - (memq (car lap1) '(byte-varset byte-varbind byte-stack-set byte-vec-set))) + (memq (car lap1) '(byte-varset byte-varbind byte-stack-set))) (byte-compile-log-lap " dup %s discard\t-->\t%s" lap1 lap1) (setq keep-going t rest (cdr rest) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 33940ec160e..e9beb0c5792 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -126,47 +126,11 @@ ;; This really ought to be loaded already! (load "byte-run")) -;; We want to do (require 'byte-lexbind) when compiling, to avoid compilation -;; errors; however that file also wants to do (require 'bytecomp) for the -;; same reason. Since we know it's OK to load byte-lexbind.el second, we -;; have that file require a feature that's provided before at the beginning -;; of this file, to avoid an infinite require loop. -;; `eval-when-compile' is defined in byte-run.el, so it must come after the -;; preceding load expression. -(provide 'bytecomp-preload) -(eval-when-compile (require 'byte-lexbind nil 'noerror)) - ;; The feature of compiling in a specific target Emacs version ;; has been turned off because compile time options are a bad idea. (defmacro byte-compile-single-version () nil) (defmacro byte-compile-version-cond (cond) cond) -;; The crud you see scattered through this file of the form -;; (or (and (boundp 'epoch::version) epoch::version) -;; (string-lessp emacs-version "19")) -;; is because the Epoch folks couldn't be bothered to follow the -;; normal emacs version numbering convention. - -;; (if (byte-compile-version-cond -;; (or (and (boundp 'epoch::version) epoch::version) -;; (string-lessp emacs-version "19"))) -;; (progn -;; ;; emacs-18 compatibility. -;; (defvar baud-rate (baud-rate)) ;Define baud-rate if it's undefined -;; -;; (if (byte-compile-single-version) -;; (defmacro byte-code-function-p (x) "Emacs 18 doesn't have these." nil) -;; (defun byte-code-function-p (x) "Emacs 18 doesn't have these." nil)) -;; -;; (or (and (fboundp 'member) -;; ;; avoid using someone else's possibly bogus definition of this. -;; (subrp (symbol-function 'member))) -;; (defun member (elt list) -;; "like memq, but uses equal instead of eq. In v19, this is a subr." -;; (while (and list (not (equal elt (car list)))) -;; (setq list (cdr list))) -;; list)))) - (defgroup bytecomp nil "Emacs Lisp byte-compiler." @@ -439,24 +403,15 @@ specify different fields to sort on." :type '(choice (const name) (const callers) (const calls) (const calls+callers) (const nil))) -;(defvar byte-compile-debug nil) (defvar byte-compile-debug t) (setq debug-on-error t) -;; (defvar byte-compile-overwrite-file t -;; "If nil, old .elc files are deleted before the new is saved, and .elc -;; files will have the same modes as the corresponding .el file. Otherwise, -;; existing .elc files will simply be overwritten, and the existing modes -;; will not be changed. If this variable is nil, then an .elc file which -;; is a symbolic link will be turned into a normal file, instead of the file -;; which the link points to being overwritten.") - (defvar byte-compile-constants nil "List of all constants encountered during compilation of this form.") (defvar byte-compile-variables nil "List of all variables encountered during compilation of this form.") (defvar byte-compile-bound-variables nil - "List of variables bound in the context of the current form. + "List of dynamic variables bound in the context of the current form. This list lives partly on the stack.") (defvar byte-compile-const-variables nil "List of variables declared as constants during compilation of this file.") @@ -512,10 +467,6 @@ but won't necessarily be defined when the compiled file is loaded.") ;; Variables for lexical binding (defvar byte-compile-lexical-environment nil "The current lexical environment.") -(defvar byte-compile-current-heap-environment nil - "If non-nil, a descriptor for the current heap-allocated lexical environment.") -(defvar byte-compile-current-num-closures 0 - "The number of lexical closures that close over `byte-compile-current-heap-environment'.") (defvar byte-compile-tag-number 0) (defvar byte-compile-output nil @@ -734,8 +685,6 @@ otherwise pop it") (byte-defop 178 -1 byte-stack-set) ; stack offset in following one byte (byte-defop 179 -1 byte-stack-set2) ; stack offset in following two bytes -(byte-defop 180 1 byte-vec-ref) ; vector offset in following one byte -(byte-defop 181 -1 byte-vec-set) ; vector offset in following one byte ;; if (following one byte & 0x80) == 0 ;; discard (following one byte & 0x7F) stack entries @@ -824,68 +773,71 @@ CONST2 may be evaulated multiple times." (dolist (lap-entry lap) (setq op (car lap-entry) off (cdr lap-entry)) - (cond ((not (symbolp op)) - (error "Non-symbolic opcode `%s'" op)) - ((eq op 'TAG) - (setcar off pc)) - ((null op) - ;; a no-op added by `byte-compile-delay-out' - (unless (zerop off) - (error - "Placeholder added by `byte-compile-delay-out' not filled in.") - )) - (t - (if (eq op 'byte-discardN-preserve-tos) - ;; byte-discardN-preserve-tos is a psuedo op, which is actually - ;; the same as byte-discardN with a modified argument - (setq opcode byte-discardN) - (setq opcode (symbol-value op))) - (cond ((memq op byte-goto-ops) - ;; goto - (byte-compile-push-bytecodes opcode nil (cdr off) bytes pc) - (push bytes patchlist)) - ((and (consp off) - ;; Variable or constant reference - (progn (setq off (cdr off)) - (eq op 'byte-constant))) - ;; constant ref - (if (< off byte-constant-limit) - (byte-compile-push-bytecodes (+ byte-constant off) - bytes pc) - (byte-compile-push-bytecode-const2 byte-constant2 off - bytes pc))) - ((and (= opcode byte-stack-set) - (> off 255)) - ;; Use the two-byte version of byte-stack-set if the - ;; offset is too large for the normal version. - (byte-compile-push-bytecode-const2 byte-stack-set2 off - bytes pc)) - ((and (>= opcode byte-listN) - (< opcode byte-discardN)) - ;; These insns all put their operand into one extra byte. - (byte-compile-push-bytecodes opcode off bytes pc)) - ((= opcode byte-discardN) - ;; byte-discardN is wierd in that it encodes a flag in the - ;; top bit of its one-byte argument. If the argument is - ;; too large to fit in 7 bits, the opcode can be repeated. - (let ((flag (if (eq op 'byte-discardN-preserve-tos) #x80 0))) - (while (> off #x7f) - (byte-compile-push-bytecodes opcode (logior #x7f flag) bytes pc) - (setq off (- off #x7f))) - (byte-compile-push-bytecodes opcode (logior off flag) bytes pc))) - ((null off) - ;; opcode that doesn't use OFF - (byte-compile-push-bytecodes opcode bytes pc)) - ;; The following three cases are for the special - ;; insns that encode their operand into 0, 1, or 2 - ;; extra bytes depending on its magnitude. - ((< off 6) - (byte-compile-push-bytecodes (+ opcode off) bytes pc)) - ((< off 256) - (byte-compile-push-bytecodes (+ opcode 6) off bytes pc)) - (t - (byte-compile-push-bytecode-const2 (+ opcode 7) off - bytes pc)))))) + (cond + ((not (symbolp op)) + (error "Non-symbolic opcode `%s'" op)) + ((eq op 'TAG) + (setcar off pc)) + ((null op) + ;; a no-op added by `byte-compile-delay-out' + (unless (zerop off) + (error + "Placeholder added by `byte-compile-delay-out' not filled in.") + )) + (t + (setq opcode + (if (eq op 'byte-discardN-preserve-tos) + ;; byte-discardN-preserve-tos is a pseudo op, which + ;; is actually the same as byte-discardN + ;; with a modified argument. + byte-discardN + (symbol-value op))) + (cond ((memq op byte-goto-ops) + ;; goto + (byte-compile-push-bytecodes opcode nil (cdr off) bytes pc) + (push bytes patchlist)) + ((and (consp off) + ;; Variable or constant reference + (progn (setq off (cdr off)) + (eq op 'byte-constant))) + ;; constant ref + (if (< off byte-constant-limit) + (byte-compile-push-bytecodes (+ byte-constant off) + bytes pc) + (byte-compile-push-bytecode-const2 byte-constant2 off + bytes pc))) + ((and (= opcode byte-stack-set) + (> off 255)) + ;; Use the two-byte version of byte-stack-set if the + ;; offset is too large for the normal version. + (byte-compile-push-bytecode-const2 byte-stack-set2 off + bytes pc)) + ((and (>= opcode byte-listN) + (< opcode byte-discardN)) + ;; These insns all put their operand into one extra byte. + (byte-compile-push-bytecodes opcode off bytes pc)) + ((= opcode byte-discardN) + ;; byte-discardN is wierd in that it encodes a flag in the + ;; top bit of its one-byte argument. If the argument is + ;; too large to fit in 7 bits, the opcode can be repeated. + (let ((flag (if (eq op 'byte-discardN-preserve-tos) #x80 0))) + (while (> off #x7f) + (byte-compile-push-bytecodes opcode (logior #x7f flag) bytes pc) + (setq off (- off #x7f))) + (byte-compile-push-bytecodes opcode (logior off flag) bytes pc))) + ((null off) + ;; opcode that doesn't use OFF + (byte-compile-push-bytecodes opcode bytes pc)) + ;; The following three cases are for the special + ;; insns that encode their operand into 0, 1, or 2 + ;; extra bytes depending on its magnitude. + ((< off 6) + (byte-compile-push-bytecodes (+ opcode off) bytes pc)) + ((< off 256) + (byte-compile-push-bytecodes (+ opcode 6) off bytes pc)) + (t + (byte-compile-push-bytecode-const2 (+ opcode 7) off + bytes pc)))))) ;;(if (not (= pc (length bytes))) ;; (error "Compiler error: pc mismatch - %s %s" pc (length bytes))) @@ -1694,7 +1646,7 @@ that already has a `.elc' file." "Non-nil to prevent byte-compiling of Emacs Lisp code. This is normally set in local file variables at the end of the elisp file: -;; Local Variables:\n;; no-byte-compile: t\n;; End: ") +\;; Local Variables:\n;; no-byte-compile: t\n;; End: ") ;Backslash for compile-main. ;;;###autoload(put 'no-byte-compile 'safe-local-variable 'booleanp) (defun byte-recompile-file (bytecomp-filename &optional bytecomp-force bytecomp-arg load) @@ -2682,7 +2634,23 @@ If FORM is a lambda or a macro, byte-compile it as a function." (setq list (cdr list))))) -(autoload 'byte-compile-make-lambda-lexenv "byte-lexbind") +(defun byte-compile-arglist-vars (arglist) + "Return a list of the variables in the lambda argument list ARGLIST." + (remq '&rest (remq '&optional arglist))) + +(defun byte-compile-make-lambda-lexenv (form) + "Return a new lexical environment for a lambda expression FORM." + ;; See if this is a closure or not + (let ((args (byte-compile-arglist-vars (cadr form)))) + (let ((lexenv nil)) + ;; Fill in the initial stack contents + (let ((stackpos 0)) + ;; Add entries for each argument + (dolist (arg args) + (push (cons arg stackpos) lexenv) + (setq stackpos (1+ stackpos))) + ;; Return the new lexical environment + lexenv)))) ;; Byte-compile a lambda-expression and return a valid function. ;; The value is usually a compiled function but may be the original @@ -2700,10 +2668,9 @@ If FORM is a lambda or a macro, byte-compile it as a function." (byte-compile-check-lambda-list (nth 1 bytecomp-fun)) (let* ((bytecomp-arglist (nth 1 bytecomp-fun)) (byte-compile-bound-variables - (nconc (and (byte-compile-warning-enabled-p 'free-vars) - (delq '&rest - (delq '&optional (copy-sequence bytecomp-arglist)))) - byte-compile-bound-variables)) + (append (and (not lexical-binding) + (byte-compile-arglist-vars bytecomp-arglist)) + byte-compile-bound-variables)) (bytecomp-body (cdr (cdr bytecomp-fun))) (bytecomp-doc (if (stringp (car bytecomp-body)) (prog1 (car bytecomp-body) @@ -2742,42 +2709,27 @@ If FORM is a lambda or a macro, byte-compile it as a function." ;; Process the body. (let* ((byte-compile-lexical-environment ;; If doing lexical binding, push a new lexical environment - ;; containing the args and any closed-over variables. - (and lexical-binding - (byte-compile-make-lambda-lexenv - bytecomp-fun - byte-compile-lexical-environment))) - (is-closure - ;; This is true if we should be making a closure instead of - ;; a simple lambda (because some variables from the - ;; containing lexical environment are closed over). + ;; containing just the args (since lambda expressions + ;; should be closed by now). (and lexical-binding - (byte-compile-closure-initial-lexenv-p - byte-compile-lexical-environment) - (error "Should have been handled by cconv"))) - (byte-compile-current-heap-environment nil) - (byte-compile-current-num-closures 0) + (byte-compile-make-lambda-lexenv bytecomp-fun))) (compiled (byte-compile-top-level (cons 'progn bytecomp-body) nil 'lambda))) ;; Build the actual byte-coded function. (if (eq 'byte-code (car-safe compiled)) - (let ((code - (apply 'make-byte-code - (append (list bytecomp-arglist) - ;; byte-string, constants-vector, stack depth - (cdr compiled) - ;; optionally, the doc string. - (if (or bytecomp-doc bytecomp-int - lexical-binding) - (list bytecomp-doc)) - ;; optionally, the interactive spec. - (if (or bytecomp-int lexical-binding) - (list (nth 1 bytecomp-int))) - (if lexical-binding - '(t)))))) - (if is-closure - (cons 'closure code) - code)) + (apply 'make-byte-code + (append (list bytecomp-arglist) + ;; byte-string, constants-vector, stack depth + (cdr compiled) + ;; optionally, the doc string. + (if (or bytecomp-doc bytecomp-int + lexical-binding) + (list bytecomp-doc)) + ;; optionally, the interactive spec. + (if (or bytecomp-int lexical-binding) + (list (nth 1 bytecomp-int))) + (if lexical-binding + '(t)))) (setq compiled (nconc (if bytecomp-int (list bytecomp-int)) (cond ((eq (car-safe compiled) 'progn) (cdr compiled)) @@ -2788,26 +2740,10 @@ If FORM is a lambda or a macro, byte-compile it as a function." (bytecomp-body (list nil)))) compiled)))))) -(defun byte-compile-closure-code-p (code) - (eq (car-safe code) 'closure)) - -(defun byte-compile-make-closure (code) - (error "Should have been handled by cconv") - ;; A real closure requires that the constant be curried with an - ;; environment vector to make a closure object. - (if for-effect - (setq for-effect nil) - (byte-compile-push-constant 'curry) - (byte-compile-push-constant code) - (byte-compile-lexical-variable-ref byte-compile-current-heap-environment) - (byte-compile-out 'byte-call 2))) - (defun byte-compile-closure (form &optional add-lambda) (let ((code (byte-compile-lambda form add-lambda))) - (if (byte-compile-closure-code-p code) - (byte-compile-make-closure code) - ;; A simple lambda is just a constant. - (byte-compile-constant code)))) + ;; A simple lambda is just a constant. + (byte-compile-constant code))) (defun byte-compile-constants-vector () ;; Builds the constants-vector from the current variables and constants. @@ -2867,34 +2803,11 @@ If FORM is a lambda or a macro, byte-compile it as a function." ;; See how many arguments there are, and set the current stack depth ;; accordingly (dolist (var byte-compile-lexical-environment) - (when (byte-compile-lexvar-on-stack-p var) - (setq byte-compile-depth (1+ byte-compile-depth)))) + (setq byte-compile-depth (1+ byte-compile-depth))) ;; If there are args, output a tag to record the initial ;; stack-depth for the optimizer (when (> byte-compile-depth 0) - (byte-compile-out-tag (byte-compile-make-tag))) - ;; If this is the top-level of a lexically bound lambda expression, - ;; perhaps some parameters on stack need to be copied into a heap - ;; environment, so check for them, and do so if necessary. - (let ((lforminfo (byte-compile-make-lforminfo))) - ;; Add any lexical variable that's on the stack to the analysis set. - (dolist (var byte-compile-lexical-environment) - (when (byte-compile-lexvar-on-stack-p var) - (byte-compile-lforminfo-add-var lforminfo (car var) t))) - ;; Analyze the body - (unless (null (byte-compile-lforminfo-vars lforminfo)) - (byte-compile-lforminfo-analyze lforminfo form nil nil)) - ;; If the analysis revealed some argument need to be in a heap - ;; environment (because they're closed over by an embedded - ;; lambda), put them there. - (setq byte-compile-lexical-environment - (nconc (byte-compile-maybe-push-heap-environment lforminfo) - byte-compile-lexical-environment)) - (dolist (arginfo (byte-compile-lforminfo-vars lforminfo)) - (when (byte-compile-lvarinfo-closed-over-p arginfo) - (byte-compile-bind (car arginfo) - byte-compile-lexical-environment - lforminfo))))) + (byte-compile-out-tag (byte-compile-make-tag)))) ;; Now compile FORM (byte-compile-form form for-effect) (byte-compile-out-toplevel for-effect output-type)))) @@ -3044,7 +2957,7 @@ That command is designed for interactive use only" bytecomp-fn)) (if (memq bytecomp-fn '(custom-declare-group custom-declare-variable custom-declare-face)) - (byte-compile-nogroup-warn form)) + (byte-compile-nogroup-warn form)) (byte-compile-callargs-warn form)) (if (and bytecomp-handler ;; Make sure that function exists. This is important @@ -3107,40 +3020,16 @@ If BINDING is non-nil, VAR is being bound." (defun byte-compile-dynamic-variable-bind (var) "Generate code to bind the lexical variable VAR to the top-of-stack value." (byte-compile-check-variable var t) - (when (byte-compile-warning-enabled-p 'free-vars) - (push var byte-compile-bound-variables)) + (push var byte-compile-bound-variables) (byte-compile-dynamic-variable-op 'byte-varbind var)) -;; This is used when it's know that VAR _definitely_ has a lexical -;; binding, and no error-checking should be done. -(defun byte-compile-lexical-variable-ref (var) - "Generate code to push the value of the lexical variable VAR on the stack." - (let ((binding (assq var byte-compile-lexical-environment))) - (when (null binding) - (error "Lexical binding not found for `%s'" var)) - (if (byte-compile-lexvar-on-stack-p binding) - ;; On the stack - (byte-compile-stack-ref (byte-compile-lexvar-offset binding)) - ;; In a heap environment vector; first push the vector on the stack - (byte-compile-lexical-variable-ref - (byte-compile-lexvar-environment binding)) - ;; Now get the value from it - (byte-compile-out 'byte-vec-ref (byte-compile-lexvar-offset binding))))) - (defun byte-compile-variable-ref (var) "Generate code to push the value of the variable VAR on the stack." (byte-compile-check-variable var) (let ((lex-binding (assq var byte-compile-lexical-environment))) (if lex-binding ;; VAR is lexically bound - (if (byte-compile-lexvar-on-stack-p lex-binding) - ;; On the stack - (byte-compile-stack-ref (byte-compile-lexvar-offset lex-binding)) - ;; In a heap environment vector - (byte-compile-lexical-variable-ref - (byte-compile-lexvar-environment lex-binding)) - (byte-compile-out 'byte-vec-ref - (byte-compile-lexvar-offset lex-binding))) + (byte-compile-stack-ref (cdr lex-binding)) ;; VAR is dynamically bound (unless (or (not (byte-compile-warning-enabled-p 'free-vars)) (boundp var) @@ -3156,14 +3045,7 @@ If BINDING is non-nil, VAR is being bound." (let ((lex-binding (assq var byte-compile-lexical-environment))) (if lex-binding ;; VAR is lexically bound - (if (byte-compile-lexvar-on-stack-p lex-binding) - ;; On the stack - (byte-compile-stack-set (byte-compile-lexvar-offset lex-binding)) - ;; In a heap environment vector - (byte-compile-lexical-variable-ref - (byte-compile-lexvar-environment lex-binding)) - (byte-compile-out 'byte-vec-set - (byte-compile-lexvar-offset lex-binding))) + (byte-compile-stack-set (cdr lex-binding)) ;; VAR is dynamically bound (unless (or (not (byte-compile-warning-enabled-p 'free-vars)) (boundp var) @@ -3795,9 +3677,7 @@ that suppresses all warnings during execution of BODY." ,condition (list 'boundp 'default-boundp))) ;; Maybe add to the bound list. (byte-compile-bound-variables - (if bound-list - (append bound-list byte-compile-bound-variables) - byte-compile-bound-variables))) + (append bound-list byte-compile-bound-variables))) (unwind-protect ;; If things not being bound at all is ok, so must them being obsolete. ;; Note that we add to the existing lists since Tramp (ab)uses @@ -3910,14 +3790,7 @@ that suppresses all warnings during execution of BODY." (defun byte-compile-while (form) (let ((endtag (byte-compile-make-tag)) - (looptag (byte-compile-make-tag)) - ;; Heap environments can't be shared between a loop and its - ;; enclosing environment (because any lexical variables bound - ;; inside the loop should have an independent value for each - ;; iteration). Setting `byte-compile-current-num-closures' to - ;; an invalid value causes the code that tries to merge - ;; environments to not do so. - (byte-compile-current-num-closures -1)) + (looptag (byte-compile-make-tag))) (byte-compile-out-tag looptag) (byte-compile-form (car (cdr form))) (byte-compile-goto-if nil for-effect endtag) @@ -3933,109 +3806,131 @@ that suppresses all warnings during execution of BODY." ;; let binding -;; All other lexical-binding functions are guarded by a non-nil return -;; value from `byte-compile-compute-lforminfo', so they needn't be -;; autoloaded. -(autoload 'byte-compile-compute-lforminfo "byte-lexbind") - -(defun byte-compile-push-binding-init (clause init-lexenv lforminfo) +(defun byte-compile-push-binding-init (clause) "Emit byte-codes to push the initialization value for CLAUSE on the stack. -INIT-LEXENV is the lexical environment created for initializations -already done for this form. -LFORMINFO should be information about lexical variables being bound. -Return INIT-LEXENV updated to include the newest initialization, or nil -if LFORMINFO is nil (meaning all bindings are dynamic)." - (let* ((var (if (consp clause) (car clause) clause)) - (vinfo - (and lforminfo (assq var (byte-compile-lforminfo-vars lforminfo)))) - (unused (and vinfo (zerop (cadr vinfo))))) - (unless (and unused (symbolp clause)) - (when (and lforminfo (not unused)) - ;; We record the stack position even of dynamic bindings and - ;; variables in non-stack lexical environments; we'll put - ;; them in the proper place below. - (push (byte-compile-make-lexvar var byte-compile-depth) init-lexenv)) +Return the offset in the form (VAR . OFFSET)." + (let* ((var (if (consp clause) (car clause) clause))) + ;; We record the stack position even of dynamic bindings and + ;; variables in non-stack lexical environments; we'll put + ;; them in the proper place below. + (prog1 (cons var byte-compile-depth) (if (consp clause) - (byte-compile-form (cadr clause) unused) - (byte-compile-push-constant nil)))) - init-lexenv) + (byte-compile-form (cadr clause)) + (byte-compile-push-constant nil))))) + +(defun byte-compile-not-lexical-var-p (var) + (or (not (symbolp var)) ; form is not a list + (if (eval-when-compile (fboundp 'special-variable-p)) + (special-variable-p var) + (boundp var)) + (memq var byte-compile-bound-variables) + (memq var '(nil t)) + (keywordp var))) + +(defun byte-compile-bind (var init-lexenv) + "Emit byte-codes to bind VAR and update `byte-compile-lexical-environment'. +INIT-LEXENV should be a lexical-environment alist describing the +positions of the init value that have been pushed on the stack. +Return non-nil if the TOS value was popped." + ;; The presence of lexical bindings mean that we may have to + ;; juggle things on the stack, either to move them to TOS for + ;; dynamic binding, or to put them in a non-stack environment + ;; vector. + (cond ((not (byte-compile-not-lexical-var-p var)) + ;; VAR is a simple stack-allocated lexical variable + (push (assq var init-lexenv) + byte-compile-lexical-environment) + nil) + ((eq var (caar init-lexenv)) + ;; VAR is dynamic and is on the top of the + ;; stack, so we can just bind it like usual + (byte-compile-dynamic-variable-bind var) + t) + (t + ;; VAR is dynamic, but we have to get its + ;; value out of the middle of the stack + (let ((stack-pos (cdr (assq var init-lexenv)))) + (byte-compile-stack-ref stack-pos) + (byte-compile-dynamic-variable-bind var) + ;; Now we have to store nil into its temporary + ;; stack position to avoid problems with GC + (byte-compile-push-constant nil) + (byte-compile-stack-set stack-pos)) + nil))) + +(defun byte-compile-unbind (clauses init-lexenv + &optional preserve-body-value) + "Emit byte-codes to unbind the variables bound by CLAUSES. +CLAUSES is a `let'-style variable binding list. INIT-LEXENV should be a +lexical-environment alist describing the positions of the init value that +have been pushed on the stack. If PRESERVE-BODY-VALUE is true, +then an additional value on the top of the stack, above any lexical binding +slots, is preserved, so it will be on the top of the stack after all +binding slots have been popped." + ;; Unbind dynamic variables + (let ((num-dynamic-bindings 0)) + (dolist (clause clauses) + (unless (assq (if (consp clause) (car clause) clause) + byte-compile-lexical-environment) + (setq num-dynamic-bindings (1+ num-dynamic-bindings)))) + (unless (zerop num-dynamic-bindings) + (byte-compile-out 'byte-unbind num-dynamic-bindings))) + ;; Pop lexical variables off the stack, possibly preserving the + ;; return value of the body. + (when init-lexenv + ;; INIT-LEXENV contains all init values left on the stack + (byte-compile-discard (length init-lexenv) preserve-body-value))) (defun byte-compile-let (form) "Generate code for the `let' form FORM." - (let ((clauses (cadr form)) - (lforminfo (and lexical-binding (byte-compile-compute-lforminfo form))) - (init-lexenv nil) - ;; bind these to restrict the scope of any changes - (byte-compile-current-heap-environment - byte-compile-current-heap-environment) - (byte-compile-current-num-closures byte-compile-current-num-closures)) - (when (and lforminfo (byte-compile-non-stack-bindings-p clauses lforminfo)) - ;; Some of the variables we're binding are lexical variables on - ;; the stack, but not all. As much as we can, rearrange the list - ;; so that non-stack lexical variables and dynamically bound - ;; variables come last, which allows slightly more optimal - ;; byte-code for binding them. - (setq clauses (byte-compile-rearrange-let-clauses clauses lforminfo))) - ;; If necessary, create a new heap environment to hold some of the - ;; variables bound here. - (when lforminfo - (setq init-lexenv (byte-compile-maybe-push-heap-environment lforminfo))) - ;; First compute the binding values in the old scope. - (dolist (clause clauses) - (setq init-lexenv - (byte-compile-push-binding-init clause init-lexenv lforminfo))) - ;; Now do the bindings, execute the body, and undo the bindings - (let ((byte-compile-bound-variables byte-compile-bound-variables) - (byte-compile-lexical-environment byte-compile-lexical-environment) - (preserve-body-value (not for-effect))) - (dolist (clause (reverse clauses)) - (let ((var (if (consp clause) (car clause) clause))) - (cond ((null lforminfo) + ;; First compute the binding values in the old scope. + (let ((varlist (car (cdr form))) + (init-lexenv nil)) + (dolist (var varlist) + (push (byte-compile-push-binding-init var) init-lexenv)) + ;; Now do the bindings, execute the body, and undo the bindings. + (let ((byte-compile-bound-variables byte-compile-bound-variables) ;new scope + (varlist (reverse (car (cdr form)))) + (byte-compile-lexical-environment byte-compile-lexical-environment)) + (dolist (var varlist) + (let ((var (if (consp var) (car var) var))) + (cond ((null lexical-binding) ;; If there are no lexical bindings, we can do things simply. (byte-compile-dynamic-variable-bind var)) - ((byte-compile-bind var init-lexenv lforminfo) + ((byte-compile-bind var init-lexenv) (pop init-lexenv))))) - ;; Emit the body + ;; Emit the body. (byte-compile-body-do-effect (cdr (cdr form))) - ;; Unbind the variables - (if lforminfo - ;; Unbind both lexical and dynamic variables - (byte-compile-unbind clauses init-lexenv lforminfo preserve-body-value) - ;; Unbind dynamic variables - (byte-compile-out 'byte-unbind (length clauses)))))) + ;; Unbind the variables. + (if lexical-binding + ;; Unbind both lexical and dynamic variables. + (byte-compile-unbind varlist init-lexenv t) + ;; Unbind dynamic variables. + (byte-compile-out 'byte-unbind (length varlist)))))) (defun byte-compile-let* (form) "Generate code for the `let*' form FORM." - (let ((clauses (cadr form)) - (lforminfo (and lexical-binding (byte-compile-compute-lforminfo form))) + (let ((byte-compile-bound-variables byte-compile-bound-variables) ;new scope + (clauses (cadr form)) (init-lexenv nil) - (preserve-body-value (not for-effect)) ;; bind these to restrict the scope of any changes - (byte-compile-bound-variables byte-compile-bound-variables) - (byte-compile-lexical-environment byte-compile-lexical-environment) - (byte-compile-current-heap-environment - byte-compile-current-heap-environment) - (byte-compile-current-num-closures byte-compile-current-num-closures)) - ;; If necessary, create a new heap environment to hold some of the - ;; variables bound here. - (when lforminfo - (setq init-lexenv (byte-compile-maybe-push-heap-environment lforminfo))) + + (byte-compile-lexical-environment byte-compile-lexical-environment)) ;; Bind the variables - (dolist (clause clauses) - (setq init-lexenv - (byte-compile-push-binding-init clause init-lexenv lforminfo)) - (let ((var (if (consp clause) (car clause) clause))) - (cond ((null lforminfo) + (dolist (var clauses) + (push (byte-compile-push-binding-init var) init-lexenv) + (let ((var (if (consp var) (car var) var))) + (cond ((null lexical-binding) ;; If there are no lexical bindings, we can do things simply. (byte-compile-dynamic-variable-bind var)) - ((byte-compile-bind var init-lexenv lforminfo) + ((byte-compile-bind var init-lexenv) (pop init-lexenv))))) ;; Emit the body (byte-compile-body-do-effect (cdr (cdr form))) ;; Unbind the variables - (if lforminfo + (if lexical-binding ;; Unbind both lexical and dynamic variables - (byte-compile-unbind clauses init-lexenv lforminfo preserve-body-value) + (byte-compile-unbind clauses init-lexenv t) ;; Unbind dynamic variables (byte-compile-out 'byte-unbind (length clauses))))) @@ -4105,10 +4000,11 @@ if LFORMINFO is nil (meaning all bindings are dynamic)." (defun byte-compile-condition-case (form) (let* ((var (nth 1 form)) - (byte-compile-bound-variables - (if var (cons var byte-compile-bound-variables) - byte-compile-bound-variables)) - (fun-bodies (eq var :fun-body))) + (fun-bodies (eq var :fun-body)) + (byte-compile-bound-variables + (if (and var (not fun-bodies)) + (cons var byte-compile-bound-variables) + byte-compile-bound-variables))) (byte-compile-set-symbol-position 'condition-case) (unless (symbolp var) (byte-compile-warn @@ -4215,12 +4111,7 @@ if LFORMINFO is nil (meaning all bindings are dynamic)." (code (byte-compile-lambda (cdr (cdr form)) t)) (for-effect nil)) (byte-compile-push-constant (nth 1 form)) - (if (not (byte-compile-closure-code-p code)) - ;; simple lambda - (byte-compile-push-constant (cons 'macro code)) - (byte-compile-push-constant 'macro) - (byte-compile-make-closure code) - (byte-compile-out 'byte-cons)) + (byte-compile-push-constant (cons 'macro code)) (byte-compile-out 'byte-fset) (byte-compile-discard)) (byte-compile-constant (nth 1 form))) diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index efb9d061b5c..10464047cd3 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -85,19 +85,6 @@ is less than this number.") "List of candidates for lambda lifting. Each candidate has the form (VAR INCLOSURE BINDER PARENTFORM).") -(defun cconv-not-lexical-var-p (var) - (or (not (symbolp var)) ; form is not a list - (if (eval-when-compile (fboundp 'special-variable-p)) - (special-variable-p var) - (boundp var)) - ;; byte-compile-bound-variables normally holds both the - ;; dynamic and lexical vars, but the bytecomp.el should - ;; only call us at the top-level so there shouldn't be - ;; any lexical vars in it here. - (memq var byte-compile-bound-variables) - (memq var '(nil t)) - (keywordp var))) - (defun cconv-freevars (form &optional fvrs) "Find all free variables of given form. Arguments: @@ -189,7 +176,7 @@ Returns a list of free variables." (dolist (exp body-forms) (setq fvrs (cconv-freevars exp fvrs))) fvrs) - (_ (if (cconv-not-lexical-var-p form) + (_ (if (byte-compile-not-lexical-var-p form) fvrs (cons form fvrs))))) @@ -704,7 +691,7 @@ Returns a form where all lambdas don't have any free variables." (defun cconv-analyse-function (args body env parentform inclosure) (dolist (arg args) (cond - ((cconv-not-lexical-var-p arg) + ((byte-compile-not-lexical-var-p arg) (byte-compile-report-error (format "Argument %S is not a lexical variable" arg))) ((eq ?& (aref (symbol-name arg) 0)) nil) ;Ignore &rest, &optional, ... @@ -738,7 +725,7 @@ lambdas if they are suitable for lambda lifting. (cconv-analyse-form value (if (eq letsym 'let*) env orig-env) inclosure)) - (unless (cconv-not-lexical-var-p var) + (unless (byte-compile-not-lexical-var-p var) (let ((varstruct (list var inclosure binder form))) (push varstruct env) ; Push a new one. diff --git a/lisp/help-fns.el b/lisp/help-fns.el index ed266c71a59..172a74d8c80 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -529,23 +529,23 @@ suitable file is found, return nil." (high (help-highlight-arguments use doc))) (let ((fill-begin (point))) (insert (car high) "\n") - (fill-region fill-begin (point)))) - (setq doc (cdr high)))) - (let* ((obsolete (and - ;; function might be a lambda construct. - (symbolp function) - (get function 'byte-obsolete-info))) - (use (car obsolete))) - (when obsolete - (princ "\nThis function is obsolete") - (when (nth 2 obsolete) - (insert (format " since %s" (nth 2 obsolete)))) - (insert (cond ((stringp use) (concat ";\n" use)) - (use (format ";\nuse `%s' instead." use)) - (t ".")) - "\n")) - (insert "\n" - (or doc "Not documented."))))))) + (fill-region fill-begin (point))) + (setq doc (cdr high)))) + (let* ((obsolete (and + ;; function might be a lambda construct. + (symbolp function) + (get function 'byte-obsolete-info))) + (use (car obsolete))) + (when obsolete + (princ "\nThis function is obsolete") + (when (nth 2 obsolete) + (insert (format " since %s" (nth 2 obsolete)))) + (insert (cond ((stringp use) (concat ";\n" use)) + (use (format ";\nuse `%s' instead." use)) + (t ".")) + "\n")) + (insert "\n" + (or doc "Not documented.")))))))) ;; Variables diff --git a/src/ChangeLog b/src/ChangeLog index f7a3fcc8b1b..6674fb31ca5 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,8 @@ +2011-02-12 Stefan Monnier + + * bytecode.c (Bvec_ref, Bvec_set): Remove. + (exec_byte_code): Don't handle them. + 2010-12-27 Stefan Monnier * eval.c (Fdefvar): Record specialness before computing initial value. diff --git a/src/bytecode.c b/src/bytecode.c index 96d2aa273f2..9bf6ae45ce9 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -231,8 +231,6 @@ extern Lisp_Object Qand_optional, Qand_rest; /* Bstack_ref is code 0. */ #define Bstack_set 0262 #define Bstack_set2 0263 -#define Bvec_ref 0264 -#define Bvec_set 0265 #define BdiscardN 0266 #define Bconstant 0300 @@ -1722,27 +1720,6 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, case Bstack_set2: stack.bottom[FETCH2] = POP; break; - case Bvec_ref: - case Bvec_set: - /* These byte-codes used mostly for variable references to - lexically bound variables that are in an environment vector - instead of on the byte-interpreter stack (generally those - variables which might be shared with a closure). */ - { - int index = FETCH; - Lisp_Object vec = POP; - - if (! VECTORP (vec)) - wrong_type_argument (Qvectorp, vec); - else if (index < 0 || index >= XVECTOR (vec)->size) - args_out_of_range (vec, make_number (index)); - - if (op == Bvec_ref) - PUSH (XVECTOR (vec)->contents[index]); - else - XVECTOR (vec)->contents[index] = POP; - } - break; case BdiscardN: op = FETCH; if (op & 0x80) -- cgit v1.3 From b38b1ec071ee9752da53f2485902165fe728e8fa Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 17 Feb 2011 16:19:13 -0500 Subject: Various compiler bug-fixes. MPC seems to run correctly now. * lisp/files.el (lexical-binding): Add a safe-local-variable property. * lisp/emacs-lisp/byte-opt.el (byte-inline-lapcode): Check how many elements are added to the stack. (byte-compile-splice-in-already-compiled-code): Don't touch lexical nor byte-compile-depth now that byte-inline-lapcode does it for us. (byte-compile-inline-expand): Don't inline dynbind byte code into lexbind code, since it has to be done differently. * lisp/emacs-lisp/bytecomp.el (byte-compile-arglist-warn): Correctly extract arglist from `closure's. (byte-compile-cl-warn): Compiler-macros are run earlier now. (byte-compile-top-level): Bind byte-compile-lexical-environment to nil, except for lambdas. (byte-compile-form): Don't run the compiler-macro expander here. (byte-compile-let): Merge with byte-compile-let*. Don't preserve-body-value if the body's value was discarded. * lisp/emacs-lisp/cconv.el (cconv--set-diff, cconv--set-diff-map) (cconv--map-diff, cconv--map-diff-elem, cconv--map-diff-set): New funs. (cconv--env-var): New constant. (cconv-closure-convert-rec): Use it and use them. Fix a typo that ended up forgetting to remove entries from lmenvs in `let'. For `lambda' use the outer `fvrs' when building the closure and don't forget to remove `vars' from the `emvrs' and `lmenvs' of the body. * lisp/emacs-lisp/cl-macs.el (cl-byte-compile-block): Disable optimization in lexbind, because it needs a different implementation. * src/bytecode.c (exec_byte_code): Fix handling of &rest. * src/eval.c (Vinternal_interpreter_environment): Remove. (syms_of_eval): Do declare Vinternal_interpreter_environment as a global lisp var, but unintern it to hide it. (Fcommandp): * src/data.c (Finteractive_form): Understand `closure's. --- lisp/ChangeLog | 31 +++++++++ lisp/doc-view.el | 4 +- lisp/emacs-lisp/byte-opt.el | 63 ++++++++++------- lisp/emacs-lisp/bytecomp.el | 149 ++++++++++++++++++----------------------- lisp/emacs-lisp/cconv.el | 144 +++++++++++++++++++++++---------------- lisp/emacs-lisp/cl-loaddefs.el | 2 +- lisp/emacs-lisp/cl-macs.el | 8 ++- lisp/emacs-lisp/pcase.el | 3 +- lisp/files.el | 25 +++---- lisp/help-fns.el | 2 +- src/ChangeLog | 10 +++ src/bytecode.c | 4 +- src/data.c | 2 + src/eval.c | 34 +++++----- src/lisp.h | 2 +- 15 files changed, 281 insertions(+), 202 deletions(-) (limited to 'src/bytecode.c') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index b972f17909a..142deda9505 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,34 @@ +2011-02-17 Stefan Monnier + + * files.el (lexical-binding): Add a safe-local-variable property. + + * emacs-lisp/cl-macs.el (cl-byte-compile-block): Disable optimization + in lexbind, because it needs a different implementation. + + * emacs-lisp/cconv.el (cconv--set-diff, cconv--set-diff-map) + (cconv--map-diff, cconv--map-diff-elem, cconv--map-diff-set): New funs. + (cconv--env-var): New constant. + (cconv-closure-convert-rec): Use it and use them. Fix a typo that + ended up forgetting to remove entries from lmenvs in `let'. + For `lambda' use the outer `fvrs' when building the closure and don't + forget to remove `vars' from the `emvrs' and `lmenvs' of the body. + + * emacs-lisp/bytecomp.el (byte-compile-arglist-warn): + Correctly extract arglist from `closure's. + (byte-compile-cl-warn): Compiler-macros are run earlier now. + (byte-compile-top-level): Bind byte-compile-lexical-environment to nil, + except for lambdas. + (byte-compile-form): Don't run the compiler-macro expander here. + (byte-compile-let): Merge with byte-compile-let*. + Don't preserve-body-value if the body's value was discarded. + + * emacs-lisp/byte-opt.el (byte-inline-lapcode): Check how many elements + are added to the stack. + (byte-compile-splice-in-already-compiled-code): Don't touch lexical nor + byte-compile-depth now that byte-inline-lapcode does it for us. + (byte-compile-inline-expand): Don't inline dynbind byte code into + lexbind code, since it has to be done differently. + 2011-02-12 Stefan Monnier * emacs-lisp/byte-lexbind.el: Delete. diff --git a/lisp/doc-view.el b/lisp/doc-view.el index 4f8c338409b..7bead624cc7 100644 --- a/lisp/doc-view.el +++ b/lisp/doc-view.el @@ -1,5 +1,5 @@ -;;; -*- lexical-binding: t -*- -;;; doc-view.el --- View PDF/PostScript/DVI files in Emacs +;;; doc-view.el --- View PDF/PostScript/DVI files in Emacs -*- lexical-binding: t -*- + ;; Copyright (C) 2007-2011 Free Software Foundation, Inc. ;; diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 71960ad54dc..12df3251267 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -248,7 +248,18 @@ ;; are no collisions, and that byte-compile-tag-number is reasonable ;; after this is spliced in. The provided list is destroyed. (defun byte-inline-lapcode (lap) - (setq byte-compile-output (nconc (nreverse lap) byte-compile-output))) + ;; "Replay" the operations: we used to just do + ;; (setq byte-compile-output (nconc (nreverse lap) byte-compile-output)) + ;; but that fails to update byte-compile-depth, so we had to assume + ;; that `lap' ends up adding exactly 1 element to the stack. This + ;; happens to be true for byte-code generated by bytecomp.el without + ;; lexical-binding, but it's not true in general, and it's not true for + ;; code output by bytecomp.el with lexical-binding. + (dolist (op lap) + (cond + ((eq (car op) 'TAG) (byte-compile-out-tag op)) + ((memq (car op) byte-goto-ops) (byte-compile-goto (car op) (cdr op))) + (t (byte-compile-out (car op) (cdr op)))))) (defun byte-compile-inline-expand (form) (let* ((name (car form)) @@ -266,25 +277,32 @@ (cdr (assq name byte-compile-function-environment))))) (if (and (consp fn) (eq (car fn) 'autoload)) (error "File `%s' didn't define `%s'" (nth 1 fn) name)) - (if (and (symbolp fn) (not (eq fn t))) - (byte-compile-inline-expand (cons fn (cdr form))) - (if (byte-code-function-p fn) - (let (string) - (fetch-bytecode fn) - (setq string (aref fn 1)) - ;; Isn't it an error for `string' not to be unibyte?? --stef - (if (fboundp 'string-as-unibyte) - (setq string (string-as-unibyte string))) - ;; `byte-compile-splice-in-already-compiled-code' - ;; takes care of inlining the body. - (cons `(lambda ,(aref fn 0) - (byte-code ,string ,(aref fn 2) ,(aref fn 3))) - (cdr form))) - (if (eq (car-safe fn) 'lambda) - (macroexpand-all (cons fn (cdr form)) - byte-compile-macro-environment) - ;; Give up on inlining. - form)))))) + (cond + ((and (symbolp fn) (not (eq fn t))) ;A function alias. + (byte-compile-inline-expand (cons fn (cdr form)))) + ((and (byte-code-function-p fn) + ;; FIXME: This works to inline old-style-byte-codes into + ;; old-style-byte-codes, but not mixed cases (not sure + ;; about new-style into new-style). + (not lexical-binding) + (not (and (>= (length fn) 7) + (aref fn 6)))) ;6 = COMPILED_PUSH_ARGS + ;; (message "Inlining %S byte-code" name) + (fetch-bytecode fn) + (let ((string (aref fn 1))) + ;; Isn't it an error for `string' not to be unibyte?? --stef + (if (fboundp 'string-as-unibyte) + (setq string (string-as-unibyte string))) + ;; `byte-compile-splice-in-already-compiled-code' + ;; takes care of inlining the body. + (cons `(lambda ,(aref fn 0) + (byte-code ,string ,(aref fn 2) ,(aref fn 3))) + (cdr form)))) + ((eq (car-safe fn) 'lambda) + (macroexpand-all (cons fn (cdr form)) + byte-compile-macro-environment)) + (t ;; Give up on inlining. + form))))) ;; ((lambda ...) ...) (defun byte-compile-unfold-lambda (form &optional name) @@ -1298,10 +1316,7 @@ (if (not (memq byte-optimize '(t lap))) (byte-compile-normal-call form) (byte-inline-lapcode - (byte-decompile-bytecode-1 (nth 1 form) (nth 2 form) t)) - (setq byte-compile-maxdepth (max (+ byte-compile-depth (nth 3 form)) - byte-compile-maxdepth)) - (setq byte-compile-depth (1+ byte-compile-depth)))) + (byte-decompile-bytecode-1 (nth 1 form) (nth 2 form) t)))) (put 'byte-code 'byte-compile 'byte-compile-splice-in-already-compiled-code) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index e9beb0c5792..d3ac50a671a 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -752,9 +752,10 @@ BYTES and PC are updated after evaluating all the arguments." (bytes-var (car (last args 2))) (pc-var (car (last args)))) `(setq ,bytes-var ,(if (null (cdr byte-exprs)) - `(cons ,@byte-exprs ,bytes-var) - `(nconc (list ,@(reverse byte-exprs)) ,bytes-var)) - ,pc-var (+ ,(length byte-exprs) ,pc-var)))) + `(progn (assert (<= 0 ,(car byte-exprs))) + (cons ,@byte-exprs ,bytes-var)) + `(nconc (list ,@(reverse byte-exprs)) ,bytes-var)) + ,pc-var (+ ,(length byte-exprs) ,pc-var)))) (defmacro byte-compile-push-bytecode-const2 (opcode const2 bytes pc) "Push OPCODE and the two-byte constant CONST2 onto BYTES, and add 3 to PC. @@ -817,7 +818,7 @@ CONST2 may be evaulated multiple times." ;; These insns all put their operand into one extra byte. (byte-compile-push-bytecodes opcode off bytes pc)) ((= opcode byte-discardN) - ;; byte-discardN is wierd in that it encodes a flag in the + ;; byte-discardN is weird in that it encodes a flag in the ;; top bit of its one-byte argument. If the argument is ;; too large to fit in 7 bits, the opcode can be repeated. (let ((flag (if (eq op 'byte-discardN-preserve-tos) #x80 0))) @@ -1330,11 +1331,11 @@ extra args." (eq 'lambda (car-safe (cdr-safe old))) (setq old (cdr old))) (let ((sig1 (byte-compile-arglist-signature - (if (eq 'lambda (car-safe old)) - (nth 1 old) - (if (byte-code-function-p old) - (aref old 0) - '(&rest def))))) + (pcase old + (`(lambda ,args . ,_) args) + (`(closure ,_ ,_ ,args . ,_) args) + ((pred byte-code-function-p) (aref old 0)) + (t '(&rest def))))) (sig2 (byte-compile-arglist-signature (nth 2 form)))) (unless (byte-compile-arglist-signatures-congruent-p sig1 sig2) (byte-compile-set-symbol-position (nth 1 form)) @@ -1402,14 +1403,7 @@ extra args." ;; but such warnings are never useful, ;; so don't warn about them. macroexpand cl-macroexpand-all - cl-compiling-file))) - ;; Avoid warnings for things which are safe because they - ;; have suitable compiler macros, but those aren't - ;; expanded at this stage. There should probably be more - ;; here than caaar and friends. - (not (and (eq (get func 'byte-compile) - 'cl-byte-compile-compiler-macro) - (string-match "\\`c[ad]+r\\'" (symbol-name func))))) + cl-compiling-file)))) (byte-compile-warn "function `%s' from cl package called at runtime" func))) form) @@ -2701,8 +2695,8 @@ If FORM is a lambda or a macro, byte-compile it as a function." (if (eq (car-safe form) 'list) (byte-compile-top-level (nth 1 bytecomp-int)) (setq bytecomp-int (list 'interactive - (byte-compile-top-level - (nth 1 bytecomp-int))))))) + (byte-compile-top-level + (nth 1 bytecomp-int))))))) ((cdr bytecomp-int) (byte-compile-warn "malformed interactive spec: %s" (prin1-to-string bytecomp-int))))) @@ -2788,6 +2782,9 @@ If FORM is a lambda or a macro, byte-compile it as a function." (byte-compile-tag-number 0) (byte-compile-depth 0) (byte-compile-maxdepth 0) + (byte-compile-lexical-environment + (when (eq output-type 'lambda) + byte-compile-lexical-environment)) (byte-compile-output nil)) (if (memq byte-optimize '(t source)) (setq form (byte-optimize-form form for-effect))) @@ -2798,14 +2795,13 @@ If FORM is a lambda or a macro, byte-compile it as a function." (stringp (nth 1 form)) (vectorp (nth 2 form)) (natnump (nth 3 form))) form - ;; Set up things for a lexically-bound function + ;; Set up things for a lexically-bound function. (when (and lexical-binding (eq output-type 'lambda)) ;; See how many arguments there are, and set the current stack depth - ;; accordingly - (dolist (var byte-compile-lexical-environment) - (setq byte-compile-depth (1+ byte-compile-depth))) + ;; accordingly. + (setq byte-compile-depth (length byte-compile-lexical-environment)) ;; If there are args, output a tag to record the initial - ;; stack-depth for the optimizer + ;; stack-depth for the optimizer. (when (> byte-compile-depth 0) (byte-compile-out-tag (byte-compile-make-tag)))) ;; Now compile FORM @@ -2964,9 +2960,10 @@ That command is designed for interactive use only" bytecomp-fn)) ;; for CL compiler macros since the symbol may be ;; `cl-byte-compile-compiler-macro' but if CL isn't ;; loaded, this function doesn't exist. - (or (not (memq bytecomp-handler - '(cl-byte-compile-compiler-macro))) - (functionp bytecomp-handler))) + (and (not (eq bytecomp-handler + ;; Already handled by macroexpand-all. + 'cl-byte-compile-compiler-macro)) + (functionp bytecomp-handler))) (funcall bytecomp-handler form) (byte-compile-normal-call form)) (if (byte-compile-warning-enabled-p 'cl-functions) @@ -3612,7 +3609,7 @@ discarding." (byte-defop-compiler-1 while) (byte-defop-compiler-1 funcall) (byte-defop-compiler-1 let) -(byte-defop-compiler-1 let*) +(byte-defop-compiler-1 let* byte-compile-let) (defun byte-compile-progn (form) (byte-compile-body-do-effect (cdr form))) @@ -3819,10 +3816,8 @@ Return the offset in the form (VAR . OFFSET)." (byte-compile-push-constant nil))))) (defun byte-compile-not-lexical-var-p (var) - (or (not (symbolp var)) ; form is not a list - (if (eval-when-compile (fboundp 'special-variable-p)) - (special-variable-p var) - (boundp var)) + (or (not (symbolp var)) + (special-variable-p var) (memq var byte-compile-bound-variables) (memq var '(nil t)) (keywordp var))) @@ -3833,9 +3828,8 @@ INIT-LEXENV should be a lexical-environment alist describing the positions of the init value that have been pushed on the stack. Return non-nil if the TOS value was popped." ;; The presence of lexical bindings mean that we may have to - ;; juggle things on the stack, either to move them to TOS for - ;; dynamic binding, or to put them in a non-stack environment - ;; vector. + ;; juggle things on the stack, to move them to TOS for + ;; dynamic binding. (cond ((not (byte-compile-not-lexical-var-p var)) ;; VAR is a simple stack-allocated lexical variable (push (assq var init-lexenv) @@ -3883,56 +3877,41 @@ binding slots have been popped." (defun byte-compile-let (form) "Generate code for the `let' form FORM." - ;; First compute the binding values in the old scope. - (let ((varlist (car (cdr form))) - (init-lexenv nil)) - (dolist (var varlist) - (push (byte-compile-push-binding-init var) init-lexenv)) - ;; Now do the bindings, execute the body, and undo the bindings. - (let ((byte-compile-bound-variables byte-compile-bound-variables) ;new scope - (varlist (reverse (car (cdr form)))) + (let ((clauses (cadr form)) + (init-lexenv nil)) + (when (eq (car form) 'let) + ;; First compute the binding values in the old scope. + (dolist (var clauses) + (push (byte-compile-push-binding-init var) init-lexenv))) + ;; New scope. + (let ((byte-compile-bound-variables byte-compile-bound-variables) (byte-compile-lexical-environment byte-compile-lexical-environment)) - (dolist (var varlist) - (let ((var (if (consp var) (car var) var))) - (cond ((null lexical-binding) - ;; If there are no lexical bindings, we can do things simply. - (byte-compile-dynamic-variable-bind var)) - ((byte-compile-bind var init-lexenv) - (pop init-lexenv))))) + ;; Bind the variables. + ;; For `let', do it in reverse order, because it makes no + ;; semantic difference, but it is a lot more efficient since the + ;; values are now in reverse order on the stack. + (dolist (var (if (eq (car form) 'let) (reverse clauses) clauses)) + (unless (eq (car form) 'let) + (push (byte-compile-push-binding-init var) init-lexenv)) + (let ((var (if (consp var) (car var) var))) + (cond ((null lexical-binding) + ;; If there are no lexical bindings, we can do things simply. + (byte-compile-dynamic-variable-bind var)) + ((byte-compile-bind var init-lexenv) + (pop init-lexenv))))) ;; Emit the body. - (byte-compile-body-do-effect (cdr (cdr form))) - ;; Unbind the variables. - (if lexical-binding - ;; Unbind both lexical and dynamic variables. - (byte-compile-unbind varlist init-lexenv t) - ;; Unbind dynamic variables. - (byte-compile-out 'byte-unbind (length varlist)))))) - -(defun byte-compile-let* (form) - "Generate code for the `let*' form FORM." - (let ((byte-compile-bound-variables byte-compile-bound-variables) ;new scope - (clauses (cadr form)) - (init-lexenv nil) - ;; bind these to restrict the scope of any changes - - (byte-compile-lexical-environment byte-compile-lexical-environment)) - ;; Bind the variables - (dolist (var clauses) - (push (byte-compile-push-binding-init var) init-lexenv) - (let ((var (if (consp var) (car var) var))) - (cond ((null lexical-binding) - ;; If there are no lexical bindings, we can do things simply. - (byte-compile-dynamic-variable-bind var)) - ((byte-compile-bind var init-lexenv) - (pop init-lexenv))))) - ;; Emit the body - (byte-compile-body-do-effect (cdr (cdr form))) - ;; Unbind the variables - (if lexical-binding - ;; Unbind both lexical and dynamic variables - (byte-compile-unbind clauses init-lexenv t) - ;; Unbind dynamic variables - (byte-compile-out 'byte-unbind (length clauses))))) + (let ((init-stack-depth byte-compile-depth)) + (byte-compile-body-do-effect (cdr (cdr form))) + ;; Unbind the variables. + (if lexical-binding + ;; Unbind both lexical and dynamic variables. + (progn + (assert (or (eq byte-compile-depth init-stack-depth) + (eq byte-compile-depth (1+ init-stack-depth)))) + (byte-compile-unbind clauses init-lexenv (> byte-compile-depth + init-stack-depth))) + ;; Unbind dynamic variables. + (byte-compile-out 'byte-unbind (length clauses))))))) @@ -4254,8 +4233,8 @@ binding slots have been popped." (progn ;; ## remove this someday (and byte-compile-depth - (not (= (cdr (cdr tag)) byte-compile-depth)) - (error "Compiler bug: depth conflict at tag %d" (car (cdr tag)))) + (not (= (cdr (cdr tag)) byte-compile-depth)) + (error "Compiler bug: depth conflict at tag %d" (car (cdr tag)))) (setq byte-compile-depth (cdr (cdr tag)))) (setcdr (cdr tag) byte-compile-depth))) diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index 10464047cd3..d8f5a7da44d 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -70,6 +70,15 @@ ;; ;;; Code: +;;; TODO: +;; - Use abstract `make-closure' and `closure-ref' expressions, which bytecomp +;; should turn into building corresponding byte-code function. +;; - don't use `curry', instead build a new compiled-byte-code object +;; (merge the closure env into the static constants pool). +;; - use relative addresses for byte-code-stack-ref. +;; - warn about unused lexical vars. +;; - clean up cconv-closure-convert-rec, especially the `let' binding part. + (eval-when-compile (require 'cl)) (defconst cconv-liftwhen 3 @@ -187,14 +196,14 @@ Returns a list of free variables." -- TOPLEVEL(optional) is a boolean variable, true if we are at the root of AST Returns a form where all lambdas don't have any free variables." - (message "Entering cconv-closure-convert...") + ;; (message "Entering cconv-closure-convert...") (let ((cconv-mutated '()) (cconv-lambda-candidates '()) (cconv-captured '()) (cconv-captured+mutated '())) - ;; Analyse form - fill these variables with new information + ;; Analyse form - fill these variables with new information. (cconv-analyse-form form '() 0) - ;; Calculate an intersection of cconv-mutated and cconv-captured + ;; Calculate an intersection of cconv-mutated and cconv-captured. (dolist (mvr cconv-mutated) (when (memq mvr cconv-captured) ; (push mvr cconv-captured+mutated))) @@ -216,14 +225,51 @@ Returns a form where all lambdas don't have any free variables." res)) (defconst cconv--dummy-var (make-symbol "ignored")) +(defconst cconv--env-var (make-symbol "env")) + +(defun cconv--set-diff (s1 s2) + "Return elements of set S1 that are not in set S2." + (let ((res '())) + (dolist (x s1) + (unless (memq x s2) (push x res))) + (nreverse res))) + +(defun cconv--set-diff-map (s m) + "Return elements of set S that are not in Dom(M)." + (let ((res '())) + (dolist (x s) + (unless (assq x m) (push x res))) + (nreverse res))) + +(defun cconv--map-diff (m1 m2) + "Return the submap of map M1 that has Dom(M2) removed." + (let ((res '())) + (dolist (x m1) + (unless (assq (car x) m2) (push x res))) + (nreverse res))) + +(defun cconv--map-diff-elem (m x) + "Return the map M minus any mapping for X." + ;; Here we assume that X appears at most once in M. + (let* ((b (assq x m)) + (res (if b (remq b m) m))) + (assert (null (assq x res))) ;; Check the assumption was warranted. + res)) -(defun cconv-closure-convert-rec - (form emvrs fvrs envs lmenvs) +(defun cconv--map-diff-set (m s) + "Return the map M minus any mapping for elements of S." + ;; Here we assume that X appears at most once in M. + (let ((res '())) + (dolist (b m) + (unless (memq (car b) s) (push b res))) + (nreverse res))) + +(defun cconv-closure-convert-rec (form emvrs fvrs envs lmenvs) ;; This function actually rewrites the tree. "Eliminates all free variables of all lambdas in given forms. Arguments: -- FORM is a piece of Elisp code after macroexpansion. --- LMENVS is a list of environments used for lambda-lifting. Initially empty. +-- LMENVS is a list of environments used for lambda-lifting. Initially empty. -- EMVRS is a list that contains mutated variables that are visible within current environment. -- ENVS is an environment(list of free variables) of current closure. @@ -343,10 +389,9 @@ Returns a form where all lambdas don't have any free variables." (setq lmenvs (remq old-lmenv lmenvs)) (push new-lmenv lmenvs) (push `(,closedsym ,var) binders-new)))) - ;; we push the element after redefined free variables - ;; are processes. this is important to avoid the bug - ;; when free variable and the function have the same - ;; name + ;; We push the element after redefined free variables are + ;; processed. This is important to avoid the bug when free + ;; variable and the function have the same name. (push (list var new-val) binders-new) (when (eq letsym 'let*) ; update fvrs @@ -355,11 +400,7 @@ Returns a form where all lambdas don't have any free variables." (when emvr-push (push emvr-push emvrs) (setq emvr-push nil)) - (let (lmenvs-1) ; remove var from lmenvs if redefined - (dolist (iter lmenvs) - (when (not (assq var lmenvs)) - (push iter lmenvs-1))) - (setq lmenvs lmenvs-1)) + (setq lmenvs (cconv--map-diff-elem lmenvs var)) (when lmenv-push (push lmenv-push lmenvs) (setq lmenv-push nil))) @@ -368,19 +409,10 @@ Returns a form where all lambdas don't have any free variables." (let (var fvrs-1 emvrs-1 lmenvs-1) ;; Here we update emvrs, fvrs and lmenvs lists - (dolist (vr fvrs) - ; safely remove - (when (not (assq vr binders-new)) (push vr fvrs-1))) - (setq fvrs fvrs-1) - (dolist (vr emvrs) - ; safely remove - (when (not (assq vr binders-new)) (push vr emvrs-1))) - (setq emvrs emvrs-1) - ; push new + (setq fvrs (cconv--set-diff-map fvrs binders-new)) + (setq emvrs (cconv--set-diff-map emvrs binders-new)) (setq emvrs (append emvrs emvrs-new)) - (dolist (vr lmenvs) - (when (not (assq (car vr) binders-new)) - (push vr lmenvs-1))) + (setq lmenvs (cconv--set-diff-map lmenvs binders-new)) (setq lmenvs (append lmenvs lmenvs-new))) ;; Here we do the same letbinding as for let* above @@ -402,9 +434,9 @@ Returns a form where all lambdas don't have any free variables." (symbol-name var)))) (setq new-lmenv (list (car lmenv))) - (dolist (frv (cdr lmenv)) (if (eq frv var) - (push closedsym new-lmenv) - (push frv new-lmenv))) + (dolist (frv (cdr lmenv)) + (push (if (eq frv var) closedsym frv) + new-lmenv)) (setq new-lmenv (reverse new-lmenv)) (setq lmenvs (remq lmenv lmenvs)) (push new-lmenv lmenvs) @@ -449,13 +481,9 @@ Returns a form where all lambdas don't have any free variables." (`(quote . ,_) form) ; quote form (`(function . ((lambda ,vars . ,body-forms))) ; function form - (let (fvrs-new) ; we remove vars from fvrs - (dolist (elm fvrs) ;i use such a tricky way to avoid side effects - (when (not (memq elm vars)) - (push elm fvrs-new))) - (setq fvrs fvrs-new)) - (let* ((fv (delete-dups (cconv-freevars form '()))) - (leave fvrs) ; leave = non nil if we should leave env unchanged + (let* ((fvrs-new (cconv--set-diff fvrs vars)) ; Remove vars from fvrs. + (fv (delete-dups (cconv-freevars form '()))) + (leave fvrs-new) ; leave=non-nil if we should leave env unchanged. (body-forms-new '()) (letbind '()) (mv nil) @@ -470,7 +498,7 @@ Returns a form where all lambdas don't have any free variables." (if (eq (length envs) (length fv)) (let ((fv-temp fv)) (while (and fv-temp leave) - (when (not (memq (car fv-temp) fvrs)) (setq leave nil)) + (when (not (memq (car fv-temp) fvrs-new)) (setq leave nil)) (setq fv-temp (cdr fv-temp)))) (setq leave nil)) @@ -479,23 +507,30 @@ Returns a form where all lambdas don't have any free variables." (dolist (elm fv) (push (cconv-closure-convert-rec + ;; Remove `elm' from `emvrs' for this call because in case + ;; `elm' is a variable that's wrapped in a cons-cell, we + ;; want to put the cons-cell itself in the closure, rather + ;; than just a copy of its current content. elm (remq elm emvrs) fvrs envs lmenvs) - envector)) ; process vars for closure vector + envector)) ; Process vars for closure vector. (setq envector (reverse envector)) (setq envs fv)) - (setq envector `(env))) ; leave unchanged - (setq fvrs fv)) ; update substitution list - - ;; the difference between envs and fvrs is explained - ;; in comment in the beginning of the function - (dolist (elm cconv-captured+mutated) ; find mutated arguments - (setq mv (car elm)) ; used in inner closures + (setq envector `(,cconv--env-var))) ; Leave unchanged. + (setq fvrs-new fv)) ; Update substitution list. + + (setq emvrs (cconv--set-diff emvrs vars)) + (setq lmenvs (cconv--map-diff-set lmenvs vars)) + + ;; The difference between envs and fvrs is explained + ;; in comment in the beginning of the function. + (dolist (elm cconv-captured+mutated) ; Find mutated arguments + (setq mv (car elm)) ; used in inner closures. (when (and (memq mv vars) (eq form (caddr elm))) (progn (push mv emvrs) (push `(,mv (list ,mv)) letbind)))) (dolist (elm body-forms) ; convert function body (push (cconv-closure-convert-rec - elm emvrs fvrs envs lmenvs) + elm emvrs fvrs-new envs lmenvs) body-forms-new)) (setq body-forms-new @@ -509,12 +544,12 @@ Returns a form where all lambdas don't have any free variables." ; 1 free variable - do not build vector ((null (cdr envector)) `(curry - (function (lambda (env . ,vars) . ,body-forms-new)) + (function (lambda (,cconv--env-var . ,vars) . ,body-forms-new)) ,(car envector))) ; >=2 free variables - build vector (t `(curry - (function (lambda (env . ,vars) . ,body-forms-new)) + (function (lambda (,cconv--env-var . ,vars) . ,body-forms-new)) (vector . ,envector)))))) (`(function . ,_) form) ; same as quote @@ -674,13 +709,10 @@ Returns a form where all lambdas don't have any free variables." (let ((free (memq form fvrs))) (if free ;form is a free variable (let* ((numero (- (length fvrs) (length free))) - (var '())) - (assert numero) - (if (null (cdr envs)) - (setq var 'env) - ;replace form => - ;(aref env #) - (setq var `(aref env ,numero))) + (var (if (null (cdr envs)) + cconv--env-var + ;; Replace form => (aref env #) + `(aref ,cconv--env-var ,numero)))) (if (memq form emvrs) ; form => (car (aref env #)) if mutable `(car ,var) var)) diff --git a/lisp/emacs-lisp/cl-loaddefs.el b/lisp/emacs-lisp/cl-loaddefs.el index e10dc10447c..a13e46ccc59 100644 --- a/lisp/emacs-lisp/cl-loaddefs.el +++ b/lisp/emacs-lisp/cl-loaddefs.el @@ -282,7 +282,7 @@ Not documented ;;;;;; do-all-symbols do-symbols dotimes dolist do* do loop return-from ;;;;;; return block etypecase typecase ecase case load-time-value ;;;;;; eval-when destructuring-bind function* defmacro* defun* gentemp -;;;;;; gensym) "cl-macs" "cl-macs.el" "0904b956872432ae7cc5fa9abcefce63") +;;;;;; gensym) "cl-macs" "cl-macs.el" "7602128fa01003de9a8df4c752865300") ;;; Generated autoloads from cl-macs.el (autoload 'gensym "cl-macs" "\ diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 80e95724f1f..093e4fbf258 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -602,7 +602,13 @@ called from BODY." (put 'cl-block-wrapper 'byte-compile 'cl-byte-compile-block) (defun cl-byte-compile-block (cl-form) - (if (fboundp 'byte-compile-form-do-effect) ; Check for optimizing compiler + ;; Here we try to determine if a catch tag is used or not, so as to get rid + ;; of the catch when it's not used. + (if (and (fboundp 'byte-compile-form-do-effect) ; Optimizing compiler? + ;; FIXME: byte-compile-top-level can only be used for code that is + ;; closed (as the name implies), so for lexical scoping we should + ;; implement this optimization differently. + (not lexical-binding)) (progn (let* ((cl-entry (cons (nth 1 (nth 1 (nth 1 cl-form))) nil)) (cl-active-block-names (cons cl-entry cl-active-block-names)) diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 7990df264a9..a338de251ed 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -1,5 +1,4 @@ -;;; -*- lexical-binding: t -*- -;;; pcase.el --- ML-style pattern-matching macro for Elisp +;;; pcase.el --- ML-style pattern-matching macro for Elisp -*- lexical-binding: t -*- ;; Copyright (C) 2010-2011 Free Software Foundation, Inc. diff --git a/lisp/files.el b/lisp/files.el index 8b42eaaddb8..e7dd96ca2ff 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -2851,18 +2851,19 @@ asking you for confirmation." ;; ;; For variables defined in the C source code the declaration should go here: -(mapc (lambda (pair) - (put (car pair) 'safe-local-variable (cdr pair))) - '((buffer-read-only . booleanp) ;; C source code - (default-directory . stringp) ;; C source code - (fill-column . integerp) ;; C source code - (indent-tabs-mode . booleanp) ;; C source code - (left-margin . integerp) ;; C source code - (no-update-autoloads . booleanp) - (tab-width . integerp) ;; C source code - (truncate-lines . booleanp) ;; C source code - (word-wrap . booleanp) ;; C source code - (bidi-display-reordering . booleanp))) ;; C source code +(dolist (pair + '((buffer-read-only . booleanp) ;; C source code + (default-directory . stringp) ;; C source code + (fill-column . integerp) ;; C source code + (indent-tabs-mode . booleanp) ;; C source code + (left-margin . integerp) ;; C source code + (no-update-autoloads . booleanp) + (lexical-binding . booleanp) ;; C source code + (tab-width . integerp) ;; C source code + (truncate-lines . booleanp) ;; C source code + (word-wrap . booleanp) ;; C source code + (bidi-display-reordering . booleanp))) ;; C source code + (put (car pair) 'safe-local-variable (cdr pair))) (put 'bidi-paragraph-direction 'safe-local-variable (lambda (v) (memq v '(nil right-to-left left-to-right)))) diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 172a74d8c80..49767e6e9d3 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -530,7 +530,7 @@ suitable file is found, return nil." (let ((fill-begin (point))) (insert (car high) "\n") (fill-region fill-begin (point))) - (setq doc (cdr high)))) + (setq doc (cdr high)))) (let* ((obsolete (and ;; function might be a lambda construct. (symbolp function) diff --git a/src/ChangeLog b/src/ChangeLog index 6674fb31ca5..0b2ee8550ca 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,13 @@ +2011-02-17 Stefan Monnier + + * eval.c (Vinternal_interpreter_environment): Remove. + (syms_of_eval): Do declare Vinternal_interpreter_environment as + a global lisp var, but unintern it to hide it. + (Fcommandp): + * data.c (Finteractive_form): Understand `closure's. + + * bytecode.c (exec_byte_code): Fix handling of &rest. + 2011-02-12 Stefan Monnier * bytecode.c (Bvec_ref, Bvec_set): Remove. diff --git a/src/bytecode.c b/src/bytecode.c index 9bf6ae45ce9..1ad01aaf8f7 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -500,7 +500,9 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, optional = 1; else if (EQ (XCAR (at), Qand_rest)) { - PUSH (Flist (nargs, args)); + PUSH (pushed < nargs + ? Flist (nargs - pushed, args) + : Qnil); pushed = nargs; at = Qnil; break; diff --git a/src/data.c b/src/data.c index 83da3e103cb..2f17edd3fdc 100644 --- a/src/data.c +++ b/src/data.c @@ -755,6 +755,8 @@ Value, if non-nil, is a list \(interactive SPEC). */) else if (CONSP (fun)) { Lisp_Object funcar = XCAR (fun); + if (EQ (funcar, Qclosure)) + fun = Fcdr (XCDR (fun)), funcar = Fcar (fun); if (EQ (funcar, Qlambda)) return Fassq (Qinteractive, Fcdr (XCDR (fun))); else if (EQ (funcar, Qautoload)) diff --git a/src/eval.c b/src/eval.c index 9adfc983ced..63484d40e1b 100644 --- a/src/eval.c +++ b/src/eval.c @@ -78,16 +78,6 @@ Lisp_Object Vrun_hooks; Lisp_Object Vautoload_queue; -/* When lexical binding is being used, this is non-nil, and contains an - alist of lexically-bound variable, or (t), indicating an empty - environment. The lisp name of this variable is - `internal-interpreter-environment'. 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. */ - -Lisp_Object Vinternal_interpreter_environment; - /* Current number of specbindings allocated in specpdl. */ EMACS_INT specpdl_size; @@ -2092,9 +2082,11 @@ then strings and vectors are not accepted. */) if (!CONSP (fun)) return Qnil; funcar = XCAR (fun); + if (EQ (funcar, Qclosure)) + fun = Fcdr (XCDR (fun)), funcar = Fcar (fun); 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; @@ -3695,6 +3687,8 @@ mark_backtrace (void) } } +EXFUN (Funintern, 2); + void syms_of_eval (void) { @@ -3840,19 +3834,27 @@ 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); -#if 0 /* Don't export this variable to Elisp, so noone can mess with it - (Just imagine if someone makes it buffer-local). */ - DEFVAR__LISP ("internal-interpreter-environment", - Vinternal_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. */); -#endif 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); diff --git a/src/lisp.h b/src/lisp.h index 906736bacad..0e7eeebc9da 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2855,7 +2855,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; -- cgit v1.3 From e0f57e65692ed73a86926f737388b60faec92767 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Sat, 19 Feb 2011 00:10:33 -0500 Subject: * lisp/subr.el (save-window-excursion): New macro, moved from C. * lisp/emacs-lisp/lisp-mode.el (save-window-excursion): Don't touch. * lisp/emacs-lisp/cconv.el (cconv-closure-convert-rec, cconv-analyse-form): Don't handle save-window-excursion any more. * lisp/emacs-lisp/bytecomp.el (interactive-p, save-window-excursion): Don't use the byte-code any more. (byte-compile-form): Check macro expansion was done. (byte-compile-save-window-excursion): Remove. * lisp/emacs-lisp/byte-opt.el (byte-optimize-form-code-walker): Ignore save-window-excursion. Don't macroepand any more. * src/window.c (Fsave_window_excursion): Remove. Moved to Lisp. (syms_of_window): Don't defsubr it. * src/window.h (Fsave_window_excursion): Don't declare it. * src/bytecode.c (exec_byte_code): Inline Fsave_window_excursion. --- lisp/ChangeLog | 13 +++++++++++++ lisp/emacs-lisp/byte-opt.el | 21 +-------------------- lisp/emacs-lisp/bytecomp.el | 18 ++++-------------- lisp/emacs-lisp/cconv.el | 6 +++--- lisp/emacs-lisp/lisp-mode.el | 1 - lisp/subr.el | 19 +++++++++++++++++++ src/ChangeLog | 7 +++++++ src/bytecode.c | 32 ++++++++++++++++++++------------ src/window.c | 23 ----------------------- src/window.h | 1 - 10 files changed, 67 insertions(+), 74 deletions(-) (limited to 'src/bytecode.c') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 6b6555ab7e3..ae91513937c 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,16 @@ +2011-02-19 Stefan Monnier + + * subr.el (save-window-excursion): New macro, moved from C. + * emacs-lisp/lisp-mode.el (save-window-excursion): Don't touch. + * emacs-lisp/cconv.el (cconv-closure-convert-rec, cconv-analyse-form): + Don't handle save-window-excursion any more. + * emacs-lisp/bytecomp.el (interactive-p, save-window-excursion): + Don't use the byte-code any more. + (byte-compile-form): Check macro expansion was done. + (byte-compile-save-window-excursion): Remove. + * emacs-lisp/byte-opt.el (byte-optimize-form-code-walker): + Ignore save-window-excursion. Don't macroepand any more. + 2011-02-18 Stefan Monnier * emacs-lisp/pcase.el (pcase--expand, pcase--u, pcase--u1, pcase--q1): diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 12df3251267..038db292350 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -498,8 +498,7 @@ (prin1-to-string form)) nil) - ((memq fn '(defun defmacro function - condition-case save-window-excursion)) + ((memq fn '(defun defmacro function condition-case)) ;; These forms are compiled as constants or by breaking out ;; all the subexpressions and compiling them separately. form) @@ -530,24 +529,6 @@ ;; However, don't actually bother calling `ignore'. `(prog1 nil . ,(mapcar 'byte-optimize-form (cdr form)))) - ;; If optimization is on, this is the only place that macros are - ;; expanded. If optimization is off, then macroexpansion happens - ;; in byte-compile-form. Otherwise, the macros are already expanded - ;; by the time that is reached. - ((not (eq form - (setq form (macroexpand form - byte-compile-macro-environment)))) - (byte-optimize-form form for-effect)) - - ;; Support compiler macros as in cl.el. - ((and (fboundp 'compiler-macroexpand) - (symbolp (car-safe form)) - (get (car-safe form) 'cl-compiler-macro) - (not (eq form - (with-no-warnings - (setq form (compiler-macroexpand form)))))) - (byte-optimize-form form for-effect)) - ((not (symbolp fn)) (byte-compile-warn "`%s' is a malformed function" (prin1-to-string fn)) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index d3ac50a671a..54a1912169a 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -586,7 +586,6 @@ Each element is (INDEX . VALUE)") (byte-defop 114 0 byte-save-current-buffer "To make a binding to record the current buffer") (byte-defop 115 0 byte-set-mark-OBSOLETE) -(byte-defop 116 1 byte-interactive-p) ;; These ops are new to v19 (byte-defop 117 0 byte-forward-char) @@ -622,8 +621,6 @@ otherwise pop it") (byte-defop 138 0 byte-save-excursion "to make a binding to record the buffer, point and mark") -(byte-defop 139 0 byte-save-window-excursion - "to make a binding to record entire window configuration") (byte-defop 140 0 byte-save-restriction "to make a binding to record the current buffer clipping restrictions") (byte-defop 141 -1 byte-catch @@ -2955,6 +2952,10 @@ That command is designed for interactive use only" bytecomp-fn)) custom-declare-face)) (byte-compile-nogroup-warn form)) (byte-compile-callargs-warn form)) + (if (and (fboundp (car form)) + (eq (car-safe (indirect-function (car form))) 'macro)) + (byte-compile-report-error + (format "Forgot to expand macro %s" (car form)))) (if (and bytecomp-handler ;; Make sure that function exists. This is important ;; for CL compiler macros since the symbol may be @@ -3167,7 +3168,6 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (byte-defop-compiler bobp 0) (byte-defop-compiler current-buffer 0) ;;(byte-defop-compiler read-char 0) ;; obsolete -(byte-defop-compiler interactive-p 0) (byte-defop-compiler widen 0) (byte-defop-compiler end-of-line 0-1) (byte-defop-compiler forward-char 0-1) @@ -3946,7 +3946,6 @@ binding slots have been popped." (byte-defop-compiler-1 save-excursion) (byte-defop-compiler-1 save-current-buffer) (byte-defop-compiler-1 save-restriction) -(byte-defop-compiler-1 save-window-excursion) (byte-defop-compiler-1 with-output-to-temp-buffer) (byte-defop-compiler-1 track-mouse) @@ -4047,15 +4046,6 @@ binding slots have been popped." (byte-compile-body-do-effect (cdr form)) (byte-compile-out 'byte-unbind 1)) -(defun byte-compile-save-window-excursion (form) - (pcase (cdr form) - (`(:fun-body ,f) - (byte-compile-form `(list (list 'funcall ,f)))) - (body - (byte-compile-push-constant - (byte-compile-top-level-body body for-effect)))) - (byte-compile-out 'byte-save-window-excursion 0)) - (defun byte-compile-with-output-to-temp-buffer (form) (byte-compile-form (car (cdr form))) (byte-compile-out 'byte-temp-output-buffer-setup 0) diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index d8f5a7da44d..4e42e9f3c1d 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -635,8 +635,8 @@ Returns a form where all lambdas don't have any free variables." ,(cconv-closure-convert-rec `(function (lambda () ,@body)) emvrs fvrs envs lmenvs))) - (`(,(and head (or `save-window-excursion `track-mouse)) . ,body) - `(,head + (`(track-mouse . ,body) + `(track-mouse :fun-body ,(cconv-closure-convert-rec `(function (lambda () ,@body)) emvrs fvrs envs lmenvs))) @@ -827,7 +827,7 @@ lambdas if they are suitable for lambda lifting. ;; FIXME: The bytecode for save-window-excursion and the lack of ;; bytecode for track-mouse forces us to wrap the body. - (`(,(or `save-window-excursion `track-mouse) . ,body) + (`(track-mouse . ,body) (setq inclosure (1+ inclosure)) (dolist (form body) (cconv-analyse-form form env inclosure))) diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index 37a86b7135d..85717408121 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -1209,7 +1209,6 @@ This function also returns nil meaning don't specify the indentation." (put 'prog1 'lisp-indent-function 1) (put 'prog2 'lisp-indent-function 2) (put 'save-excursion 'lisp-indent-function 0) -(put 'save-window-excursion 'lisp-indent-function 0) (put 'save-restriction 'lisp-indent-function 0) (put 'save-match-data 'lisp-indent-function 0) (put 'save-current-buffer 'lisp-indent-function 0) diff --git a/lisp/subr.el b/lisp/subr.el index c72752eb8f2..626128c62b3 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -2767,6 +2767,25 @@ nor the buffer list." (when (buffer-live-p ,old-buffer) (set-buffer ,old-buffer)))))) +(defmacro save-window-excursion (&rest body) + "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. + +BEWARE: Most uses of this macro introduce bugs. +E.g. it should not be used to try and prevent some code from opening +a new window, since that window may sometimes appear in another frame, +in which case `save-window-excursion' cannot help." + (declare (indent 0) (debug t)) + (let ((c (make-symbol "wconfig"))) + `(let ((,c (current-window-configuration))) + (unwind-protect (progn ,@body) + (set-window-configuration ,c))))) + (defmacro with-temp-file (file &rest body) "Create a new buffer, evaluate BODY there, and write the buffer to FILE. The value returned is the value of the last form in BODY. diff --git a/src/ChangeLog b/src/ChangeLog index 0b2ee8550ca..6bebce0abaa 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,10 @@ +2011-02-19 Stefan Monnier + + * window.c (Fsave_window_excursion): Remove. Moved to Lisp. + (syms_of_window): Don't defsubr it. + * window.h (Fsave_window_excursion): Don't declare it. + * bytecode.c (exec_byte_code): Inline Fsave_window_excursion. + 2011-02-17 Stefan Monnier * eval.c (Vinternal_interpreter_environment): Remove. diff --git a/src/bytecode.c b/src/bytecode.c index 1ad01aaf8f7..ad2f7d18ade 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -138,7 +138,7 @@ extern Lisp_Object Qand_optional, Qand_rest; #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 +158,7 @@ extern Lisp_Object Qand_optional, Qand_rest; #define Bsave_current_buffer_1 0162 /* Replacing Bsave_current_buffer. */ #define Bread_char 0162 /* No longer generated as of v19 */ #define Bset_mark 0163 /* this loser is no longer generated as of v18 */ -#define Binteractive_p 0164 /* Needed since interactive-p takes unevalled args */ +#define Binteractive_p 0164 /* Obsolete. */ #define Bforward_char 0165 #define Bforward_word 0166 @@ -183,7 +183,7 @@ extern Lisp_Object Qand_optional, Qand_rest; #define Bdup 0211 #define Bsave_excursion 0212 -#define Bsave_window_excursion 0213 +#define Bsave_window_excursion 0213 /* Obsolete. */ #define Bsave_restriction 0214 #define Bcatch 0215 @@ -192,7 +192,7 @@ extern Lisp_Object Qand_optional, Qand_rest; #define Btemp_output_buffer_setup 0220 #define Btemp_output_buffer_show 0221 -#define Bunbind_all 0222 +#define Bunbind_all 0222 /* Obsolete. */ #define Bset_marker 0223 #define Bmatch_beginning 0224 @@ -763,7 +763,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, AFTER_POTENTIAL_GC (); break; - case Bunbind_all: + case Bunbind_all: /* Obsolete. */ /* To unbind back to the beginning of this frame. Not used yet, but will be needed for tail-recursion elimination. */ BEFORE_POTENTIAL_GC (); @@ -891,16 +891,24 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, save_excursion_save ()); break; - case Bsave_current_buffer: + case Bsave_current_buffer: /* Obsolete. */ 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); /* FIXME: lexbind */ - AFTER_POTENTIAL_GC (); - break; + case Bsave_window_excursion: /* Obsolete. */ + { + register Lisp_Object val; + 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, @@ -1412,7 +1420,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, AFTER_POTENTIAL_GC (); break; - case Binteractive_p: + case Binteractive_p: /* Obsolete. */ PUSH (Finteractive_p ()); break; diff --git a/src/window.c b/src/window.c index abf01758c3f..c90cc268a92 100644 --- a/src/window.c +++ b/src/window.c @@ -6400,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 @@ -7195,7 +7173,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 491ffa30bd1..473a43bbc3c 100644 --- a/src/window.h +++ b/src/window.h @@ -860,7 +860,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); -- cgit v1.3 From 3e21b6a72b87787e2327513a44623b250054f77d Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Mon, 21 Feb 2011 15:12:44 -0500 Subject: Use offsets relative to top rather than bottom for stack refs * lisp/emacs-lisp/byte-opt.el (byte-compile-side-effect-and-error-free-ops): Remove interactive-p. (byte-optimize-lapcode): Update optimizations now that stack-refs are relative to the top rather than to the bottom. * lisp/emacs-lisp/bytecomp.el (byte-compile-lapcode): Turn stack-ref-0 into dup. (byte-compile-form): Don't indirect-function since it can signal errors. (byte-compile-stack-ref, byte-compile-stack-set): Adjust to stack-refs being relative to top rather than to bottom in the byte-code. (with-output-to-temp-buffer): Remove. (byte-compile-with-output-to-temp-buffer): Remove. * lisp/emacs-lisp/cconv.el: Use lexical-binding. (cconv--lookup-let): Rename from cconv-lookup-let. (cconv-closure-convert-rec): Fix handling of captured+mutated arguments in defun/defmacro. * lisp/emacs-lisp/eieio-comp.el (eieio-byte-compile-file-form-defmethod): Rename from byte-compile-file-form-defmethod. Don't byte-compile-lambda. (eieio-byte-compile-defmethod-param-convert): Rename from byte-compile-defmethod-param-convert. * lisp/emacs-lisp/eieio.el (eieio-defgeneric-form-primary-only-one): Call byte-compile rather than byte-compile-lambda. * src/alloc.c (Fgarbage_collect): Don't mark the byte-stack redundantly. * src/bytecode.c (exec_byte_code): Change stack_ref and stack_set to use offsets relative to top rather than to bottom. * lisp/subr.el (with-output-to-temp-buffer): New macro. * lisp/simple.el (count-words-region): Don't use interactive-p. --- lisp/ChangeLog | 39 ++++++++++++ lisp/emacs-lisp/byte-opt.el | 143 ++++++++++++++++++++---------------------- lisp/emacs-lisp/bytecomp.el | 34 +++++----- lisp/emacs-lisp/cconv.el | 45 +++++++------ lisp/emacs-lisp/eieio-comp.el | 11 ++-- lisp/emacs-lisp/eieio.el | 17 +++-- lisp/simple.el | 3 +- lisp/subr.el | 51 +++++++++++++-- src/ChangeLog | 7 +++ src/alloc.c | 2 +- src/bytecode.c | 52 +++++++++------ src/print.c | 57 +---------------- src/window.c | 12 +++- 13 files changed, 263 insertions(+), 210 deletions(-) (limited to 'src/bytecode.c') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index ae91513937c..4e2e87ab60f 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,42 @@ +2011-02-21 Stefan Monnier + + * subr.el (with-output-to-temp-buffer): New macro. + + * simple.el (count-words-region): Don't use interactive-p. + + * minibuffer.el: Use lexical-binding. Replace all uses of lexical-let. + + * emacs-lisp/eieio.el (eieio-defgeneric-form-primary-only-one): + Call byte-compile rather than byte-compile-lambda. + + * emacs-lisp/eieio-comp.el (eieio-byte-compile-file-form-defmethod): + Rename from byte-compile-file-form-defmethod. + Don't byte-compile-lambda. + (eieio-byte-compile-defmethod-param-convert): Rename from + byte-compile-defmethod-param-convert. + + * emacs-lisp/cl-extra.el (cl-macroexpand-all): Don't assume that the + value of (function (lambda ...)) is self-quoting. + + * emacs-lisp/cconv.el: Use lexical-binding. + (cconv--lookup-let): Rename from cconv-lookup-let. + (cconv-closure-convert-rec): Fix handling of captured+mutated + arguments in defun/defmacro. + + * emacs-lisp/bytecomp.el (byte-compile-lapcode): + Turn stack-ref-0 into dup. + (byte-compile-form): Don't indirect-function since it can signal + errors. + (byte-compile-stack-ref, byte-compile-stack-set): Adjust to stack-refs + being relative to top rather than to bottom in the byte-code. + (with-output-to-temp-buffer): Remove. + (byte-compile-with-output-to-temp-buffer): Remove. + + * emacs-lisp/byte-opt.el (byte-compile-side-effect-and-error-free-ops): + Remove interactive-p. + (byte-optimize-lapcode): Update optimizations now that stack-refs are + relative to the top rather than to the bottom. + 2011-02-19 Stefan Monnier * subr.el (save-window-excursion): New macro, moved from C. diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 038db292350..e415b5edde2 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -1470,7 +1470,7 @@ byte-cdr-safe byte-cons byte-list1 byte-list2 byte-point byte-point-max byte-point-min byte-following-char byte-preceding-char byte-current-column byte-eolp byte-eobp byte-bolp byte-bobp - byte-current-buffer byte-interactive-p byte-stack-ref)) + byte-current-buffer byte-stack-ref)) (defconst byte-compile-side-effect-free-ops (nconc @@ -1628,14 +1628,15 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; const/dup varbind-X varref-X --> const/dup varbind-X const/dup ;; The latter two can enable other optimizations. ;; - ((or (and (eq 'byte-varref (car lap2)) - (eq (cdr lap1) (cdr lap2)) - (memq (car lap1) '(byte-varset byte-varbind))) - (and (eq (car lap2) 'byte-stack-ref) - (eq (car lap1) 'byte-stack-set) - (eq (cdr lap1) (cdr lap2)))) - (if (and (eq 'byte-varref (car lap2)) - (setq tmp (memq (car (cdr lap2)) byte-boolean-vars)) + ;; For lexical variables, we could do the same + ;; stack-set-X+1 stack-ref-X --> dup stack-set-X+2 + ;; but this is a very minor gain, since dup is stack-ref-0, + ;; i.e. it's only better if X>5, and even then it comes + ;; at the cost cost of an extra stack slot. Let's not bother. + ((and (eq 'byte-varref (car lap2)) + (eq (cdr lap1) (cdr lap2)) + (memq (car lap1) '(byte-varset byte-varbind))) + (if (and (setq tmp (memq (car (cdr lap2)) byte-boolean-vars)) (not (eq (car lap0) 'byte-constant))) nil (setq keep-going t) @@ -1663,15 +1664,18 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; ;; dup varset-X discard --> varset-X ;; dup varbind-X discard --> varbind-X + ;; dup stack-set-X discard --> stack-set-X-1 ;; (the varbind variant can emerge from other optimizations) ;; ((and (eq 'byte-dup (car lap0)) (eq 'byte-discard (car lap2)) - (memq (car lap1) '(byte-varset byte-varbind byte-stack-set))) + (memq (car lap1) '(byte-varset byte-varbind + byte-stack-set))) (byte-compile-log-lap " dup %s discard\t-->\t%s" lap1 lap1) (setq keep-going t rest (cdr rest) stack-adjust -1) + (if (eq 'byte-stack-set (car lap1)) (decf (cdr lap1))) (setq lap (delq lap0 (delq lap2 lap)))) ;; ;; not goto-X-if-nil --> goto-X-if-non-nil @@ -1739,18 +1743,24 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; ;; varref-X varref-X --> varref-X dup ;; varref-X [dup ...] varref-X --> varref-X [dup ...] dup + ;; stackref-X [dup ...] stackref-X+N --> stackref-X [dup ...] dup ;; We don't optimize the const-X variations on this here, ;; because that would inhibit some goto optimizations; we ;; optimize the const-X case after all other optimizations. ;; ((and (memq (car lap0) '(byte-varref byte-stack-ref)) (progn - (setq tmp (cdr rest) tmp2 0) + (setq tmp (cdr rest)) + (setq tmp2 0) (while (eq (car (car tmp)) 'byte-dup) - (setq tmp (cdr tmp) tmp2 (1+ tmp2))) + (setq tmp2 (1+ tmp2)) + (setq tmp (cdr tmp))) t) - (eq (car lap0) (car (car tmp))) - (eq (cdr lap0) (cdr (car tmp)))) + (eq (if (eq 'byte-stack-ref (car lap0)) + (+ tmp2 1 (cdr lap0)) + (cdr lap0)) + (cdr (car tmp))) + (eq (car lap0) (car (car tmp)))) (if (memq byte-optimize-log '(t byte)) (let ((str "")) (setq tmp2 (cdr rest)) @@ -1857,14 +1867,6 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." "")) (setq keep-going t)) ;; - ;; stack-ref-N --> dup ; where N is TOS - ;; - ((and stack-depth (eq (car lap0) 'byte-stack-ref) - (= (cdr lap0) (1- stack-depth))) - (setcar lap0 'byte-dup) - (setcdr lap0 nil) - (setq keep-going t)) - ;; ;; goto*-X ... X: goto-Y --> goto*-Y ;; goto-X ... X: return --> return ;; @@ -1948,12 +1950,19 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; X: varref-Y Z: ... dup varset-Y goto-Z ;; (varset-X goto-BACK, BACK: varref-X --> copy the varref down.) ;; (This is so usual for while loops that it is worth handling). + ;; + ;; Here again, we could do it for stack-ref/stack-set, but + ;; that's replacing a stack-ref-Y with a stack-ref-0, which + ;; is a very minor improvement (if any), at the cost of + ;; more stack use and more byte-code. Let's not do it. ;; - ((and (memq (car lap1) '(byte-varset byte-stack-set)) + ((and (eq (car lap1) 'byte-varset) (eq (car lap2) 'byte-goto) (not (memq (cdr lap2) rest)) ;Backwards jump (eq (car (car (setq tmp (cdr (memq (cdr lap2) lap))))) - (if (eq (car lap1) 'byte-varset) 'byte-varref 'byte-stack-ref)) + (if (eq (car lap1) 'byte-varset) 'byte-varref + ;; 'byte-stack-ref + )) (eq (cdr (car tmp)) (cdr lap1)) (not (and (eq (car lap1) 'byte-varref) (memq (car (cdr lap1)) byte-boolean-vars)))) @@ -2026,7 +2035,7 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; Rebuild byte-compile-constants / byte-compile-variables. ;; Simple optimizations that would inhibit other optimizations if they ;; were done in the optimizing loop, and optimizations which there is no - ;; need to do more than once. + ;; need to do more than once. (setq byte-compile-constants nil byte-compile-variables nil) (setq rest lap @@ -2089,38 +2098,38 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; stack-set-M [discard/discardN ...] --> discardN-preserve-tos ;; stack-set-M [discard/discardN ...] --> discardN ;; - ((and stack-depth ;Make sure we know the stack depth. - (eq (car lap0) 'byte-stack-set) - (memq (car lap1) '(byte-discard byte-discardN)) - (progn - ;; See if enough discard operations follow to expose or - ;; destroy the value stored by the stack-set. - (setq tmp (cdr rest)) - (setq tmp2 (- stack-depth 2 (cdr lap0))) - (setq tmp3 0) - (while (memq (car (car tmp)) '(byte-discard byte-discardN)) - (if (eq (car (car tmp)) 'byte-discard) - (setq tmp3 (1+ tmp3)) - (setq tmp3 (+ tmp3 (cdr (car tmp))))) - (setq tmp (cdr tmp))) - (>= tmp3 tmp2))) - ;; Do the optimization + ((and (eq (car lap0) 'byte-stack-set) + (memq (car lap1) '(byte-discard byte-discardN)) + (progn + ;; See if enough discard operations follow to expose or + ;; destroy the value stored by the stack-set. + (setq tmp (cdr rest)) + (setq tmp2 (1- (cdr lap0))) + (setq tmp3 0) + (while (memq (car (car tmp)) '(byte-discard byte-discardN)) + (setq tmp3 + (+ tmp3 (if (eq (car (car tmp)) 'byte-discard) + 1 + (cdr (car tmp))))) + (setq tmp (cdr tmp))) + (>= tmp3 tmp2))) + ;; Do the optimization. (setq lap (delq lap0 lap)) - (cond ((= tmp2 tmp3) - ;; The value stored is the new TOS, so pop one more value - ;; (to get rid of the old value) using the TOS-preserving - ;; discard operator. - (setcar lap1 'byte-discardN-preserve-tos) - (setcdr lap1 (1+ tmp3))) - (t - ;; Otherwise, the value stored is lost, so just use a - ;; normal discard. - (setcar lap1 'byte-discardN) - (setcdr lap1 tmp3))) + (setcar lap1 + (if (= tmp2 tmp3) + ;; The value stored is the new TOS, so pop + ;; one more value (to get rid of the old + ;; value) using the TOS-preserving + ;; discard operator. + 'byte-discardN-preserve-tos + ;; Otherwise, the value stored is lost, so just use a + ;; normal discard. + 'byte-discardN)) + (setcdr lap1 (1+ tmp3)) (setcdr (cdr rest) tmp) (setq stack-adjust 0) (byte-compile-log-lap " %s [discard/discardN]...\t-->\t%s" - lap0 lap1)) + lap0 lap1)) ;; ;; discard/discardN/discardN-preserve-tos-X discard/discardN-Y --> @@ -2158,30 +2167,16 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; dup return --> return ;; stack-set-N return --> return ; where N is TOS-1 ;; - ((and stack-depth ;Make sure we know the stack depth. - (eq (car lap1) 'byte-return) - (or (memq (car lap0) '(byte-discardN-preserve-tos byte-dup)) - (and (eq (car lap0) 'byte-stack-set) - (= (cdr lap0) (- stack-depth 2))))) - ;; the byte-code interpreter will pop the stack for us, so - ;; we can just leave stuff on it + ((and (eq (car lap1) 'byte-return) + (or (memq (car lap0) '(byte-discardN-preserve-tos byte-dup)) + (and (eq (car lap0) 'byte-stack-set) + (= (cdr lap0) 1)))) + ;; The byte-code interpreter will pop the stack for us, so + ;; we can just leave stuff on it. (setq lap (delq lap0 lap)) (setq stack-adjust 0) (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 lap1)) - - ;; - ;; dup stack-set-N return --> return ; where N is TOS - ;; - ((and stack-depth ;Make sure we know the stack depth. - (eq (car lap0) 'byte-dup) - (eq (car lap1) 'byte-stack-set) - (eq (car (car (cdr (cdr rest)))) 'byte-return) - (= (cdr lap1) (1- stack-depth))) - (setq lap (delq lap0 (delq lap1 lap))) - (setq rest (cdr rest)) - (setq stack-adjust 0) - (byte-compile-log-lap " dup %s return\t-->\treturn" lap1)) - ) + ) (setq stack-depth (and stack-depth stack-adjust (+ stack-depth stack-adjust))) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 54a1912169a..8892a27b29c 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -636,13 +636,13 @@ otherwise pop it") ;; Takes, on stack, the buffer name. ;; Binds standard-output and does some other things. ;; Returns with temp buffer on the stack in place of buffer name. -(byte-defop 144 0 byte-temp-output-buffer-setup) +;; (byte-defop 144 0 byte-temp-output-buffer-setup) ;; For exit from with-output-to-temp-buffer. ;; Expects the temp buffer on the stack underneath value to return. ;; Pops them both, then pushes the value back on. ;; Unbinds standard-output and makes the temp buffer visible. -(byte-defop 145 -1 byte-temp-output-buffer-show) +;; (byte-defop 145 -1 byte-temp-output-buffer-show) ;; these ops are new to v19 @@ -826,6 +826,10 @@ CONST2 may be evaulated multiple times." ((null off) ;; opcode that doesn't use OFF (byte-compile-push-bytecodes opcode bytes pc)) + ((and (eq opcode byte-stack-ref) (eq off 0)) + ;; (stack-ref 0) is really just another name for `dup'. + (debug) ;FIXME: When would this happen? + (byte-compile-push-bytecodes byte-dup bytes pc)) ;; The following three cases are for the special ;; insns that encode their operand into 0, 1, or 2 ;; extra bytes depending on its magnitude. @@ -2530,13 +2534,13 @@ If FORM is a lambda or a macro, byte-compile it as a function." (if macro (setq fun (cdr fun))) (cond ((eq (car-safe fun) 'lambda) - ;; expand macros + ;; Expand macros. (setq fun (macroexpand-all fun byte-compile-initial-macro-environment)) (if lexical-binding (setq fun (cconv-closure-convert fun))) - ;; get rid of the `function' quote added by the `lambda' macro + ;; Get rid of the `function' quote added by the `lambda' macro. (setq fun (cadr fun)) (setq fun (if macro (cons 'macro (byte-compile-lambda fun)) @@ -2953,7 +2957,7 @@ That command is designed for interactive use only" bytecomp-fn)) (byte-compile-nogroup-warn form)) (byte-compile-callargs-warn form)) (if (and (fboundp (car form)) - (eq (car-safe (indirect-function (car form))) 'macro)) + (eq (car-safe (symbol-function (car form))) 'macro)) (byte-compile-report-error (format "Forgot to expand macro %s" (car form)))) (if (and bytecomp-handler @@ -3324,15 +3328,16 @@ discarding." (defun byte-compile-stack-ref (stack-pos) "Output byte codes to push the value at position STACK-POS in the stack, on the top of the stack." - (if (= byte-compile-depth (1+ stack-pos)) - ;; A simple optimization - (byte-compile-out 'byte-dup) - ;; normal case - (byte-compile-out 'byte-stack-ref stack-pos))) + (let ((dist (- byte-compile-depth (1+ stack-pos)))) + (if (zerop dist) + ;; A simple optimization + (byte-compile-out 'byte-dup) + ;; normal case + (byte-compile-out 'byte-stack-ref dist)))) (defun byte-compile-stack-set (stack-pos) "Output byte codes to store the top-of-stack value at position STACK-POS in the stack." - (byte-compile-out 'byte-stack-set stack-pos)) + (byte-compile-out 'byte-stack-set (- byte-compile-depth (1+ stack-pos)))) ;; Compile a function that accepts one or more args and is right-associative. @@ -3946,7 +3951,6 @@ binding slots have been popped." (byte-defop-compiler-1 save-excursion) (byte-defop-compiler-1 save-current-buffer) (byte-defop-compiler-1 save-restriction) -(byte-defop-compiler-1 with-output-to-temp-buffer) (byte-defop-compiler-1 track-mouse) (defun byte-compile-catch (form) @@ -4045,12 +4049,6 @@ binding slots have been popped." (byte-compile-out 'byte-save-current-buffer 0) (byte-compile-body-do-effect (cdr form)) (byte-compile-out 'byte-unbind 1)) - -(defun byte-compile-with-output-to-temp-buffer (form) - (byte-compile-form (car (cdr form))) - (byte-compile-out 'byte-temp-output-buffer-setup 0) - (byte-compile-body (cdr (cdr form))) - (byte-compile-out 'byte-temp-output-buffer-show 0)) ;;; top-level forms elsewhere diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index 4e42e9f3c1d..66e5051c2f1 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -1,4 +1,4 @@ -;;; cconv.el --- Closure conversion for statically scoped Emacs lisp. -*- lexical-binding: nil -*- +;;; cconv.el --- Closure conversion for statically scoped Emacs lisp. -*- lexical-binding: t -*- ;; Copyright (C) 2011 Free Software Foundation, Inc. @@ -71,13 +71,17 @@ ;;; Code: ;;; TODO: +;; - Change new byte-code representation, so it directly gives the +;; number of mandatory and optional arguments as well as whether or +;; not there's a &rest arg. ;; - Use abstract `make-closure' and `closure-ref' expressions, which bytecomp ;; should turn into building corresponding byte-code function. ;; - don't use `curry', instead build a new compiled-byte-code object ;; (merge the closure env into the static constants pool). -;; - use relative addresses for byte-code-stack-ref. ;; - warn about unused lexical vars. ;; - clean up cconv-closure-convert-rec, especially the `let' binding part. +;; - new byte codes for unwind-protect, catch, and condition-case so that +;; closures aren't needed at all. (eval-when-compile (require 'cl)) @@ -215,7 +219,7 @@ Returns a form where all lambdas don't have any free variables." '() ))) -(defun cconv-lookup-let (table var binder form) +(defun cconv--lookup-let (table var binder form) (let ((res nil)) (dolist (elem table) (when (and (eq (nth 2 elem) binder) @@ -312,7 +316,7 @@ Returns a form where all lambdas don't have any free variables." (new-val (cond ;; Check if var is a candidate for lambda lifting. - ((cconv-lookup-let cconv-lambda-candidates var binder form) + ((cconv--lookup-let cconv-lambda-candidates var binder form) (let* ((fv (delete-dups (cconv-freevars value '()))) (funargs (cadr (cadr value))) @@ -341,7 +345,7 @@ Returns a form where all lambdas don't have any free variables." ,(reverse funcbodies-new)))))))) ;; Check if it needs to be turned into a "ref-cell". - ((cconv-lookup-let cconv-captured+mutated var binder form) + ((cconv--lookup-let cconv-captured+mutated var binder form) ;; Declared variable is mutated and captured. (prog1 `(list ,(cconv-closure-convert-rec @@ -478,9 +482,9 @@ Returns a form where all lambdas don't have any free variables." (cons 'cond (reverse cond-forms-new)))) - (`(quote . ,_) form) ; quote form + (`(quote . ,_) form) - (`(function . ((lambda ,vars . ,body-forms))) ; function form + (`(function (lambda ,vars . ,body-forms)) ; function form (let* ((fvrs-new (cconv--set-diff fvrs vars)) ; Remove vars from fvrs. (fv (delete-dups (cconv-freevars form '()))) (leave fvrs-new) ; leave=non-nil if we should leave env unchanged. @@ -493,8 +497,8 @@ Returns a form where all lambdas don't have any free variables." ;; If outer closure contains all ;; free variables of this function(and nothing else) ;; then we use the same environment vector as for outer closure, - ;; i.e. we leave the environment vector unchanged - ;; otherwise we build a new environmet vector + ;; i.e. we leave the environment vector unchanged, + ;; otherwise we build a new environment vector. (if (eq (length envs) (length fv)) (let ((fv-temp fv)) (while (and fv-temp leave) @@ -552,7 +556,7 @@ Returns a form where all lambdas don't have any free variables." (function (lambda (,cconv--env-var . ,vars) . ,body-forms-new)) (vector . ,envector)))))) - (`(function . ,_) form) ; same as quote + (`(function . ,_) form) ; Same as quote. ;defconst, defvar (`(,(and sym (or `defconst `defvar)) ,definedsymbol . ,body-forms) @@ -568,23 +572,23 @@ Returns a form where all lambdas don't have any free variables." ;defun, defmacro (`(,(and sym (or `defun `defmacro)) ,func ,vars . ,body-forms) - (let ((body-new '()) ; the whole body - (body-forms-new '()) ; body w\o docstring and interactive + (let ((body-new '()) ; The whole body. + (body-forms-new '()) ; Body w\o docstring and interactive. (letbind '())) - ; find mutable arguments - (let ((lmutated cconv-captured+mutated) ismutated) - (dolist (elm vars) - (setq ismutated nil) + ; Find mutable arguments. + (dolist (elm vars) + (let ((lmutated cconv-captured+mutated) + (ismutated nil)) (while (and lmutated (not ismutated)) (when (and (eq (caar lmutated) elm) - (eq (cadar lmutated) form)) + (eq (caddar lmutated) form)) (setq ismutated t)) (setq lmutated (cdr lmutated))) (when ismutated (push elm letbind) (push elm emvrs)))) - ;transform body-forms - (when (stringp (car body-forms)) ; treat docstring well + ;Transform body-forms. + (when (stringp (car body-forms)) ; Treat docstring well. (push (car body-forms) body-new) (setq body-forms (cdr body-forms))) (when (eq (car-safe (car body-forms)) 'interactive) @@ -601,7 +605,7 @@ Returns a form where all lambdas don't have any free variables." (setq body-forms-new (reverse body-forms-new)) (if letbind - ; letbind mutable arguments + ; Letbind mutable arguments. (let ((binders-new '())) (dolist (elm letbind) (push `(,elm (list ,elm)) binders-new)) @@ -655,6 +659,7 @@ Returns a form where all lambdas don't have any free variables." (push `(setcar ,sym-new ,value) prognlist) (if (symbolp sym-new) (push `(setq ,sym-new ,value) prognlist) + (debug) ;FIXME: When can this be right? (push `(set ,sym-new ,value) prognlist))) (setq forms (cddr forms))) (if (cdr prognlist) diff --git a/lisp/emacs-lisp/eieio-comp.el b/lisp/emacs-lisp/eieio-comp.el index ed6fb6f1c41..244c4318425 100644 --- a/lisp/emacs-lisp/eieio-comp.el +++ b/lisp/emacs-lisp/eieio-comp.el @@ -45,9 +45,9 @@ ) ;; This teaches the byte compiler how to do this sort of thing. -(put 'defmethod 'byte-hunk-handler 'byte-compile-file-form-defmethod) +(put 'defmethod 'byte-hunk-handler 'eieio-byte-compile-file-form-defmethod) -(defun byte-compile-file-form-defmethod (form) +(defun eieio-byte-compile-file-form-defmethod (form) "Mumble about the method we are compiling. This function is mostly ripped from `byte-compile-file-form-defun', but it's been modified to handle the special syntax of the `defmethod' @@ -74,7 +74,7 @@ that is called but rarely. Argument FORM is the body of the method." ":static ") (t "")))) (params (car form)) - (lamparams (byte-compile-defmethod-param-convert params)) + (lamparams (eieio-byte-compile-defmethod-param-convert params)) (arg1 (car params)) (class (if (listp arg1) (nth 1 arg1) nil)) (my-outbuffer (if (eval-when-compile (featurep 'xemacs)) @@ -98,6 +98,9 @@ that is called but rarely. Argument FORM is the body of the method." ;; Byte compile the body. For the byte compiled forms, add the ;; rest arguments, which will get ignored by the engine which will ;; add them later (I hope) + ;; FIXME: This relies on compiler's internal. Make sure it still + ;; works with lexical-binding code. Maybe calling `byte-compile' + ;; would be preferable. (let* ((new-one (byte-compile-lambda (append (list 'lambda lamparams) (cdr form)))) @@ -125,7 +128,7 @@ that is called but rarely. Argument FORM is the body of the method." ;; nil prevents cruft from appearing in the output buffer. nil)) -(defun byte-compile-defmethod-param-convert (paramlist) +(defun eieio-byte-compile-defmethod-param-convert (paramlist) "Convert method params into the params used by the `defmethod' thingy. Argument PARAMLIST is the parameter list to convert." (let ((argfix nil)) diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index d958bfbd45c..82c0e1319fe 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -182,9 +182,9 @@ Stored outright without modifications or stripping.") )) ;; How to specialty compile stuff. -(autoload 'byte-compile-file-form-defmethod "eieio-comp" +(autoload 'eieio-byte-compile-file-form-defmethod "eieio-comp" "This function is used to byte compile methods in a nice way.") -(put 'defmethod 'byte-hunk-handler 'byte-compile-file-form-defmethod) +(put 'defmethod 'byte-hunk-handler 'eieio-byte-compile-file-form-defmethod) ;;; Important macros used in eieio. ;; @@ -1192,10 +1192,8 @@ IMPL is the symbol holding the method implementation." ;; is faster to execute this for not byte-compiled. ie, install this, ;; then measure calls going through here. I wonder why. (require 'bytecomp) - (let ((byte-compile-free-references nil) - (byte-compile-warnings nil) - ) - (byte-compile-lambda + (let ((byte-compile-warnings nil)) + (byte-compile `(lambda (&rest local-args) ,doc-string ;; This is a cool cheat. Usually we need to look up in the @@ -1205,7 +1203,8 @@ IMPL is the symbol holding the method implementation." ;; of that one implementation, then clearly, there is no method def. (if (not (eieio-object-p (car local-args))) ;; Not an object. Just signal. - (signal 'no-method-definition (list ,(list 'quote method) local-args)) + (signal 'no-method-definition + (list ,(list 'quote method) local-args)) ;; We do have an object. Make sure it is the right type. (if ,(if (eq class eieio-default-superclass) @@ -1228,9 +1227,7 @@ IMPL is the symbol holding the method implementation." ) (apply ,(list 'quote impl) local-args) ;(,impl local-args) - )))) - ) - )) + ))))))) (defsubst eieio-defgeneric-reset-generic-form-primary-only-one (method) "Setup METHOD to call the generic form." diff --git a/lisp/simple.el b/lisp/simple.el index 456318de213..4776cf37931 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -990,7 +990,7 @@ When called interactively, the word count is printed in echo area." (goto-char (point-min)) (while (forward-word 1) (setq count (1+ count))))) - (if (interactive-p) + (if (called-interactively-p 'interactive) (message "Region has %d words" count)) count)) @@ -6641,6 +6641,7 @@ saving the value of `buffer-invisibility-spec' and setting it to nil." ;; Partial application of functions (similar to "currying"). ;; This function is here rather than in subr.el because it uses CL. +;; (defalias 'apply-partially #'curry) (defun apply-partially (fun &rest args) "Return a function that is a partial application of FUN to ARGS. ARGS is a list of the first N arguments to pass to FUN. diff --git a/lisp/subr.el b/lisp/subr.el index 626128c62b3..a493c31b254 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -426,12 +426,6 @@ Non-strings in LIST are ignored." (setq list (cdr list))) list) -;; Remove this since we don't know how to handle it in the byte-compiler yet. -;; (defmacro with-lexical-binding (&rest body) -;; "Execute the statements in BODY using lexical binding." -;; `(let ((internal-interpreter-environment '(t))) -;; ,@body)) - (defun assq-delete-all (key alist) "Delete from ALIST all elements whose car is `eq' to KEY. Return the modified alist. @@ -2786,6 +2780,51 @@ in which case `save-window-excursion' cannot help." (unwind-protect (progn ,@body) (set-window-configuration ,c))))) +(defmacro with-output-to-temp-buffer (bufname &rest body) + "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'." + (let ((old-dir (make-symbol "old-dir")) + (buf (make-symbol "buf"))) + `(let ((,old-dir default-directory)) + (with-current-buffer (get-buffer-create ,bufname) + (kill-all-local-variables) + ;; FIXME: delete_all_overlays + (setq default-directory ,old-dir) + (setq buffer-read-only nil) + (setq buffer-file-name nil) + (setq buffer-undo-list t) + (let ((,buf (current-buffer))) + (let ((inhibit-read-only t) + (inhibit-modification-hooks t)) + (erase-buffer) + (run-hooks 'temp-buffer-setup-hook)) + (let ((standard-output ,buf)) + (prog1 (progn ,@body) + (internal-temp-output-buffer-show ,buf)))))))) + (defmacro with-temp-file (file &rest body) "Create a new buffer, evaluate BODY there, and write the buffer to FILE. The value returned is the value of the last form in BODY. diff --git a/src/ChangeLog b/src/ChangeLog index 6bebce0abaa..d522b6c55dc 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,10 @@ +2011-02-21 Stefan Monnier + + * bytecode.c (exec_byte_code): Change stack_ref and stack_set to use + offsets relative to top rather than to bottom. + + * alloc.c (Fgarbage_collect): Don't mark the byte-stack redundantly. + 2011-02-19 Stefan Monnier * window.c (Fsave_window_excursion): Remove. Moved to Lisp. diff --git a/src/alloc.c b/src/alloc.c index 36c849418f3..4c29ce0b4ec 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -5029,9 +5029,9 @@ returns nil, because real GC can't be done. */) for (i = 0; i < tail->nvars; i++) mark_object (tail->var[i]); } + mark_byte_stack (); #endif - mark_byte_stack (); for (catch = catchlist; catch; catch = catch->next) { mark_object (catch->tag); diff --git a/src/bytecode.c b/src/bytecode.c index ad2f7d18ade..b2e9e3c5b56 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -51,7 +51,7 @@ by Hallvard: * * define BYTE_CODE_METER to enable generation of a byte-op usage histogram. */ -/* #define BYTE_CODE_SAFE */ +#define BYTE_CODE_SAFE /* #define BYTE_CODE_METER */ @@ -88,7 +88,7 @@ extern Lisp_Object Qand_optional, Qand_rest; /* Byte codes: */ -#define Bstack_ref 0 +#define Bstack_ref 0 /* Actually, Bstack_ref+0 is not implemented: use dup. */ #define Bvarref 010 #define Bvarset 020 #define Bvarbind 030 @@ -189,8 +189,8 @@ extern Lisp_Object Qand_optional, Qand_rest; #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. */ +#define Btemp_output_buffer_show 0221 /* Obsolete. */ #define Bunbind_all 0222 /* Obsolete. */ @@ -898,9 +898,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, case Bsave_window_excursion: /* Obsolete. */ { - register Lisp_Object val; register int count = SPECPDL_INDEX (); - record_unwind_protect (Fset_window_configuration, Fcurrent_window_configuration (Qnil)); BEFORE_POTENTIAL_GC (); @@ -940,7 +938,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, break; } - case Btemp_output_buffer_setup: + case Btemp_output_buffer_setup: /* Obsolete. */ BEFORE_POTENTIAL_GC (); CHECK_STRING (TOP); temp_output_buffer_setup (SSDATA (TOP)); @@ -948,7 +946,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, TOP = Vstandard_output; break; - case Btemp_output_buffer_show: + case Btemp_output_buffer_show: /* Obsolete. */ { Lisp_Object v1; BEFORE_POTENTIAL_GC (); @@ -1710,26 +1708,42 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, #endif /* Handy byte-codes for lexical binding. */ - case Bstack_ref: + /* case Bstack_ref: */ /* Use `dup' instead. */ case Bstack_ref+1: case Bstack_ref+2: case Bstack_ref+3: case Bstack_ref+4: case Bstack_ref+5: - PUSH (stack.bottom[op - Bstack_ref]); - break; + { + Lisp_Object *ptr = top - (op - Bstack_ref); + PUSH (*ptr); + break; + } case Bstack_ref+6: - PUSH (stack.bottom[FETCH]); - break; + { + Lisp_Object *ptr = top - (FETCH); + PUSH (*ptr); + break; + } case Bstack_ref+7: - PUSH (stack.bottom[FETCH2]); - break; + { + Lisp_Object *ptr = top - (FETCH2); + PUSH (*ptr); + break; + } + /* stack-set-0 = discard; stack-set-1 = discard-1-preserve-tos. */ case Bstack_set: - stack.bottom[FETCH] = POP; - break; + { + Lisp_Object *ptr = top - (FETCH); + *ptr = POP; + break; + } case Bstack_set2: - stack.bottom[FETCH2] = POP; - break; + { + Lisp_Object *ptr = top - (FETCH2); + *ptr = POP; + break; + } case BdiscardN: op = FETCH; if (op & 0x80) diff --git a/src/print.c b/src/print.c index 2c4762047ac..f48b618775d 100644 --- a/src/print.c +++ b/src/print.c @@ -524,6 +524,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) { @@ -545,60 +546,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 = eval_sub (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); @@ -2310,6 +2257,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 c90cc268a92..d21cbb164ea 100644 --- a/src/window.c +++ b/src/window.c @@ -3655,7 +3655,6 @@ displaying that buffer. */) return Qnil; } - void temp_output_buffer_show (register Lisp_Object buf) { @@ -3715,6 +3714,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) @@ -7155,6 +7164,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); -- cgit v1.3 From 876c194cbac17a6220dbf406b0a602325978011c Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 24 Feb 2011 22:27:45 -0500 Subject: Get rid of funvec. * lisp/emacs-lisp/bytecomp.el (byte-compile-lapcode): Handle new form of `byte-constant'. (byte-compile-close-variables, displaying-byte-compile-warnings): Add edebug spec. (byte-compile-toplevel-file-form): New fun, split out of byte-compile-file-form. (byte-compile-from-buffer): Use it to avoid applying cconv multiple times. (byte-compile): Only strip `function' if it's present. (byte-compile-lambda): Add `reserved-csts' argument. Use new lexenv arg of byte-compile-top-level. (byte-compile-reserved-constants): New var. (byte-compile-constants-vector): Obey it. (byte-compile-constants-vector): Handle new `byte-constant' form. (byte-compile-top-level): Add args `lexenv' and `reserved-csts'. (byte-compile-form): Don't check callargs here. (byte-compile-normal-call): Do it here instead. (byte-compile-push-unknown-constant) (byte-compile-resolve-unknown-constant): Remove, unused. (byte-compile-make-closure): Use `make-byte-code' rather than `curry', putting the environment into the "constant" pool. (byte-compile-get-closed-var): Use special byte-constant. * lisp/emacs-lisp/byte-opt.el (byte-optimize-form-code-walker): Handle new intermediate special form `internal-make-vector'. (byte-optimize-lapcode): Handle new form of `byte-constant'. * lisp/help-fns.el (describe-function-1): Don't handle funvecs. * lisp/emacs-lisp/macroexp.el (macroexpand-all-1): Only convert quote to function if the content is a lambda expression, not if it's a closure. * emacs-lisp/eieio-come.el: Remove. * lisp/emacs-lisp/eieio.el: Don't require eieio-comp. (defmethod): Do a bit more work to find the body and wrap it into a function before passing it to eieio-defmethod. (eieio-defmethod): New arg `code' for it. * lisp/emacs-lisp/debug.el (debugger-setup-buffer): Don't hide things in debugger backtrace. * lisp/emacs-lisp/cl-extra.el (cl-macroexpand-all): Use backquotes, and be more careful when quoting a function value. * lisp/emacs-lisp/cconv.el (cconv-freevars): Accept defvar/defconst. (cconv-closure-convert-rec): Catch stray `internal-make-closure'. * lisp/Makefile.in (COMPILE_FIRST): Compile pcase and cconv early. * src/eval.c (Qcurry): Remove. (funcall_funvec): Remove. (funcall_lambda): Move new byte-code handling to reduce impact. Treat all args as lexical in the case of lexbind. (Fcurry): Remove. * src/data.c (Qfunction_vector): Remove. (Ffunvecp): Remove. * src/lread.c (read1): Revert to calling make_byte_code here. (read_vector): Don't call make_byte_code any more. * src/lisp.h (enum pvec_type): Rename back to PVEC_COMPILED. (XSETCOMPILED): Rename back from XSETFUNVEC. (FUNVEC_SIZE): Remove. (FUNVEC_COMPILED_TAG_P, FUNVEC_COMPILED_P): Remove. (COMPILEDP): Rename back from FUNVECP. * src/fns.c (Felt): Remove unexplained FUNVEC check. * src/doc.c (Fdocumentation): Don't handle funvec. * src/alloc.c (make_funvec, Ffunvec): Remove. * doc/lispref/vol2.texi (Top): * doc/lispref/vol1.texi (Top): * doc/lispref/objects.texi (Programming Types, Funvec Type, Type Predicates): * doc/lispref/functions.texi (Functions, What Is a Function, FunctionCurrying): * doc/lispref/elisp.texi (Top): Remove mentions of funvec and curry. --- .dir-locals.el | 2 +- doc/lispref/ChangeLog | 8 +++ doc/lispref/elisp.texi | 4 +- doc/lispref/functions.texi | 70 +------------------- doc/lispref/objects.texi | 61 ++++------------- doc/lispref/vol1.texi | 2 +- doc/lispref/vol2.texi | 2 +- etc/NEWS.lexbind | 21 ++---- lisp/ChangeLog | 43 ++++++++++++ lisp/Makefile.in | 6 +- lisp/emacs-lisp/byte-opt.el | 47 ++++++++----- lisp/emacs-lisp/bytecomp.el | 138 ++++++++++++++++++++------------------- lisp/emacs-lisp/cconv.el | 43 +++++------- lisp/emacs-lisp/cl-extra.el | 24 +++---- lisp/emacs-lisp/cl-loaddefs.el | 2 +- lisp/emacs-lisp/debug.el | 5 +- lisp/emacs-lisp/eieio-comp.el | 145 ----------------------------------------- lisp/emacs-lisp/eieio.el | 45 +++++++++---- lisp/emacs-lisp/macroexp.el | 5 +- lisp/help-fns.el | 22 ------- src/ChangeLog | 56 ++++++++++++++++ src/ChangeLog.funvec | 37 ----------- src/alloc.c | 71 ++------------------ src/bytecode.c | 9 ++- src/data.c | 25 ++----- src/doc.c | 5 -- src/eval.c | 133 +++++++------------------------------ src/fns.c | 25 ++++--- src/image.c | 3 +- src/keyboard.c | 2 +- src/lisp.h | 33 ++-------- src/lread.c | 33 +++------- src/print.c | 6 +- 33 files changed, 380 insertions(+), 753 deletions(-) delete mode 100644 lisp/emacs-lisp/eieio-comp.el delete mode 100644 src/ChangeLog.funvec (limited to 'src/bytecode.c') diff --git a/.dir-locals.el b/.dir-locals.el index f098f3e7460..86410cc8f40 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -1,6 +1,6 @@ ((nil . ((tab-width . 8) (sentence-end-double-space . t) - (fill-column . 70))) + (fill-column . 79))) (c-mode . ((c-file-style . "GNU"))) ;; You must set bugtracker_debbugs_url in your bazaar.conf for this to work. ;; See admin/notes/bugtracker. diff --git a/doc/lispref/ChangeLog b/doc/lispref/ChangeLog index 90eed004d39..c5e445cec38 100644 --- a/doc/lispref/ChangeLog +++ b/doc/lispref/ChangeLog @@ -1,3 +1,11 @@ +2011-02-25 Stefan Monnier + + * vol2.texi (Top): + * vol1.texi (Top): + * objects.texi (Programming Types, Funvec Type, Type Predicates): + * functions.texi (Functions, What Is a Function, Function Currying): + * elisp.texi (Top): Remove mentions of funvec and curry. + 2011-02-19 Eli Zaretskii * elisp.texi: Sync @dircategory with ../../info/dir. diff --git a/doc/lispref/elisp.texi b/doc/lispref/elisp.texi index 8e3498b8b6f..f7c1d55f6ae 100644 --- a/doc/lispref/elisp.texi +++ b/doc/lispref/elisp.texi @@ -249,7 +249,7 @@ Programming Types * Macro Type:: A method of expanding an expression into another expression, more fundamental but less pretty. * Primitive Function Type:: A function written in C, callable from Lisp. -* Funvec Type:: A vector type callable as a function. +* Byte-Code Type:: A function written in Lisp, then compiled. * Autoload Type:: A type used for automatically loading seldom-used functions. @@ -464,8 +464,6 @@ Functions * Inline Functions:: Defining functions that the compiler will open code. * Declaring Functions:: Telling the compiler that a function is defined. -* Function Currying:: Making wrapper functions that pre-specify - some arguments. * Function Safety:: Determining whether a function is safe to call. * Related Topics:: Cross-references to specific Lisp primitives that have a special bearing on how functions work. diff --git a/doc/lispref/functions.texi b/doc/lispref/functions.texi index fc56e806cf7..974487382c8 100644 --- a/doc/lispref/functions.texi +++ b/doc/lispref/functions.texi @@ -23,8 +23,6 @@ define them. of a symbol. * Obsolete Functions:: Declaring functions obsolete. * Inline Functions:: Defining functions that the compiler will open code. -* Function Currying:: Making wrapper functions that pre-specify - some arguments. * Declaring Functions:: Telling the compiler that a function is defined. * Function Safety:: Determining whether a function is safe to call. * Related Topics:: Cross-references to specific Lisp primitives @@ -113,25 +111,7 @@ editors; for Lisp programs, the distinction is normally unimportant. @item byte-code function A @dfn{byte-code function} is a function that has been compiled by the -byte compiler. A byte-code function is actually a special case of a -@dfn{funvec} object (see below). - -@item function vector -A @dfn{function vector}, or @dfn{funvec} is a vector-like object whose -purpose is to define special kinds of functions. @xref{Funvec Type}. - -The exact meaning of the vector elements is determined by the type of -funvec: the most common use is byte-code functions, which have a -list---the argument list---as the first element. Further types of -funvec object are: - -@table @code -@item curry -A curried function. Remaining arguments in the funvec are function to -call, and arguments to prepend to user arguments at the time of the -call; @xref{Function Currying}. -@end table - +byte compiler. @xref{Byte-Code Type}. @end table @defun functionp object @@ -172,11 +152,6 @@ function. For example: @end example @end defun -@defun funvecp object -@code{funvecp} returns @code{t} if @var{object} is a function vector -object (including byte-code objects), and @code{nil} otherwise. -@end defun - @defun subr-arity subr This function provides information about the argument list of a primitive, @var{subr}. The returned value is a pair @@ -1302,49 +1277,6 @@ do for macros. (@xref{Argument Evaluation}.) Inline functions can be used and open-coded later on in the same file, following the definition, just like macros. -@node Function Currying -@section Function Currying -@cindex function currying -@cindex currying -@cindex partial-application - -Function currying is a way to make a new function that calls an -existing function with a partially pre-determined argument list. - -@defun curry function &rest args -Return a function-like object that will append any arguments it is -called with to @var{args}, and call @var{function} with the resulting -list of arguments. - -For example, @code{(curry 'concat "The ")} returns a function that -concatenates @code{"The "} and its arguments. Calling this function -on @code{"end"} returns @code{"The end"}: - -@example -(funcall (curry 'concat "The ") "end") - @result{} "The end" -@end example - -The @dfn{curried function} is useful as an argument to @code{mapcar}: - -@example -(mapcar (curry 'concat "The ") '("big" "red" "balloon")) - @result{} ("The big" "The red" "The balloon") -@end example -@end defun - -Function currying may be implemented in any Lisp by constructing a -@code{lambda} expression, for instance: - -@example -(defun curry (function &rest args) - `(lambda (&rest call-args) - (apply #',function ,@@args call-args))) -@end example - -However in Emacs Lisp, a special curried function object is used for -efficiency. @xref{Funvec Type}. - @node Declaring Functions @section Telling the Compiler that a Function is Defined @cindex function declaration diff --git a/doc/lispref/objects.texi b/doc/lispref/objects.texi index a20c50b63d6..c58d54f13fc 100644 --- a/doc/lispref/objects.texi +++ b/doc/lispref/objects.texi @@ -156,7 +156,7 @@ latter are unique to Emacs Lisp. * Macro Type:: A method of expanding an expression into another expression, more fundamental but less pretty. * Primitive Function Type:: A function written in C, callable from Lisp. -* Funvec Type:: A vector type callable as a function. +* Byte-Code Type:: A function written in Lisp, then compiled. * Autoload Type:: A type used for automatically loading seldom-used functions. @end menu @@ -1313,55 +1313,18 @@ with the name of the subroutine. @end group @end example -@node Funvec Type -@subsection ``Function Vector' Type -@cindex function vector -@cindex funvec +@node Byte-Code Type +@subsection Byte-Code Function Type -A @dfn{function vector}, or @dfn{funvec} is a vector-like object whose -purpose is to define special kinds of functions. You can examine or -modify the contents of a funvec like a normal vector, using the -@code{aref} and @code{aset} functions. +The byte compiler produces @dfn{byte-code function objects}. +Internally, a byte-code function object is much like a vector; however, +the evaluator handles this data type specially when it appears as a +function to be called. @xref{Byte Compilation}, for information about +the byte compiler. -The behavior of a funvec when called is dependent on the kind of -funvec it is, and that is determined by its first element (a -zero-length funvec will signal an error if called): - -@table @asis -@item A list -A funvec with a list as its first element is a byte-compiled function, -produced by the byte compiler; such funvecs are known as -@dfn{byte-code function objects}. @xref{Byte Compilation}, for -information about the byte compiler. - -@item The symbol @code{curry} -A funvec with @code{curry} as its first element is a ``curried function''. - -The second element in such a funvec is the function which is -being curried, and the remaining elements are a list of arguments. - -Calling such a funvec operates by calling the embedded function with -an argument list composed of the arguments in the funvec followed by -the arguments the funvec was called with. @xref{Function Currying}. -@end table - -The printed representation and read syntax for a funvec object is like -that for a vector, with an additional @samp{#} before the opening -@samp{[}. - -@defun funvecp object -@code{funvecp} returns @code{t} if @var{object} is a function vector -object (including byte-code objects), and @code{nil} otherwise. -@end defun - -@defun funvec kind &rest params -@code{funvec} returns a new function vector containing @var{kind} and -@var{params}. @var{kind} determines the type of funvec; it should be -one of the choices listed in the table above. - -Typically you should use the @code{make-byte-code} function to create -byte-code objects, though they are a type of funvec. -@end defun +The printed representation and read syntax for a byte-code function +object is like that for a vector, with an additional @samp{#} before the +opening @samp{[}. @node Autoload Type @subsection Autoload Type @@ -1808,7 +1771,7 @@ with references to further information. @xref{Buffer Basics, bufferp}. @item byte-code-function-p -@xref{Funvec Type, byte-code-function-p}. +@xref{Byte-Code Type, byte-code-function-p}. @item case-table-p @xref{Case Tables, case-table-p}. diff --git a/doc/lispref/vol1.texi b/doc/lispref/vol1.texi index 33671623b51..ad8ff0819ca 100644 --- a/doc/lispref/vol1.texi +++ b/doc/lispref/vol1.texi @@ -269,7 +269,7 @@ Programming Types * Macro Type:: A method of expanding an expression into another expression, more fundamental but less pretty. * Primitive Function Type:: A function written in C, callable from Lisp. -* Funvec Type:: A vector type callable as a function. +* Byte-Code Type:: A function written in Lisp, then compiled. * Autoload Type:: A type used for automatically loading seldom-used functions. diff --git a/doc/lispref/vol2.texi b/doc/lispref/vol2.texi index 8e5c4b2ef8f..7832b3a8614 100644 --- a/doc/lispref/vol2.texi +++ b/doc/lispref/vol2.texi @@ -268,7 +268,7 @@ Programming Types * Macro Type:: A method of expanding an expression into another expression, more fundamental but less pretty. * Primitive Function Type:: A function written in C, callable from Lisp. -* Funvec Type:: A vector type callable as a function. +* Byte-Code Type:: A function written in Lisp, then compiled. * Autoload Type:: A type used for automatically loading seldom-used functions. diff --git a/etc/NEWS.lexbind b/etc/NEWS.lexbind index 372ee6827cf..bcb56c313f8 100644 --- a/etc/NEWS.lexbind +++ b/etc/NEWS.lexbind @@ -1,6 +1,6 @@ GNU Emacs NEWS -- history of user-visible changes. -Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007 +Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2011 Free Software Foundation, Inc. See the end of the file for license conditions. @@ -12,21 +12,12 @@ This file is about changes in the Emacs "lexbind" branch. * Lisp changes in Emacs 23.1 -** New `function vector' type, including function currying -The `function vector', or `funvec' type extends the old -byte-compiled-function vector type to have other uses as well, and -includes existing byte-compiled functions as a special case. The kind -of funvec is determined by the first element: a list is a byte-compiled -function, and a non-nil atom is one of the new extended uses, currently -`curry' for curried functions. See the node `Funvec Type' in the Emacs -Lisp Reference Manual for more information. - -*** New function curry allows constructing `curried functions' -(see the node `Function Currying' in the Emacs Lisp Reference Manual). - -*** New functions funvec and funvecp allow primitive access to funvecs - +** The `lexical-binding' lets code use lexical scoping for local variables. +It is typically set via file-local variables, in which case it applies to +all the code in that file. +** Lexically scoped interpreted functions are represented with a new form +of function value which looks like (closure ENV lambda ARGS &rest BODY). ---------------------------------------------------------------------- This file is part of GNU Emacs. diff --git a/lisp/ChangeLog b/lisp/ChangeLog index f7a62bc8385..ee6944d8e07 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,46 @@ +2011-02-25 Stefan Monnier + + * emacs-lisp/bytecomp.el (byte-compile-lapcode): Handle new form of + `byte-constant'. + (byte-compile-close-variables, displaying-byte-compile-warnings): + Add edebug spec. + (byte-compile-toplevel-file-form): New fun, split out of + byte-compile-file-form. + (byte-compile-from-buffer): Use it to avoid applying cconv + multiple times. + (byte-compile): Only strip `function' if it's present. + (byte-compile-lambda): Add `reserved-csts' argument. + Use new lexenv arg of byte-compile-top-level. + (byte-compile-reserved-constants): New var. + (byte-compile-constants-vector): Obey it. + (byte-compile-constants-vector): Handle new `byte-constant' form. + (byte-compile-top-level): Add args `lexenv' and `reserved-csts'. + (byte-compile-form): Don't check callargs here. + (byte-compile-normal-call): Do it here instead. + (byte-compile-push-unknown-constant) + (byte-compile-resolve-unknown-constant): Remove, unused. + (byte-compile-make-closure): Use `make-byte-code' rather than `curry', + putting the environment into the "constant" pool. + (byte-compile-get-closed-var): Use special byte-constant. + * emacs-lisp/byte-opt.el (byte-optimize-form-code-walker): Handle new + intermediate special form `internal-make-vector'. + (byte-optimize-lapcode): Handle new form of `byte-constant'. + * help-fns.el (describe-function-1): Don't handle funvecs. + * emacs-lisp/macroexp.el (macroexpand-all-1): Only convert quote to + function if the content is a lambda expression, not if it's a closure. + * emacs-lisp/eieio-come.el: Remove. + * emacs-lisp/eieio.el: Don't require eieio-comp. + (defmethod): Do a bit more work to find the body and wrap it into + a function before passing it to eieio-defmethod. + (eieio-defmethod): New arg `code' for it. + * emacs-lisp/debug.el (debugger-setup-buffer): Don't hide things in + debugger backtrace. + * emacs-lisp/cl-extra.el (cl-macroexpand-all): Use backquotes, and be + more careful when quoting a function value. + * emacs-lisp/cconv.el (cconv-freevars): Accept defvar/defconst. + (cconv-closure-convert-rec): Catch stray `internal-make-closure'. + * Makefile.in (COMPILE_FIRST): Compile pcase and cconv early. + 2011-02-21 Stefan Monnier * emacs-lisp/cconv.el (cconv-closure-convert-rec): Let the byte diff --git a/lisp/Makefile.in b/lisp/Makefile.in index 6e28c3f9df8..389d5b154aa 100644 --- a/lisp/Makefile.in +++ b/lisp/Makefile.in @@ -83,7 +83,9 @@ BIG_STACK_OPTS = --eval "(setq max-lisp-eval-depth $(BIG_STACK_DEPTH))" COMPILE_FIRST = \ $(lisp)/emacs-lisp/bytecomp.elc \ $(lisp)/emacs-lisp/byte-opt.elc \ + $(lisp)/emacs-lisp/pcase.elc \ $(lisp)/emacs-lisp/macroexp.elc \ + $(lisp)/emacs-lisp/cconv.elc \ $(lisp)/emacs-lisp/autoload.elc # The actual Emacs command run in the targets below. @@ -203,7 +205,7 @@ compile-onefile: @echo Compiling $(THEFILE) @# Use byte-compile-refresh-preloaded to try and work around some of @# the most common bootstrapping problems. - @$(emacs) -l bytecomp.el -f byte-compile-refresh-preloaded \ + $(emacs) -l bytecomp.el -f byte-compile-refresh-preloaded \ $(BIG_STACK_OPTS) $(BYTE_COMPILE_EXTRA_FLAGS) \ -f batch-byte-compile $(THEFILE) @@ -220,7 +222,7 @@ compile-onefile: # cannot have prerequisites. .el.elc: @echo Compiling $< - @$(emacs) $(BIG_STACK_OPTS) $(BYTE_COMPILE_EXTRA_FLAGS) \ + $(emacs) $(BIG_STACK_OPTS) $(BYTE_COMPILE_EXTRA_FLAGS) \ -f batch-byte-compile $< .PHONY: compile-first compile-main compile compile-always diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index c9cc4618967..342dd8b71d1 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -531,7 +531,11 @@ ;; However, don't actually bother calling `ignore'. `(prog1 nil . ,(mapcar 'byte-optimize-form (cdr form)))) + ((eq fn 'internal-make-closure) + form) + ((not (symbolp fn)) + (debug) (byte-compile-warn "`%s' is a malformed function" (prin1-to-string fn)) form) @@ -1472,7 +1476,8 @@ byte-cdr-safe byte-cons byte-list1 byte-list2 byte-point byte-point-max byte-point-min byte-following-char byte-preceding-char byte-current-column byte-eolp byte-eobp byte-bolp byte-bobp - byte-current-buffer byte-stack-ref)) + byte-current-buffer byte-stack-ref ;; byte-closed-var + )) (defconst byte-compile-side-effect-free-ops (nconc @@ -1680,11 +1685,18 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; const goto-if-* --> whatever ;; ((and (eq 'byte-constant (car lap0)) - (memq (car lap1) byte-conditional-ops)) + (memq (car lap1) byte-conditional-ops) + ;; If the `byte-constant's cdr is not a cons cell, it has + ;; to be an index into the constant pool); even though + ;; it'll be a constant, that constant is not known yet + ;; (it's typically a free variable of a closure, so will + ;; only be known when the closure will be built at + ;; run-time). + (consp (cdr lap0))) (cond ((if (or (eq (car lap1) 'byte-goto-if-nil) - (eq (car lap1) 'byte-goto-if-nil-else-pop)) - (car (cdr lap0)) - (not (car (cdr lap0)))) + (eq (car lap1) 'byte-goto-if-nil-else-pop)) + (car (cdr lap0)) + (not (car (cdr lap0)))) (byte-compile-log-lap " %s %s\t-->\t" lap0 lap1) (setq rest (cdr rest) @@ -1696,11 +1708,11 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (when (memq (car lap1) byte-goto-always-pop-ops) (setq lap (delq lap0 lap))) (setcar lap1 'byte-goto))) - (setq keep-going t)) + (setq keep-going t)) ;; ;; varref-X varref-X --> varref-X dup ;; varref-X [dup ...] varref-X --> varref-X [dup ...] dup - ;; stackref-X [dup ...] stackref-X+N --> stackref-X [dup ...] dup + ;; stackref-X [dup ...] stackref-X+N --> stackref-X [dup ...] dup ;; We don't optimize the const-X variations on this here, ;; because that would inhibit some goto optimizations; we ;; optimize the const-X case after all other optimizations. @@ -1877,18 +1889,21 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (cons 'byte-discard byte-conditional-ops))) (not (eq lap1 (car tmp)))) (setq tmp2 (car tmp)) - (cond ((memq (car tmp2) - (if (null (car (cdr lap0))) - '(byte-goto-if-nil byte-goto-if-nil-else-pop) - '(byte-goto-if-not-nil - byte-goto-if-not-nil-else-pop))) + (cond ((when (consp (cdr lap0)) + (memq (car tmp2) + (if (null (car (cdr lap0))) + '(byte-goto-if-nil byte-goto-if-nil-else-pop) + '(byte-goto-if-not-nil + byte-goto-if-not-nil-else-pop)))) (byte-compile-log-lap " %s goto [%s]\t-->\t%s %s" lap0 tmp2 lap0 tmp2) (setcar lap1 (car tmp2)) (setcdr lap1 (cdr tmp2)) ;; Let next step fix the (const,goto-if*) sequence. - (setq rest (cons nil rest))) - (t + (setq rest (cons nil rest)) + (setq keep-going t)) + ((or (consp (cdr lap0)) + (eq (car tmp2) 'byte-discard)) ;; Jump one step further (byte-compile-log-lap " %s goto [%s]\t-->\t goto " @@ -1897,8 +1912,8 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (setcdr tmp (cons (byte-compile-make-tag) (cdr tmp)))) (setcdr lap1 (car (cdr tmp))) - (setq lap (delq lap0 lap)))) - (setq keep-going t)) + (setq lap (delq lap0 lap)) + (setq keep-going t)))) ;; ;; X: varref-Y ... varset-Y goto-X --> ;; X: varref-Y Z: ... dup varset-Y goto-Z diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 771306bb0e6..6bc2b3b5617 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -794,10 +794,13 @@ CONST2 may be evaulated multiple times." ;; goto (byte-compile-push-bytecodes opcode nil (cdr off) bytes pc) (push bytes patchlist)) - ((and (consp off) - ;; Variable or constant reference - (progn (setq off (cdr off)) - (eq op 'byte-constant))) + ((or (and (consp off) + ;; Variable or constant reference + (progn + (setq off (cdr off)) + (eq op 'byte-constant))) + (and (eq op 'byte-constant) ;; 'byte-closed-var + (integerp off))) ;; constant ref (if (< off byte-constant-limit) (byte-compile-push-bytecodes (+ byte-constant off) @@ -1480,6 +1483,7 @@ symbol itself." ((byte-compile-const-symbol-p ,form)))) (defmacro byte-compile-close-variables (&rest body) + (declare (debug t)) (cons 'let (cons '(;; ;; Close over these variables to encapsulate the @@ -1510,6 +1514,7 @@ symbol itself." body))) (defmacro displaying-byte-compile-warnings (&rest body) + (declare (debug t)) `(let* ((--displaying-byte-compile-warnings-fn (lambda () ,@body)) (warning-series-started (and (markerp warning-series) @@ -1930,7 +1935,7 @@ With argument ARG, insert value in current buffer after the form." (byte-compile-warn "!! The file uses old-style backquotes !! This functionality has been obsolete for more than 10 years already and will be removed soon. See (elisp)Backquote in the manual.")) - (byte-compile-file-form form))) + (byte-compile-toplevel-file-form form))) ;; Compile pending forms at end of file. (byte-compile-flush-pending) ;; Make warnings about unresolved functions @@ -2041,8 +2046,8 @@ Call from the source buffer." ;; defalias calls are output directly by byte-compile-file-form-defmumble; ;; it does not pay to first build the defalias in defmumble and then parse ;; it here. - (if (and (memq (car-safe form) '(defun defmacro defvar defvaralias defconst autoload - custom-declare-variable)) + (if (and (memq (car-safe form) '(defun defmacro defvar defvaralias defconst + autoload custom-declare-variable)) (stringp (nth 3 form))) (byte-compile-output-docform nil nil '("\n(" 3 ")") form nil (memq (car form) @@ -2182,12 +2187,17 @@ list that represents a doc string reference. byte-compile-maxdepth 0 byte-compile-output nil)))) -(defun byte-compile-file-form (form) - (let ((byte-compile-current-form nil) ; close over this for warnings. - bytecomp-handler) +;; byte-hunk-handlers cannot call this! +(defun byte-compile-toplevel-file-form (form) + (let ((byte-compile-current-form nil)) ; close over this for warnings. (setq form (macroexpand-all form byte-compile-macro-environment)) (if lexical-binding (setq form (cconv-closure-convert form))) + (byte-compile-file-form form))) + +;; byte-hunk-handlers can call this. +(defun byte-compile-file-form (form) + (let (bytecomp-handler) (cond ((not (consp form)) (byte-compile-keep-pending form)) ((and (symbolp (car form)) @@ -2541,7 +2551,7 @@ If FORM is a lambda or a macro, byte-compile it as a function." (if lexical-binding (setq fun (cconv-closure-convert fun))) ;; Get rid of the `function' quote added by the `lambda' macro. - (setq fun (cadr fun)) + (if (eq (car-safe fun) 'function) (setq fun (cadr fun))) (setq fun (if macro (cons 'macro (byte-compile-lambda fun)) (byte-compile-lambda fun))) @@ -2654,7 +2664,7 @@ If FORM is a lambda or a macro, byte-compile it as a function." ;; of the list FUN and `byte-compile-set-symbol-position' is not called. ;; Use this feature to avoid calling `byte-compile-set-symbol-position' ;; for symbols generated by the byte compiler itself. -(defun byte-compile-lambda (bytecomp-fun &optional add-lambda) +(defun byte-compile-lambda (bytecomp-fun &optional add-lambda reserved-csts) (if add-lambda (setq bytecomp-fun (cons 'lambda bytecomp-fun)) (unless (eq 'lambda (car-safe bytecomp-fun)) @@ -2702,14 +2712,16 @@ If FORM is a lambda or a macro, byte-compile it as a function." (byte-compile-warn "malformed interactive spec: %s" (prin1-to-string bytecomp-int))))) ;; Process the body. - (let* ((byte-compile-lexical-environment - ;; If doing lexical binding, push a new lexical environment - ;; containing just the args (since lambda expressions - ;; should be closed by now). - (and lexical-binding - (byte-compile-make-lambda-lexenv bytecomp-fun))) - (compiled - (byte-compile-top-level (cons 'progn bytecomp-body) nil 'lambda))) + (let* ((compiled + (byte-compile-top-level (cons 'progn bytecomp-body) nil 'lambda + ;; If doing lexical binding, push a new + ;; lexical environment containing just the + ;; args (since lambda expressions should be + ;; closed by now). + (and lexical-binding + (byte-compile-make-lambda-lexenv + bytecomp-fun)) + reserved-csts))) ;; Build the actual byte-coded function. (if (eq 'byte-code (car-safe compiled)) (apply 'make-byte-code @@ -2740,6 +2752,8 @@ If FORM is a lambda or a macro, byte-compile it as a function." ;; A simple lambda is just a constant. (byte-compile-constant code))) +(defvar byte-compile-reserved-constants 0) + (defun byte-compile-constants-vector () ;; Builds the constants-vector from the current variables and constants. ;; This modifies the constants from (const . nil) to (const . offset). @@ -2748,7 +2762,7 @@ If FORM is a lambda or a macro, byte-compile it as a function." ;; Next up to byte-constant-limit are constants, still with one-byte codes. ;; Next variables again, to get 2-byte codes for variable lookup. ;; The rest of the constants and variables need 3-byte byte-codes. - (let* ((i -1) + (let* ((i (1- byte-compile-reserved-constants)) (rest (nreverse byte-compile-variables)) ; nreverse because the first (other (nreverse byte-compile-constants)) ; vars often are used most. ret tmp @@ -2759,11 +2773,15 @@ If FORM is a lambda or a macro, byte-compile it as a function." limit) (while (or rest other) (setq limit (car limits)) - (while (and rest (not (eq i limit))) - (if (setq tmp (assq (car (car rest)) ret)) - (setcdr (car rest) (cdr tmp)) + (while (and rest (< i limit)) + (cond + ((numberp (car rest)) + (assert (< (car rest) byte-compile-reserved-constants))) + ((setq tmp (assq (car (car rest)) ret)) + (setcdr (car rest) (cdr tmp))) + (t (setcdr (car rest) (setq i (1+ i))) - (setq ret (cons (car rest) ret))) + (setq ret (cons (car rest) ret)))) (setq rest (cdr rest))) (setq limits (cdr limits) rest (prog1 other @@ -2772,7 +2790,8 @@ If FORM is a lambda or a macro, byte-compile it as a function." ;; Given an expression FORM, compile it and return an equivalent byte-code ;; expression (a call to the function byte-code). -(defun byte-compile-top-level (form &optional for-effect output-type) +(defun byte-compile-top-level (form &optional for-effect output-type + lexenv reserved-csts) ;; OUTPUT-TYPE advises about how form is expected to be used: ;; 'eval or nil -> a single form, ;; 'progn or t -> a list of forms, @@ -2783,9 +2802,8 @@ If FORM is a lambda or a macro, byte-compile it as a function." (byte-compile-tag-number 0) (byte-compile-depth 0) (byte-compile-maxdepth 0) - (byte-compile-lexical-environment - (when (eq output-type 'lambda) - byte-compile-lexical-environment)) + (byte-compile-lexical-environment lexenv) + (byte-compile-reserved-constants (or reserved-csts 0)) (byte-compile-output nil)) (if (memq byte-optimize '(t source)) (setq form (byte-optimize-form form for-effect))) @@ -2904,6 +2922,8 @@ If FORM is a lambda or a macro, byte-compile it as a function." (bytecomp-body (list bytecomp-body)))) +;; FIXME: Like defsubst's, this hunk-handler won't be called any more +;; because the macro is expanded away before we see it. (put 'declare-function 'byte-hunk-handler 'byte-compile-declare-function) (defun byte-compile-declare-function (form) (push (cons (nth 1 form) @@ -2950,12 +2970,6 @@ If FORM is a lambda or a macro, byte-compile it as a function." (memq bytecomp-fn byte-compile-interactive-only-functions) (byte-compile-warn "`%s' used from Lisp code\n\ That command is designed for interactive use only" bytecomp-fn)) - (when (byte-compile-warning-enabled-p 'callargs) - (if (memq bytecomp-fn - '(custom-declare-group custom-declare-variable - custom-declare-face)) - (byte-compile-nogroup-warn form)) - (byte-compile-callargs-warn form)) (if (and (fboundp (car form)) (eq (car-safe (symbol-function (car form))) 'macro)) (byte-compile-report-error @@ -2985,6 +2999,13 @@ That command is designed for interactive use only" bytecomp-fn)) (byte-compile-discard))) (defun byte-compile-normal-call (form) + (when (and (byte-compile-warning-enabled-p 'callargs) + (symbolp (car form))) + (if (memq (car form) + '(custom-declare-group custom-declare-variable + custom-declare-face)) + (byte-compile-nogroup-warn form)) + (byte-compile-callargs-warn form)) (if byte-compile-generate-call-tree (byte-compile-annotate-call-tree form)) (when (and for-effect (eq (car form) 'mapcar) @@ -3037,7 +3058,7 @@ If BINDING is non-nil, VAR is being bound." (boundp var) (memq var byte-compile-bound-variables) (memq var byte-compile-free-references)) - (byte-compile-warn "reference to free variable `%s'" var) + (byte-compile-warn "reference to free variable `%S'" var) (push var byte-compile-free-references)) (byte-compile-dynamic-variable-op 'byte-varref var)))) @@ -3082,26 +3103,6 @@ If BINDING is non-nil, VAR is being bound." (defun byte-compile-push-constant (const) (let ((for-effect nil)) (inline (byte-compile-constant const)))) - -(defun byte-compile-push-unknown-constant (&optional id) - "Generate code to push a `constant' who's value isn't known yet. -A tag is returned which may then later be passed to -`byte-compile-resolve-unknown-constant' to finalize the value. -The optional argument ID is a tag returned by an earlier call to -`byte-compile-push-unknown-constant', in which case the same constant is -pushed again." - (unless id - (setq id (list (make-symbol "unknown"))) - (push id byte-compile-constants)) - (byte-compile-out 'byte-constant id) - id) - -(defun byte-compile-resolve-unknown-constant (id value) - "Give an `unknown constant' a value. -ID is the tag returned by `byte-compile-push-unknown-constant'. and VALUE -is the value it should have." - (setcar id value)) - ;; Compile those primitive ordinary functions ;; which have special byte codes just for speed. @@ -3345,18 +3346,23 @@ discarding." (defconst byte-compile--env-var (make-symbol "env")) (defun byte-compile-make-closure (form) - ;; FIXME: don't use `curry'! - (byte-compile-form - (unless for-effect - `(curry (function (lambda (,byte-compile--env-var . ,(nth 1 form)) - . ,(nthcdr 3 form))) - (vector . ,(nth 2 form)))) - for-effect)) + (if for-effect (setq for-effect nil) + (let* ((vars (nth 1 form)) + (env (nth 2 form)) + (body (nthcdr 3 form)) + (fun + (byte-compile-lambda `(lambda ,vars . ,body) nil (length env)))) + (assert (byte-code-function-p fun)) + (byte-compile-form `(make-byte-code + ',(aref fun 0) ',(aref fun 1) + (vconcat (vector . ,env) ',(aref fun 2)) + ,@(nthcdr 3 (mapcar (lambda (x) `',x) fun))))))) + (defun byte-compile-get-closed-var (form) - (byte-compile-form (unless for-effect - `(aref ,byte-compile--env-var ,(nth 1 form))) - for-effect)) + (if for-effect (setq for-effect nil) + (byte-compile-out 'byte-constant ;; byte-closed-var + (nth 1 form)))) ;; Compile a function that accepts one or more args and is right-associative. ;; We do it by left-associativity so that the operations diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index 6aa4b7e0a61..bc7ecb1ad55 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -47,19 +47,14 @@ ;; (lambda (v1 ...) ... fv1 fv2 ...) => (lambda (v1 ... fv1 fv2 ) ... fv1 fv2 .) ;; if the function is suitable for lambda lifting (if all calls are known) ;; -;; (lambda (v1 ...) ... fv ...) => -;; (curry (lambda (env v1 ...) ... env ...) env) -;; if the function has only 1 free variable -;; -;; and finally -;; (lambda (v1 ...) ... fv1 fv2 ...) => -;; (curry (lambda (env v1 ..) .. (aref env 0) (aref env 1) ..) (vector fv1 fv2)) -;; if the function has 2 or more free variables. +;; (lambda (v0 ...) ... fv0 .. fv1 ...) => +;; (internal-make-closure (v0 ...) (fv1 ...) +;; ... (internal-get-closed-var 0) ... (internal-get-closed-var 1) ...) ;; ;; If the function has no free variables, we don't do anything. ;; ;; If a variable is mutated (updated by setq), and it is used in a closure -;; we wrap it's definition with list: (list val) and we also replace +;; we wrap its definition with list: (list val) and we also replace ;; var => (car var) wherever this variable is used, and also ;; (setq var value) => (setcar var value) where it is updated. ;; @@ -71,15 +66,12 @@ ;;; Code: ;;; TODO: +;; - pay attention to `interactive': its arg is run in an empty env. ;; - canonize code in macro-expand so we don't have to handle (let (var) body) ;; and other oddities. ;; - Change new byte-code representation, so it directly gives the ;; number of mandatory and optional arguments as well as whether or ;; not there's a &rest arg. -;; - Use abstract `make-closure' and `closure-ref' expressions, which bytecomp -;; should turn into building corresponding byte-code function. -;; - don't use `curry', instead build a new compiled-byte-code object -;; (merge the closure env into the static constants pool). ;; - warn about unused lexical vars. ;; - clean up cconv-closure-convert-rec, especially the `let' binding part. ;; - new byte codes for unwind-protect, catch, and condition-case so that @@ -184,8 +176,8 @@ Returns a list of free variables." ;; We call cconv-freevars only for functions(lambdas) ;; defun, defconst, defvar are not allowed to be inside ;; a function (lambda). - ;; FIXME: should be a byte-compile-report-error! - (error "Invalid form: %s inside a function" sym)) + ;; (error "Invalid form: %s inside a function" sym) + (cconv-freevars `(progn ,@(cddr form)) fvrs)) (`(,_ . ,body-forms) ; First element is (like) a function. (dolist (exp body-forms) @@ -537,6 +529,9 @@ Returns a form where all lambdas don't have any free variables." `(internal-make-closure ,vars ,envector . ,body-forms-new))))) + (`(internal-make-closure . ,_) + (error "Internal byte-compiler error: cconv called twice")) + (`(function . ,_) form) ; Same as quote. ;defconst, defvar @@ -599,20 +594,18 @@ Returns a form where all lambdas don't have any free variables." ;condition-case (`(condition-case ,var ,protected-form . ,handlers) - (let ((handlers-new '()) - (newform (cconv-closure-convert-rec + (let ((newform (cconv-closure-convert-rec `(function (lambda () ,protected-form)) emvrs fvrs envs lmenvs))) (setq fvrs (remq var fvrs)) - (dolist (handler handlers) - (push (list (car handler) - (cconv-closure-convert-rec - `(function (lambda (,(or var cconv--dummy-var)) - ,@(cdr handler))) - emvrs fvrs envs lmenvs)) - handlers-new)) `(condition-case :fun-body ,newform - ,@(nreverse handlers-new)))) + ,@(mapcar (lambda (handler) + (list (car handler) + (cconv-closure-convert-rec + (let ((arg (or var cconv--dummy-var))) + `(function (lambda (,arg) ,@(cdr handler)))) + emvrs fvrs envs lmenvs))) + handlers)))) (`(,(and head (or `catch `unwind-protect)) ,form . ,body) `(,head ,(cconv-closure-convert-rec form emvrs fvrs envs lmenvs) diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index 12dafe274b9..7468a0237cf 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -766,21 +766,15 @@ This also does some trivial optimizations to make the form prettier." (eq (car-safe (car body)) 'interactive)) (push (list 'quote (pop body)) decls)) (put (car (last cl-closure-vars)) 'used t) - (append - (list 'list '(quote lambda) '(quote (&rest --cl-rest--))) - (sublis sub (nreverse decls)) - (list - (list* 'list '(quote apply) - (list 'quote - (list 'function - (list* 'lambda - (append new (cadadr form)) - (sublis sub body)))) - (nconc (mapcar (function - (lambda (x) - (list 'list '(quote quote) x))) - cl-closure-vars) - '((quote --cl-rest--))))))) + `(list 'lambda '(&rest --cl-rest--) + ,@(sublis sub (nreverse decls)) + (list 'apply + (list 'quote + #'(lambda ,(append new (cadadr form)) + ,@(sublis sub body))) + ,@(nconc (mapcar (lambda (x) `(list 'quote ,x)) + cl-closure-vars) + '((quote --cl-rest--)))))) (list (car form) (list* 'lambda (cadadr form) body)))) (let ((found (assq (cadr form) env))) (if (and found (ignore-errors diff --git a/lisp/emacs-lisp/cl-loaddefs.el b/lisp/emacs-lisp/cl-loaddefs.el index bd50c75bcc3..df9460154e8 100644 --- a/lisp/emacs-lisp/cl-loaddefs.el +++ b/lisp/emacs-lisp/cl-loaddefs.el @@ -10,7 +10,7 @@ ;;;;;; ceiling* floor* isqrt lcm gcd cl-progv-before cl-set-frame-visible-p ;;;;;; cl-map-overlays cl-map-intervals cl-map-keymap-recursively ;;;;;; notevery notany every some mapcon mapcan mapl maplist map -;;;;;; cl-mapcar-many equalp coerce) "cl-extra" "cl-extra.el" "2bfbae6523c842d511b8c8d88658825a") +;;;;;; cl-mapcar-many equalp coerce) "cl-extra" "cl-extra.el" "26339d9571f9485bf34fa6d2ae38fc84") ;;; Generated autoloads from cl-extra.el (autoload 'coerce "cl-extra" "\ diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el index 88633eaaa46..0b2ea81fb64 100644 --- a/lisp/emacs-lisp/debug.el +++ b/lisp/emacs-lisp/debug.el @@ -269,8 +269,9 @@ That buffer should be current already." (setq buffer-undo-list t) (let ((standard-output (current-buffer)) (print-escape-newlines t) - (print-level 8) - (print-length 50)) + (print-level 1000) ;8 + ;; (print-length 50) + ) (backtrace)) (goto-char (point-min)) (delete-region (point) diff --git a/lisp/emacs-lisp/eieio-comp.el b/lisp/emacs-lisp/eieio-comp.el deleted file mode 100644 index 244c4318425..00000000000 --- a/lisp/emacs-lisp/eieio-comp.el +++ /dev/null @@ -1,145 +0,0 @@ -;;; eieio-comp.el -- eieio routines to help with byte compilation - -;; Copyright (C) 1995-1996, 1998-2002, 2005, 2008-2011 -;; Free Software Foundation, Inc. - -;; Author: Eric M. Ludlam -;; Version: 0.2 -;; Keywords: lisp, tools -;; Package: eieio - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see . - -;;; Commentary: - -;; Byte compiler functions for defmethod. This will affect the new GNU -;; byte compiler for Emacs 19 and better. This function will be called by -;; the byte compiler whenever a `defmethod' is encountered in a file. -;; It will output a function call to `eieio-defmethod' with the byte -;; compiled function as a parameter. - -;;; Code: - -(declare-function eieio-defgeneric-form "eieio" (method doc-string)) - -;; Some compatibility stuff -(eval-and-compile - (if (not (fboundp 'byte-compile-compiled-obj-to-list)) - (defun byte-compile-compiled-obj-to-list (moose) nil)) - - (if (not (boundp 'byte-compile-outbuffer)) - (defvar byte-compile-outbuffer nil)) - ) - -;; This teaches the byte compiler how to do this sort of thing. -(put 'defmethod 'byte-hunk-handler 'eieio-byte-compile-file-form-defmethod) - -(defun eieio-byte-compile-file-form-defmethod (form) - "Mumble about the method we are compiling. -This function is mostly ripped from `byte-compile-file-form-defun', -but it's been modified to handle the special syntax of the `defmethod' -command. There should probably be one for `defgeneric' as well, but -that is called but rarely. Argument FORM is the body of the method." - (setq form (cdr form)) - (let* ((meth (car form)) - (key (progn (setq form (cdr form)) - (cond ((or (eq ':BEFORE (car form)) - (eq ':before (car form))) - (setq form (cdr form)) - ":before ") - ((or (eq ':AFTER (car form)) - (eq ':after (car form))) - (setq form (cdr form)) - ":after ") - ((or (eq ':PRIMARY (car form)) - (eq ':primary (car form))) - (setq form (cdr form)) - ":primary ") - ((or (eq ':STATIC (car form)) - (eq ':static (car form))) - (setq form (cdr form)) - ":static ") - (t "")))) - (params (car form)) - (lamparams (eieio-byte-compile-defmethod-param-convert params)) - (arg1 (car params)) - (class (if (listp arg1) (nth 1 arg1) nil)) - (my-outbuffer (if (eval-when-compile (featurep 'xemacs)) - byte-compile-outbuffer - (cond ((boundp 'bytecomp-outbuffer) - bytecomp-outbuffer) ; Emacs >= 23.2 - ((boundp 'outbuffer) outbuffer) - (t (error "Unable to set outbuffer")))))) - (let ((name (format "%s::%s" (or class "#") meth))) - (if byte-compile-verbose - ;; #### filename used free - (message "Compiling %s... (%s)" - (cond ((boundp 'bytecomp-filename) bytecomp-filename) - ((boundp 'filename) filename) - (t "")) - name)) - (setq byte-compile-current-form name) ; for warnings - ) - ;; Flush any pending output - (byte-compile-flush-pending) - ;; Byte compile the body. For the byte compiled forms, add the - ;; rest arguments, which will get ignored by the engine which will - ;; add them later (I hope) - ;; FIXME: This relies on compiler's internal. Make sure it still - ;; works with lexical-binding code. Maybe calling `byte-compile' - ;; would be preferable. - (let* ((new-one (byte-compile-lambda - (append (list 'lambda lamparams) - (cdr form)))) - (code (byte-compile-byte-code-maker new-one))) - (princ "\n(eieio-defmethod '" my-outbuffer) - (princ meth my-outbuffer) - (princ " '(" my-outbuffer) - (princ key my-outbuffer) - (prin1 params my-outbuffer) - (princ " " my-outbuffer) - (prin1 code my-outbuffer) - (princ "))" my-outbuffer) - ) - ;; Now add this function to the list of known functions. - ;; Don't bother with a doc string. Not relevant here. - (add-to-list 'byte-compile-function-environment - (cons meth - (eieio-defgeneric-form meth ""))) - - ;; Remove it from the undefined list if it is there. - (let ((elt (assq meth byte-compile-unresolved-functions))) - (if elt (setq byte-compile-unresolved-functions - (delq elt byte-compile-unresolved-functions)))) - - ;; nil prevents cruft from appearing in the output buffer. - nil)) - -(defun eieio-byte-compile-defmethod-param-convert (paramlist) - "Convert method params into the params used by the `defmethod' thingy. -Argument PARAMLIST is the parameter list to convert." - (let ((argfix nil)) - (while paramlist - (setq argfix (cons (if (listp (car paramlist)) - (car (car paramlist)) - (car paramlist)) - argfix)) - (setq paramlist (cdr paramlist))) - (nreverse argfix))) - -(provide 'eieio-comp) - -;;; eieio-comp.el ends here diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index bd768dbdb9f..4e443452d8b 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -45,8 +45,7 @@ ;;; Code: (eval-when-compile - (require 'cl) - (require 'eieio-comp)) + (require 'cl)) (defvar eieio-version "1.3" "Current version of EIEIO.") @@ -123,6 +122,7 @@ execute a `call-next-method'. DO NOT SET THIS YOURSELF!") ;; while it is being built itself. (defvar eieio-default-superclass nil) +;; FIXME: The constants below should have a `eieio-' prefix added!! (defconst class-symbol 1 "Class's symbol (self-referencing.).") (defconst class-parent 2 "Class parent slot.") (defconst class-children 3 "Class children class slot.") @@ -181,10 +181,6 @@ Stored outright without modifications or stripping.") (t key) ;; already generic.. maybe. )) -;; How to specialty compile stuff. -(autoload 'eieio-byte-compile-file-form-defmethod "eieio-comp" - "This function is used to byte compile methods in a nice way.") -(put 'defmethod 'byte-hunk-handler 'eieio-byte-compile-file-form-defmethod) ;;; Important macros used in eieio. ;; @@ -1293,9 +1289,35 @@ Summary: ((typearg class-name) arg2 &optional opt &rest rest) \"doc-string\" body)" - `(eieio-defmethod (quote ,method) (quote ,args))) - -(defun eieio-defmethod (method args) + (let* ((key (cond ((or (eq ':BEFORE (car args)) + (eq ':before (car args))) + (setq args (cdr args)) + :before) + ((or (eq ':AFTER (car args)) + (eq ':after (car args))) + (setq args (cdr args)) + :after) + ((or (eq ':PRIMARY (car args)) + (eq ':primary (car args))) + (setq args (cdr args)) + :primary) + ((or (eq ':STATIC (car args)) + (eq ':static (car args))) + (setq args (cdr args)) + :static) + (t nil))) + (params (car args)) + (lamparams + (mapcar (lambda (param) (if (listp param) (car param) param)) + params)) + (arg1 (car params)) + (class (if (listp arg1) (nth 1 arg1) nil))) + `(eieio-defmethod ',method + '(,@(if key (list key)) + ,params) + (lambda ,lamparams ,@(cdr args))))) + +(defun eieio-defmethod (method args &optional code) "Work part of the `defmethod' macro defining METHOD with ARGS." (let ((key nil) (body nil) (firstarg nil) (argfix nil) (argclass nil) loopa) ;; find optional keys @@ -1349,10 +1371,7 @@ Summary: ;; generics are higher (setq key (eieio-specialized-key-to-generic-key key))) ;; Put this lambda into the symbol so we can find it - (if (byte-code-function-p (car-safe body)) - (eieiomt-add method (car-safe body) key argclass) - (eieiomt-add method (append (list 'lambda (reverse argfix)) body) - key argclass)) + (eieiomt-add method code key argclass) ) (when eieio-optimize-primary-methods-flag diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index bccc60a24e0..781195d034a 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -153,13 +153,14 @@ Assumes the caller has bound `macroexpand-all-environment'." ;; here, so that any code that cares about the difference will ;; see the same transformation. ;; First arg is a function: - (`(,(and fun (or `apply `mapcar `mapatoms `mapconcat `mapc)) ',f . ,args) + (`(,(and fun (or `apply `mapcar `mapatoms `mapconcat `mapc)) + ',(and f `(lambda . ,_)) . ,args) ;; We don't use `maybe-cons' since there's clearly a change. (cons fun (cons (macroexpand-all-1 (list 'function f)) (macroexpand-all-forms args)))) ;; Second arg is a function: - (`(,(and fun (or `sort)) ,arg1 ',f . ,args) + (`(,(and fun (or `sort)) ,arg1 ',(and f `(lambda . ,_)) . ,args) ;; We don't use `maybe-cons' since there's clearly a change. (cons fun (cons (macroexpand-all-1 arg1) diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 49767e6e9d3..b488bc40acd 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -363,13 +363,6 @@ suitable file is found, return nil." (concat beg "built-in function"))) ((byte-code-function-p def) (concat beg "compiled Lisp function")) - ((and (funvecp def) (eq (aref def 0) 'curry)) - (if (symbolp (aref def 1)) - (format "a curried function calling `%s'" (aref def 1)) - "a curried function")) - ((funvecp def) - (format "a function-vector (funvec) of type `%s'" - (aref def 0))) ((symbolp def) (while (and (fboundp def) (symbolp (symbol-function def))) @@ -510,21 +503,6 @@ suitable file is found, return nil." ((or (stringp def) (vectorp def)) (format "\nMacro: %s" (format-kbd-macro def))) - ((and (funvecp def) (eq (aref def 0) 'curry)) - ;; Describe a curried-function's function and args - (let ((slot 0)) - (mapconcat (lambda (arg) - (setq slot (1+ slot)) - (cond - ((= slot 1) "") - ((= slot 2) - (format " Function: %S" arg)) - (t - (format "Argument %d: %S" - (- slot 3) arg)))) - def - "\n"))) - ((funvecp def) nil) (t "[Missing arglist. Please make a bug report.]"))) (high (help-highlight-arguments use doc))) (let ((fill-begin (point))) diff --git a/src/ChangeLog b/src/ChangeLog index d522b6c55dc..e7902b8c083 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,23 @@ +2011-02-25 Stefan Monnier + + * eval.c (Qcurry): Remove. + (funcall_funvec): Remove. + (funcall_lambda): Move new byte-code handling to reduce impact. + Treat all args as lexical in the case of lexbind. + (Fcurry): Remove. + * data.c (Qfunction_vector): Remove. + (Ffunvecp): Remove. + * lread.c (read1): Revert to calling make_byte_code here. + (read_vector): Don't call make_byte_code any more. + * lisp.h (enum pvec_type): Rename back to PVEC_COMPILED. + (XSETCOMPILED): Rename back from XSETFUNVEC. + (FUNVEC_SIZE): Remove. + (FUNVEC_COMPILED_TAG_P, FUNVEC_COMPILED_P): Remove. + (COMPILEDP): Rename back from FUNVECP. + * fns.c (Felt): Remove unexplained FUNVEC check. + * doc.c (Fdocumentation): Don't handle funvec. + * alloc.c (make_funvec, Ffunvec): Remove. + 2011-02-21 Stefan Monnier * bytecode.c (exec_byte_code): Change stack_ref and stack_set to use @@ -113,6 +133,42 @@ Merge funvec patch. +2004-05-20 Miles Bader + + * lisp.h: Declare make_funvec and Ffunvec. + (enum pvec_type): Rename `PVEC_COMPILED' to `PVEC_FUNVEC'. + (XSETFUNVEC): Rename from `XSETCOMPILED'. + (FUNVEC_SIZE, FUNVEC_COMPILED_TAG_P, FUNVEC_COMPILED_P): New macros. + (COMPILEDP): Define in terms of funvec macros. + (FUNVECP, GC_FUNVECP): Rename from `COMPILEDP' & `GC_COMPILEDP'. + (FUNCTIONP): Use FUNVECP instead of COMPILEDP. + * alloc.c (make_funvec, funvec): New functions. + (Fmake_byte_code): Make sure the first element is a list. + + * eval.c (Qcurry): New variable. + (funcall_funvec, Fcurry): New functions. + (syms_of_eval): Initialize them. + (funcall_lambda): Handle non-bytecode funvec objects by calling + funcall_funvec. + (Ffuncall, Feval): Use FUNVECP insetad of COMPILEDP. + * lread.c (read1): Return result of read_vector for `#[' syntax + directly; read_vector now does any extra work required. + (read_vector): Handle both funvec and byte-code objects, converting the + type as necessary. `bytecodeflag' argument is now called + `read_funvec'. + * data.c (Ffunvecp): New function. + * doc.c (Fdocumentation): Return nil for unknown funvecs. + * fns.c (mapcar1, Felt, concat): Allow funvecs. + + * eval.c (Ffunctionp): Use `funvec' operators instead of `compiled' + operators. + * alloc.c (Fmake_byte_code, Fpurecopy, mark_object): Likewise. + * keyboard.c (Fcommand_execute): Likewise. + * image.c (parse_image_spec): Likewise. + * fns.c (Flength, concat, internal_equal): Likewise. + * data.c (Faref, Ftype_of): Likewise. + * print.c (print_preprocess, print_object): Likewise. + 2004-04-10 Miles Bader * eval.c (Fspecialp): New function. diff --git a/src/ChangeLog.funvec b/src/ChangeLog.funvec deleted file mode 100644 index 098539f1dd9..00000000000 --- a/src/ChangeLog.funvec +++ /dev/null @@ -1,37 +0,0 @@ -2004-05-20 Miles Bader - - * lisp.h: Declare make_funvec and Ffunvec. - (enum pvec_type): Rename `PVEC_COMPILED' to `PVEC_FUNVEC'. - (XSETFUNVEC): Renamed from `XSETCOMPILED'. - (FUNVEC_SIZE, FUNVEC_COMPILED_TAG_P, FUNVEC_COMPILED_P): New macros. - (COMPILEDP): Define in terms of funvec macros. - (FUNVECP, GC_FUNVECP): Renamed from `COMPILEDP' & `GC_COMPILEDP'. - (FUNCTIONP): Use FUNVECP instead of COMPILEDP. - * alloc.c (make_funvec, funvec): New functions. - (Fmake_byte_code): Make sure the first element is a list. - - * eval.c (Qcurry): New variable. - (funcall_funvec, Fcurry): New functions. - (syms_of_eval): Initialize them. - (funcall_lambda): Handle non-bytecode funvec objects by calling - funcall_funvec. - (Ffuncall, Feval): Use FUNVECP insetad of COMPILEDP. - * lread.c (read1): Return result of read_vector for `#[' syntax - directly; read_vector now does any extra work required. - (read_vector): Handle both funvec and byte-code objects, converting the - type as necessary. `bytecodeflag' argument is now called - `read_funvec'. - * data.c (Ffunvecp): New function. - * doc.c (Fdocumentation): Return nil for unknown funvecs. - * fns.c (mapcar1, Felt, concat): Allow funvecs. - - * eval.c (Ffunctionp): Use `funvec' operators instead of `compiled' - operators. - * alloc.c (Fmake_byte_code, Fpurecopy, mark_object): Likewise. - * keyboard.c (Fcommand_execute): Likewise. - * image.c (parse_image_spec): Likewise. - * fns.c (Flength, concat, internal_equal): Likewise. - * data.c (Faref, Ftype_of): Likewise. - * print.c (print_preprocess, print_object): Likewise. - -;; arch-tag: f35a6a00-4a11-4739-a4b6-9cf98296f315 diff --git a/src/alloc.c b/src/alloc.c index 81a17b5c13b..0b7db7ec627 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -2924,37 +2924,6 @@ See also the function `vector'. */) } -/* Return a new `function vector' containing KIND as the first element, - followed by NUM_NIL_SLOTS nil elements, and further elements copied from - the vector PARAMS of length NUM_PARAMS (so the total length of the - resulting vector is 1 + NUM_NIL_SLOTS + NUM_PARAMS). - - If NUM_PARAMS is zero, then PARAMS may be NULL. - - A `function vector', a.k.a. `funvec', is a funcallable vector in Emacs Lisp. - See the function `funvec' for more detail. */ - -Lisp_Object -make_funvec (Lisp_Object kind, int num_nil_slots, int num_params, - Lisp_Object *params) -{ - int param_index; - Lisp_Object funvec; - - funvec = Fmake_vector (make_number (1 + num_nil_slots + num_params), Qnil); - - ASET (funvec, 0, kind); - - for (param_index = 0; param_index < num_params; param_index++) - ASET (funvec, 1 + num_nil_slots + param_index, params[param_index]); - - XSETPVECTYPE (XVECTOR (funvec), PVEC_FUNVEC); - XSETFUNVEC (funvec, XVECTOR (funvec)); - - return funvec; -} - - DEFUN ("vector", Fvector, Svector, 0, MANY, 0, doc: /* Return a newly created vector with specified arguments as elements. Any number of arguments, even zero arguments, are allowed. @@ -2974,27 +2943,6 @@ usage: (vector &rest OBJECTS) */) } -DEFUN ("funvec", Ffunvec, Sfunvec, 1, MANY, 0, - doc: /* Return a newly created `function vector' of type KIND. -A `function vector', a.k.a. `funvec', is a funcallable vector in Emacs Lisp. -KIND indicates the kind of funvec, and determines its behavior when called. -The meaning of the remaining arguments depends on KIND. Currently -implemented values of KIND, and their meaning, are: - - A list -- A byte-compiled function. See `make-byte-code' for the usual - way to create byte-compiled functions. - - `curry' -- A curried function. Remaining arguments are a function to - call, and arguments to prepend to user arguments at the - time of the call; see the `curry' function. - -usage: (funvec KIND &rest PARAMS) */) - (int nargs, Lisp_Object *args) -{ - return make_funvec (args[0], 0, nargs - 1, args + 1); -} - - 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, @@ -3008,10 +2956,6 @@ usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INT register int index; register struct Lisp_Vector *p; - /* Make sure the arg-list is really a list, as that's what's used to - distinguish a byte-compiled object from other funvecs. */ - CHECK_LIST (args[0]); - XSETFASTINT (len, nargs); if (!NILP (Vpurify_flag)) val = make_pure_vector ((EMACS_INT) nargs); @@ -3033,8 +2977,8 @@ usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INT args[index] = Fpurecopy (args[index]); p->contents[index] = args[index]; } - XSETPVECTYPE (p, PVEC_FUNVEC); - XSETFUNVEC (val, p); + XSETPVECTYPE (p, PVEC_COMPILED); + XSETCOMPILED (val, p); return val; } @@ -4817,7 +4761,7 @@ Does not copy symbols. Copies strings without text properties. */) obj = make_pure_string (SSDATA (obj), SCHARS (obj), SBYTES (obj), STRING_MULTIBYTE (obj)); - else if (FUNVECP (obj) || VECTORP (obj)) + else if (COMPILEDP (obj) || VECTORP (obj)) { register struct Lisp_Vector *vec; register EMACS_INT i; @@ -4829,10 +4773,10 @@ Does not copy symbols. Copies strings without text properties. */) vec = XVECTOR (make_pure_vector (size)); for (i = 0; i < size; i++) vec->contents[i] = Fpurecopy (XVECTOR (obj)->contents[i]); - if (FUNVECP (obj)) + if (COMPILEDP (obj)) { - XSETPVECTYPE (vec, PVEC_FUNVEC); - XSETFUNVEC (obj, vec); + XSETPVECTYPE (vec, PVEC_COMPILED); + XSETCOMPILED (obj, vec); } else XSETVECTOR (obj, vec); @@ -5418,7 +5362,7 @@ mark_object (Lisp_Object arg) } else if (SUBRP (obj)) break; - else if (FUNVECP (obj) && FUNVEC_COMPILED_P (obj)) + else if (COMPILEDP (obj)) /* We could treat this just like a vector, but it is better to save the COMPILED_CONSTANTS element for last and avoid recursion there. */ @@ -6320,7 +6264,6 @@ The time is in seconds as a floating point value. */); defsubr (&Scons); defsubr (&Slist); defsubr (&Svector); - defsubr (&Sfunvec); defsubr (&Smake_byte_code); defsubr (&Smake_list); defsubr (&Smake_vector); diff --git a/src/bytecode.c b/src/bytecode.c index 639c543dbf9..464bc3d12de 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -51,7 +51,7 @@ by Hallvard: * * define BYTE_CODE_METER to enable generation of a byte-op usage histogram. */ -/* #define BYTE_CODE_SAFE 1 */ +/* #define BYTE_CODE_SAFE */ /* #define BYTE_CODE_METER */ @@ -1720,8 +1720,13 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, break; #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: */ /* Use `dup' instead. */ case Bstack_ref+1: case Bstack_ref+2: case Bstack_ref+3: diff --git a/src/data.c b/src/data.c index ecedba24101..186e9cb9859 100644 --- a/src/data.c +++ b/src/data.c @@ -84,7 +84,7 @@ static Lisp_Object Qsymbol, Qstring, Qcons, Qmarker, Qoverlay; Lisp_Object Qwindow; static Lisp_Object Qfloat, Qwindow_configuration; Lisp_Object Qprocess; -static Lisp_Object Qcompiled_function, Qfunction_vector, Qbuffer, Qframe, Qvector; +static Lisp_Object Qcompiled_function, Qbuffer, Qframe, Qvector; static Lisp_Object Qchar_table, Qbool_vector, Qhash_table; static Lisp_Object Qsubrp, Qmany, Qunevalled; Lisp_Object Qfont_spec, Qfont_entity, Qfont_object; @@ -194,11 +194,8 @@ for example, (type-of 1) returns `integer'. */) return Qwindow; if (SUBRP (object)) return Qsubr; - if (FUNVECP (object)) - if (FUNVEC_COMPILED_P (object)) - return Qcompiled_function; - else - return Qfunction_vector; + if (COMPILEDP (object)) + return Qcompiled_function; if (BUFFERP (object)) return Qbuffer; if (CHAR_TABLE_P (object)) @@ -397,13 +394,6 @@ DEFUN ("byte-code-function-p", Fbyte_code_function_p, Sbyte_code_function_p, return Qnil; } -DEFUN ("funvecp", Ffunvecp, Sfunvecp, 1, 1, 0, - doc: /* Return t if OBJECT is a `function vector' object. */) - (Lisp_Object object) -{ - return FUNVECP (object) ? Qt : Qnil; -} - DEFUN ("char-or-string-p", Fchar_or_string_p, Schar_or_string_p, 1, 1, 0, doc: /* Return t if OBJECT is a character or a string. */) (register Lisp_Object object) @@ -2113,9 +2103,9 @@ or a byte-code object. IDX starts at 0. */) { int size = 0; if (VECTORP (array)) - size = ASIZE (array); - else if (FUNVECP (array)) - size = FUNVEC_SIZE (array); + size = XVECTOR (array)->size; + else if (COMPILEDP (array)) + size = XVECTOR (array)->size & PSEUDOVECTOR_SIZE_MASK; else wrong_type_argument (Qarrayp, array); @@ -3180,7 +3170,6 @@ syms_of_data (void) Qwindow = intern_c_string ("window"); /* Qsubr = intern_c_string ("subr"); */ Qcompiled_function = intern_c_string ("compiled-function"); - Qfunction_vector = intern_c_string ("function-vector"); Qbuffer = intern_c_string ("buffer"); Qframe = intern_c_string ("frame"); Qvector = intern_c_string ("vector"); @@ -3206,7 +3195,6 @@ syms_of_data (void) staticpro (&Qwindow); /* staticpro (&Qsubr); */ staticpro (&Qcompiled_function); - staticpro (&Qfunction_vector); staticpro (&Qbuffer); staticpro (&Qframe); staticpro (&Qvector); @@ -3243,7 +3231,6 @@ syms_of_data (void) defsubr (&Smarkerp); defsubr (&Ssubrp); defsubr (&Sbyte_code_function_p); - defsubr (&Sfunvecp); defsubr (&Schar_or_string_p); defsubr (&Scar); defsubr (&Scdr); diff --git a/src/doc.c b/src/doc.c index 834321108b5..de20edb2d98 100644 --- a/src/doc.c +++ b/src/doc.c @@ -357,11 +357,6 @@ string is passed through `substitute-command-keys'. */) else return Qnil; } - else if (FUNVECP (fun)) - { - /* Unless otherwise handled, funvecs have no documentation. */ - return Qnil; - } else if (STRINGP (fun) || VECTORP (fun)) { return build_string ("Keyboard macro."); diff --git a/src/eval.c b/src/eval.c index 63484d40e1b..869d70e3d7f 100644 --- a/src/eval.c +++ b/src/eval.c @@ -60,7 +60,6 @@ Lisp_Object Qinhibit_quit; Lisp_Object Qand_rest, Qand_optional; Lisp_Object Qdebug_on_error; Lisp_Object Qdeclare; -Lisp_Object Qcurry; Lisp_Object Qinternal_interpreter_environment, Qclosure; Lisp_Object Qdebug; @@ -2405,7 +2404,7 @@ eval_sub (Lisp_Object form) } } } - else if (FUNVECP (fun)) + else if (COMPILEDP (fun)) val = apply_lambda (fun, original_args); else { @@ -2890,7 +2889,7 @@ DEFUN ("functionp", Ffunctionp, Sfunctionp, 1, 1, 0, if (SUBRP (object)) return (XSUBR (object)->max_args != UNEVALLED) ? Qt : Qnil; - else if (FUNVECP (object)) + else if (COMPILEDP (object)) return Qt; else if (CONSP (object)) { @@ -3034,7 +3033,7 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */) } } } - else if (FUNVECP (fun)) + else if (COMPILEDP (fun)) val = funcall_lambda (fun, numargs, args + 1); else { @@ -3107,54 +3106,6 @@ apply_lambda (Lisp_Object fun, Lisp_Object args) return tem; } - -/* Call a non-bytecode funvec object FUN, on the argments in ARGS (of - length NARGS). */ - -static Lisp_Object -funcall_funvec (Lisp_Object fun, int nargs, Lisp_Object *args) -{ - int size = FUNVEC_SIZE (fun); - Lisp_Object tag = (size > 0 ? AREF (fun, 0) : Qnil); - - if (EQ (tag, Qcurry)) - { - /* A curried function is a way to attach arguments to a another - function. The first element of the vector is the identifier - `curry', the second is the wrapped function, and remaining - elements are the attached arguments. */ - int num_curried_args = size - 2; - /* Offset of the curried and user args in the final arglist. Curried - args are first in the new arg vector, after the function. User - args follow. */ - int curried_args_offs = 1; - int user_args_offs = curried_args_offs + num_curried_args; - /* The curried function and arguments. */ - Lisp_Object *curry_params = XVECTOR (fun)->contents + 1; - /* The arguments in the curry vector. */ - Lisp_Object *curried_args = curry_params + 1; - /* The number of arguments with which we'll call funcall, and the - arguments themselves. */ - int num_funcall_args = 1 + num_curried_args + nargs; - Lisp_Object *funcall_args - = (Lisp_Object *) alloca (num_funcall_args * sizeof (Lisp_Object)); - - /* First comes the real function. */ - funcall_args[0] = curry_params[0]; - - /* Then the arguments in the appropriate order. */ - memcpy (funcall_args + curried_args_offs, curried_args, - num_curried_args * sizeof (Lisp_Object)); - memcpy (funcall_args + user_args_offs, args, - nargs * sizeof (Lisp_Object)); - - return Ffuncall (num_funcall_args, funcall_args); - } - else - xsignal1 (Qinvalid_function, fun); -} - - /* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR and return the result of evaluation. FUN must be either a lambda-expression or a compiled-code object. */ @@ -3167,34 +3118,6 @@ funcall_lambda (Lisp_Object fun, int nargs, int count = SPECPDL_INDEX (); int i, optional, rest; - if (COMPILEDP (fun) - && FUNVEC_SIZE (fun) > COMPILED_PUSH_ARGS - && ! NILP (XVECTOR (fun)->contents[COMPILED_PUSH_ARGS])) - /* 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), - AREF (fun, COMPILED_ARGLIST), - nargs, arg_vector); - } - - if (FUNVECP (fun) && !FUNVEC_COMPILED_P (fun)) - /* Byte-compiled functions are handled directly below, but we - call other funvec types via funcall_funvec. */ - return funcall_funvec (fun, nargs, arg_vector); - if (CONSP (fun)) { if (EQ (XCAR (fun), Qclosure)) @@ -3213,6 +3136,27 @@ funcall_lambda (Lisp_Object fun, int nargs, } else if (COMPILEDP (fun)) { + if ((ASIZE (fun) & PSEUDOVECTOR_SIZE_MASK) > COMPILED_PUSH_ARGS + && ! NILP (XVECTOR (fun)->contents[COMPILED_PUSH_ARGS])) + /* 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), + AREF (fun, COMPILED_ARGLIST), + nargs, arg_vector); + } syms_left = AREF (fun, COMPILED_ARGLIST); lexenv = Qnil; } @@ -3248,11 +3192,7 @@ funcall_lambda (Lisp_Object fun, int nargs, val = Qnil; /* Bind the argument. */ - if (!NILP (lexenv) && SYMBOLP (next) - /* FIXME: there's no good reason to allow dynamic-scoping - on function arguments, other than consistency with let. */ - && !XSYMBOL (next)->declared_special - && NILP (Fmemq (next, Vinternal_interpreter_environment))) + if (!NILP (lexenv) && SYMBOLP (next)) /* Lexically bind NEXT by adding it to the lexenv alist. */ lexenv = Fcons (Fcons (next, val), lexenv); else @@ -3532,24 +3472,6 @@ context where binding is lexical by default. */) -DEFUN ("curry", Fcurry, Scurry, 1, MANY, 0, - doc: /* Return FUN curried with ARGS. -The result is a function-like object that will append any arguments it -is called with to ARGS, and call FUN with the resulting list of arguments. - -For instance: - (funcall (curry '+ 3 4 5) 2) is the same as (funcall '+ 3 4 5 2) -and: - (mapcar (curry 'concat "The ") '("a" "b" "c")) - => ("The a" "The b" "The c") - -usage: (curry FUN &rest ARGS) */) - (int nargs, Lisp_Object *args) -{ - return make_funvec (Qcurry, 0, nargs, args); -} - - 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. The debugger is entered when that frame exits, if the flag is non-nil. */) @@ -3764,9 +3686,6 @@ before making `inhibit-quit' nil. */); Qclosure = intern_c_string ("closure"); staticpro (&Qclosure); - Qcurry = intern_c_string ("curry"); - staticpro (&Qcurry); - Qdebug = intern_c_string ("debug"); staticpro (&Qdebug); @@ -3901,11 +3820,9 @@ alist of active lexical bindings. */); defsubr (&Srun_hook_with_args_until_success); defsubr (&Srun_hook_with_args_until_failure); defsubr (&Sfetch_bytecode); - defsubr (&Scurry); defsubr (&Sbacktrace_debug); defsubr (&Sbacktrace); defsubr (&Sbacktrace_frame); - defsubr (&Scurry); defsubr (&Sspecial_variable_p); defsubr (&Sfunctionp); } diff --git a/src/fns.c b/src/fns.c index 5748c3d6e02..b800846b781 100644 --- a/src/fns.c +++ b/src/fns.c @@ -127,8 +127,8 @@ To get the number of bytes, use `string-bytes'. */) XSETFASTINT (val, MAX_CHAR); else if (BOOL_VECTOR_P (sequence)) XSETFASTINT (val, XBOOL_VECTOR (sequence)->size); - else if (FUNVECP (sequence)) - XSETFASTINT (val, FUNVEC_SIZE (sequence)); + else if (COMPILEDP (sequence)) + XSETFASTINT (val, ASIZE (sequence) & PSEUDOVECTOR_SIZE_MASK); else if (CONSP (sequence)) { i = 0; @@ -488,7 +488,7 @@ concat (int nargs, Lisp_Object *args, enum Lisp_Type target_type, int last_speci { this = args[argnum]; if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this) - || FUNVECP (this) || BOOL_VECTOR_P (this))) + || COMPILEDP (this) || BOOL_VECTOR_P (this))) wrong_type_argument (Qsequencep, this); } @@ -512,7 +512,7 @@ concat (int nargs, Lisp_Object *args, enum Lisp_Type target_type, int last_speci Lisp_Object ch; EMACS_INT this_len_byte; - if (VECTORP (this) || FUNVECP (this)) + if (VECTORP (this) || COMPILEDP (this)) for (i = 0; i < len; i++) { ch = AREF (this, i); @@ -1311,9 +1311,7 @@ DEFUN ("elt", Felt, Selt, 2, 2, 0, return Fcar (Fnthcdr (n, sequence)); /* Faref signals a "not array" error, so check here. */ - if (! FUNVECP (sequence)) - CHECK_ARRAY (sequence, Qsequencep); - + CHECK_ARRAY (sequence, Qsequencep); return Faref (sequence, n); } @@ -2092,14 +2090,13 @@ internal_equal (register Lisp_Object o1, register Lisp_Object o2, int depth, int if (WINDOW_CONFIGURATIONP (o1)) return compare_window_configurations (o1, o2, 0); - /* Aside from them, only true vectors, char-tables, function vectors, - and fonts (font-spec, font-entity, font-ojbect) are sensible to - compare, so eliminate the others now. */ + /* Aside from them, only true vectors, char-tables, compiled + functions, and fonts (font-spec, font-entity, font-ojbect) + are sensible to compare, so eliminate the others now. */ if (size & PSEUDOVECTOR_FLAG) { - if (!(size & (PVEC_FUNVEC - | PVEC_CHAR_TABLE | PVEC_SUB_CHAR_TABLE - | PVEC_FONT))) + if (!(size & (PVEC_COMPILED + | PVEC_CHAR_TABLE | PVEC_SUB_CHAR_TABLE | PVEC_FONT))) return 0; size &= PSEUDOVECTOR_SIZE_MASK; } @@ -2302,7 +2299,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) || FUNVECP (seq)) + if (VECTORP (seq) || COMPILEDP (seq)) { for (i = 0; i < leni; i++) { diff --git a/src/image.c b/src/image.c index f4a50e92ab1..a7c6346f62c 100644 --- a/src/image.c +++ b/src/image.c @@ -835,8 +835,9 @@ parse_image_spec (Lisp_Object spec, struct image_keyword *keywords, case IMAGE_FUNCTION_VALUE: value = indirect_function (value); + /* FIXME: Shouldn't we use Ffunctionp here? */ if (SUBRP (value) - || FUNVECP (value) + || COMPILEDP (value) || (CONSP (value) && EQ (XCAR (value), Qlambda))) break; return 0; diff --git a/src/keyboard.c b/src/keyboard.c index 1f14af78844..78aa1cfea77 100644 --- a/src/keyboard.c +++ b/src/keyboard.c @@ -10179,7 +10179,7 @@ a special event, so ignore the prefix argument and don't clear it. */) return Fexecute_kbd_macro (final, prefixarg, Qnil); } - if (CONSP (final) || SUBRP (final) || FUNVECP (final)) + if (CONSP (final) || SUBRP (final) || COMPILEDP (final)) /* Don't call Fcall_interactively directly because we want to make sure the backtrace has an entry for `call-interactively'. For the same reason, pass `cmd' rather than `final'. */ diff --git a/src/lisp.h b/src/lisp.h index badeb4258fb..223cdbc92f0 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -349,7 +349,7 @@ enum pvec_type PVEC_NORMAL_VECTOR = 0, PVEC_PROCESS = 0x200, PVEC_FRAME = 0x400, - PVEC_FUNVEC = 0x800, + PVEC_COMPILED = 0x800, PVEC_WINDOW = 0x1000, PVEC_WINDOW_CONFIGURATION = 0x2000, PVEC_SUBR = 0x4000, @@ -607,7 +607,7 @@ extern Lisp_Object make_number (EMACS_INT); #define XSETWINDOW(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_WINDOW)) #define XSETTERMINAL(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_TERMINAL)) #define XSETSUBR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_SUBR)) -#define XSETFUNVEC(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_FUNVEC)) +#define XSETCOMPILED(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_COMPILED)) #define XSETBUFFER(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_BUFFER)) #define XSETCHAR_TABLE(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_CHAR_TABLE)) #define XSETBOOL_VECTOR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_BOOL_VECTOR)) @@ -623,9 +623,6 @@ extern Lisp_Object make_number (EMACS_INT); eassert ((IDX) >= 0 && (IDX) < ASIZE (ARRAY)), \ AREF ((ARRAY), (IDX)) = (VAL)) -/* Return the size of the psuedo-vector object FUNVEC. */ -#define FUNVEC_SIZE(funvec) (ASIZE (funvec) & PSEUDOVECTOR_SIZE_MASK) - /* Convenience macros for dealing with Lisp strings. */ #define SDATA(string) (XSTRING (string)->data + 0) @@ -1474,7 +1471,7 @@ struct Lisp_Float typedef unsigned char UCHAR; #endif -/* Meanings of slots in a byte-compiled function vector: */ +/* Meanings of slots in a Lisp_Compiled: */ #define COMPILED_ARGLIST 0 #define COMPILED_BYTECODE 1 @@ -1484,24 +1481,6 @@ typedef unsigned char UCHAR; #define COMPILED_INTERACTIVE 5 #define COMPILED_PUSH_ARGS 6 -/* Return non-zero if TAG, the first element from a funvec object, refers - to a byte-code object. Byte-code objects are distinguished from other - `funvec' objects by having a (possibly empty) list as their first - element -- other funvec types use a non-nil symbol there. */ -#define FUNVEC_COMPILED_TAG_P(tag) \ - (NILP (tag) || CONSP (tag)) - -/* Return non-zero if FUNVEC, which should be a `funvec' object, is a - byte-compiled function. Byte-compiled function are funvecs with the - arglist as the first element (other funvec types will have a symbol - identifying the type as the first object). */ -#define FUNVEC_COMPILED_P(funvec) \ - (FUNVEC_SIZE (funvec) > 0 && FUNVEC_COMPILED_TAG_P (AREF (funvec, 0))) - -/* Return non-zero if OBJ is byte-compile function. */ -#define COMPILEDP(obj) \ - (FUNVECP (obj) && FUNVEC_COMPILED_P (obj)) - /* Flag bits in a character. These also get used in termhooks.h. Richard Stallman thinks that MULE (MUlti-Lingual Emacs) might need 22 bits for the character value @@ -1657,7 +1636,7 @@ typedef struct { #define WINDOWP(x) PSEUDOVECTORP (x, PVEC_WINDOW) #define TERMINALP(x) PSEUDOVECTORP (x, PVEC_TERMINAL) #define SUBRP(x) PSEUDOVECTORP (x, PVEC_SUBR) -#define FUNVECP(x) PSEUDOVECTORP (x, PVEC_FUNVEC) +#define COMPILEDP(x) PSEUDOVECTORP (x, PVEC_COMPILED) #define BUFFERP(x) PSEUDOVECTORP (x, PVEC_BUFFER) #define CHAR_TABLE_P(x) PSEUDOVECTORP (x, PVEC_CHAR_TABLE) #define SUB_CHAR_TABLE_P(x) PSEUDOVECTORP (x, PVEC_SUB_CHAR_TABLE) @@ -1851,7 +1830,7 @@ typedef struct { #define FUNCTIONP(OBJ) \ ((CONSP (OBJ) && EQ (XCAR (OBJ), Qlambda)) \ || (SYMBOLP (OBJ) && !NILP (Ffboundp (OBJ))) \ - || FUNVECP (OBJ) \ + || COMPILEDP (OBJ) \ || SUBRP (OBJ)) /* defsubr (Sname); @@ -2725,7 +2704,6 @@ EXFUN (Fmake_list, 2); extern Lisp_Object allocate_misc (void); EXFUN (Fmake_vector, 2); EXFUN (Fvector, MANY); -EXFUN (Ffunvec, MANY); EXFUN (Fmake_symbol, 1); EXFUN (Fmake_marker, 0); EXFUN (Fmake_string, 2); @@ -2745,7 +2723,6 @@ extern Lisp_Object make_pure_c_string (const char *data); extern Lisp_Object pure_cons (Lisp_Object, Lisp_Object); extern Lisp_Object make_pure_vector (EMACS_INT); EXFUN (Fgarbage_collect, 0); -extern Lisp_Object make_funvec (Lisp_Object, int, int, Lisp_Object *); EXFUN (Fmake_byte_code, MANY); EXFUN (Fmake_bool_vector, 2); extern Lisp_Object Qchar_table_extra_slots; diff --git a/src/lread.c b/src/lread.c index b30a75b67c3..77b397a03df 100644 --- a/src/lread.c +++ b/src/lread.c @@ -2497,8 +2497,14 @@ read1 (register Lisp_Object readcharfun, int *pch, int first_in_list) invalid_syntax ("#&...", 5); } if (c == '[') - /* `function vector' objects, including byte-compiled functions. */ - return read_vector (readcharfun, 1); + { + /* Accept compiled functions at read-time so that we don't have to + build them using function calls. */ + Lisp_Object tmp; + tmp = read_vector (readcharfun, 1); + return Fmake_byte_code (XVECTOR (tmp)->size, + XVECTOR (tmp)->contents); + } if (c == '(') { Lisp_Object tmp; @@ -3311,7 +3317,7 @@ isfloat_string (const char *cp, int ignore_trailing) static Lisp_Object -read_vector (Lisp_Object readcharfun, int read_funvec) +read_vector (Lisp_Object readcharfun, int bytecodeflag) { register int i; register int size; @@ -3319,11 +3325,6 @@ read_vector (Lisp_Object readcharfun, int read_funvec) register Lisp_Object tem, item, vector; register struct Lisp_Cons *otem; Lisp_Object len; - /* If we're reading a funvec object we start out assuming it's also a - byte-code object (a subset of funvecs), so we can do any special - processing needed. If it's just an ordinary funvec object, we'll - realize that as soon as we've read the first element. */ - int read_bytecode = read_funvec; tem = read_list (1, readcharfun); len = Flength (tem); @@ -3335,18 +3336,11 @@ read_vector (Lisp_Object readcharfun, int read_funvec) { item = Fcar (tem); - /* If READ_BYTECODE is set, check whether this is really a byte-code - object, or just an ordinary `funvec' object -- non-byte-code - funvec objects use the same reader syntax. We can tell from the - first element which one it is. */ - if (read_bytecode && i == 0 && ! FUNVEC_COMPILED_TAG_P (item)) - read_bytecode = 0; /* Nope. */ - /* If `load-force-doc-strings' is t when reading a lazily-loaded bytecode object, the docstring containing the bytecode and constants values must be treated as unibyte and passed to Fread, to get the actual bytecode string and constants vector. */ - if (read_bytecode && load_force_doc_strings) + if (bytecodeflag && load_force_doc_strings) { if (i == COMPILED_BYTECODE) { @@ -3400,13 +3394,6 @@ read_vector (Lisp_Object readcharfun, int read_funvec) free_cons (otem); } - if (read_bytecode && size >= 4) - /* Convert this vector to a bytecode object. */ - vector = Fmake_byte_code (size, XVECTOR (vector)->contents); - else if (read_funvec && size >= 1) - /* Convert this vector to an ordinary funvec object. */ - XSETFUNVEC (vector, XVECTOR (vector)); - return vector; } diff --git a/src/print.c b/src/print.c index 11bce153ffc..00847d67318 100644 --- a/src/print.c +++ b/src/print.c @@ -1155,7 +1155,7 @@ print_preprocess (Lisp_Object obj) loop: if (STRINGP (obj) || CONSP (obj) || VECTORP (obj) - || FUNVECP (obj) || CHAR_TABLE_P (obj) || SUB_CHAR_TABLE_P (obj) + || COMPILEDP (obj) || CHAR_TABLE_P (obj) || SUB_CHAR_TABLE_P (obj) || HASH_TABLE_P (obj) || (! NILP (Vprint_gensym) && SYMBOLP (obj) @@ -1337,7 +1337,7 @@ print_object (Lisp_Object obj, register Lisp_Object printcharfun, int escapeflag /* Detect circularities and truncate them. */ if (STRINGP (obj) || CONSP (obj) || VECTORP (obj) - || FUNVECP (obj) || CHAR_TABLE_P (obj) || SUB_CHAR_TABLE_P (obj) + || COMPILEDP (obj) || CHAR_TABLE_P (obj) || SUB_CHAR_TABLE_P (obj) || HASH_TABLE_P (obj) || (! NILP (Vprint_gensym) && SYMBOLP (obj) @@ -1960,7 +1960,7 @@ print_object (Lisp_Object obj, register Lisp_Object printcharfun, int escapeflag else { EMACS_INT size = XVECTOR (obj)->size; - if (FUNVECP (obj)) + if (COMPILEDP (obj)) { PRINTCHAR ('#'); size &= PSEUDOVECTOR_SIZE_MASK; -- cgit v1.3 From a9de04fa62f123413d82b7b7b1e7a77705eb82dd Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Sat, 26 Feb 2011 10:19:08 -0500 Subject: Compute freevars in cconv-analyse. * lisp/emacs-lisp/cconv.el: Compute freevars in cconv-analyse. (cconv-mutated, cconv-captured): Remove. (cconv-captured+mutated, cconv-lambda-candidates): Don't give them a global value. (cconv-freevars-alist): New var. (cconv-freevars): Remove. (cconv--lookup-let): Remove. (cconv-closure-convert-function): Extract from cconv-closure-convert-rec. (cconv-closure-convert-rec): Adjust to above changes. (fboundp): New function. (cconv-analyse-function, form): Rewrite. * lisp/emacs-lisp/bytecomp.el (byte-compile-initial-macro-environment): Handle declare-function here. (byte-compile-obsolete): Remove. (byte-compile-arglist-warn): Check late defsubst here. (byte-compile-file-form): Simplify. (byte-compile-file-form-defsubst): Remove. (byte-compile-macroexpand-declare-function): Rename from byte-compile-declare-function, turn it into a macro-expander. (byte-compile-normal-call): Check obsolescence. (byte-compile-quote-form): Remove. (byte-compile-defmacro): Revert to trunk's definition which seems to work just as well and handles `declare'. * lisp/emacs-lisp/byte-run.el (make-obsolete): Don't modify byte-compile. * lisp/Makefile.in (BIG_STACK_DEPTH): Increase to 1200. (compile-onefile): Pass $(BIG_STACK_OPTS) before "-l bytecomp". * lisp/emacs-lisp/macroexp.el: Use lexbind. (macroexpand-all-1): Check macro obsolescence. * lisp/vc/diff-mode.el: Use lexbind. * lisp/follow.el (follow-calc-win-end): Simplify. --- lisp/ChangeLog | 33 ++++ lisp/Makefile.in | 8 +- lisp/emacs-lisp/byte-run.el | 10 +- lisp/emacs-lisp/bytecomp.el | 123 +++++------- lisp/emacs-lisp/cconv.el | 468 +++++++++++++++++++------------------------- lisp/emacs-lisp/debug.el | 1 + lisp/emacs-lisp/macroexp.el | 11 +- lisp/follow.el | 3 +- lisp/vc/diff-mode.el | 4 +- src/bytecode.c | 2 +- 10 files changed, 309 insertions(+), 354 deletions(-) (limited to 'src/bytecode.c') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index ee6944d8e07..1b5e9400a8c 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,36 @@ +2011-02-26 Stefan Monnier + + * emacs-lisp/cconv.el: Compute freevars in cconv-analyse. + (cconv-mutated, cconv-captured): Remove. + (cconv-captured+mutated, cconv-lambda-candidates): Don't give them + a global value. + (cconv-freevars-alist): New var. + (cconv-freevars): Remove. + (cconv--lookup-let): Remove. + (cconv-closure-convert-function): Extract from cconv-closure-convert-rec. + (cconv-closure-convert-rec): Adjust to above changes. + (fboundp): New function. + (cconv-analyse-function, form): Rewrite. + * emacs-lisp/bytecomp.el (byte-compile-initial-macro-environment): + Handle declare-function here. + (byte-compile-obsolete): Remove. + (byte-compile-arglist-warn): Check late defsubst here. + (byte-compile-file-form): Simplify. + (byte-compile-file-form-defsubst): Remove. + (byte-compile-macroexpand-declare-function): Rename from + byte-compile-declare-function, turn it into a macro-expander. + (byte-compile-normal-call): Check obsolescence. + (byte-compile-quote-form): Remove. + (byte-compile-defmacro): Revert to trunk's definition which seems to + work just as well and handles `declare'. + * emacs-lisp/byte-run.el (make-obsolete): Don't modify byte-compile. + * Makefile.in (BIG_STACK_DEPTH): Increase to 1200. + (compile-onefile): Pass $(BIG_STACK_OPTS) before "-l bytecomp". + * emacs-lisp/macroexp.el: Use lexbind. + (macroexpand-all-1): Check macro obsolescence. + * vc/diff-mode.el: Use lexbind. + * follow.el (follow-calc-win-end): Simplify. + 2011-02-25 Stefan Monnier * emacs-lisp/bytecomp.el (byte-compile-lapcode): Handle new form of diff --git a/lisp/Makefile.in b/lisp/Makefile.in index 389d5b154aa..0182b7f5072 100644 --- a/lisp/Makefile.in +++ b/lisp/Makefile.in @@ -74,7 +74,7 @@ AUTOGENEL = loaddefs.el \ # During bootstrapping the byte-compiler is run interpreted when compiling # itself, and uses more stack than usual. # -BIG_STACK_DEPTH = 1000 +BIG_STACK_DEPTH = 1200 BIG_STACK_OPTS = --eval "(setq max-lisp-eval-depth $(BIG_STACK_DEPTH))" # Files to compile before others during a bootstrap. This is done to @@ -205,8 +205,8 @@ compile-onefile: @echo Compiling $(THEFILE) @# Use byte-compile-refresh-preloaded to try and work around some of @# the most common bootstrapping problems. - $(emacs) -l bytecomp.el -f byte-compile-refresh-preloaded \ - $(BIG_STACK_OPTS) $(BYTE_COMPILE_EXTRA_FLAGS) \ + @$(emacs) $(BIG_STACK_OPTS) -l bytecomp $(BYTE_COMPILE_EXTRA_FLAGS) \ + -f byte-compile-refresh-preloaded \ -f batch-byte-compile $(THEFILE) # Files MUST be compiled one by one. If we compile several files in a @@ -222,7 +222,7 @@ compile-onefile: # cannot have prerequisites. .el.elc: @echo Compiling $< - $(emacs) $(BIG_STACK_OPTS) $(BYTE_COMPILE_EXTRA_FLAGS) \ + @$(emacs) $(BIG_STACK_OPTS) $(BYTE_COMPILE_EXTRA_FLAGS) \ -f batch-byte-compile $< .PHONY: compile-first compile-main compile compile-always diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 524f4f1b465..3fb3d841ed1 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -123,12 +123,10 @@ If CURRENT-NAME is a string, that is the `use instead' message If provided, WHEN should be a string indicating when the function was first made obsolete, for example a date or a release number." (interactive "aMake function obsolete: \nxObsoletion replacement: ") - (let ((handler (get obsolete-name 'byte-compile))) - (if (eq 'byte-compile-obsolete handler) - (setq handler (nth 1 (get obsolete-name 'byte-obsolete-info))) - (put obsolete-name 'byte-compile 'byte-compile-obsolete)) - (put obsolete-name 'byte-obsolete-info - (list (purecopy current-name) handler (purecopy when)))) + (put obsolete-name 'byte-obsolete-info + ;; The second entry used to hold the `byte-compile' handler, but + ;; is not used any more nowadays. + (list (purecopy current-name) nil (purecopy when))) obsolete-name) (set-advertised-calling-convention ;; New code should always provide the `when' argument. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 6bc2b3b5617..4a53faefa3d 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -424,6 +424,7 @@ This list lives partly on the stack.") '( ;; (byte-compiler-options . (lambda (&rest forms) ;; (apply 'byte-compiler-options-handler forms))) + (declare-function . byte-compile-macroexpand-declare-function) (eval-when-compile . (lambda (&rest body) (list 'quote @@ -1140,13 +1141,6 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." (byte-compile-log-warning (error-message-string error-info) nil :error)) - -;;; Used by make-obsolete. -(defun byte-compile-obsolete (form) - (byte-compile-set-symbol-position (car form)) - (byte-compile-warn-obsolete (car form)) - (funcall (or (cadr (get (car form) 'byte-obsolete-info)) ; handler - 'byte-compile-normal-call) form)) ;;; sanity-checking arglists @@ -1328,7 +1322,8 @@ extra args." ;; Warn if the function or macro is being redefined with a different ;; number of arguments. (defun byte-compile-arglist-warn (form macrop) - (let ((old (byte-compile-fdefinition (nth 1 form) macrop))) + (let* ((name (nth 1 form)) + (old (byte-compile-fdefinition name macrop))) (if (and old (not (eq old t))) (progn (and (eq 'macro (car-safe old)) @@ -1342,36 +1337,39 @@ extra args." (t '(&rest def))))) (sig2 (byte-compile-arglist-signature (nth 2 form)))) (unless (byte-compile-arglist-signatures-congruent-p sig1 sig2) - (byte-compile-set-symbol-position (nth 1 form)) + (byte-compile-set-symbol-position name) (byte-compile-warn "%s %s used to take %s %s, now takes %s" (if (eq (car form) 'defun) "function" "macro") - (nth 1 form) + name (byte-compile-arglist-signature-string sig1) (if (equal sig1 '(1 . 1)) "argument" "arguments") (byte-compile-arglist-signature-string sig2))))) ;; This is the first definition. See if previous calls are compatible. - (let ((calls (assq (nth 1 form) byte-compile-unresolved-functions)) + (let ((calls (assq name byte-compile-unresolved-functions)) nums sig min max) - (if calls - (progn - (setq sig (byte-compile-arglist-signature (nth 2 form)) - nums (sort (copy-sequence (cdr calls)) (function <)) - min (car nums) - max (car (nreverse nums))) - (when (or (< min (car sig)) - (and (cdr sig) (> max (cdr sig)))) - (byte-compile-set-symbol-position (nth 1 form)) - (byte-compile-warn - "%s being defined to take %s%s, but was previously called with %s" - (nth 1 form) - (byte-compile-arglist-signature-string sig) - (if (equal sig '(1 . 1)) " arg" " args") - (byte-compile-arglist-signature-string (cons min max)))) - - (setq byte-compile-unresolved-functions - (delq calls byte-compile-unresolved-functions))))) - ))) + (when calls + (when (and (symbolp name) + (eq (get name 'byte-optimizer) + 'byte-compile-inline-expand)) + (byte-compile-warn "defsubst `%s' was used before it was defined" + name)) + (setq sig (byte-compile-arglist-signature (nth 2 form)) + nums (sort (copy-sequence (cdr calls)) (function <)) + min (car nums) + max (car (nreverse nums))) + (when (or (< min (car sig)) + (and (cdr sig) (> max (cdr sig)))) + (byte-compile-set-symbol-position name) + (byte-compile-warn + "%s being defined to take %s%s, but was previously called with %s" + name + (byte-compile-arglist-signature-string sig) + (if (equal sig '(1 . 1)) " arg" " args") + (byte-compile-arglist-signature-string (cons min max)))) + + (setq byte-compile-unresolved-functions + (delq calls byte-compile-unresolved-functions))))))) (defvar byte-compile-cl-functions nil "List of functions defined in CL.") @@ -1470,7 +1468,7 @@ symbol itself." (if any-value (or (memq symbol byte-compile-const-variables) ;; FIXME: We should provide a less intrusive way to find out - ;; is a variable is "constant". + ;; if a variable is "constant". (and (boundp symbol) (condition-case nil (progn (set symbol (symbol-value symbol)) nil) @@ -2198,9 +2196,8 @@ list that represents a doc string reference. ;; byte-hunk-handlers can call this. (defun byte-compile-file-form (form) (let (bytecomp-handler) - (cond ((not (consp form)) - (byte-compile-keep-pending form)) - ((and (symbolp (car form)) + (cond ((and (consp form) + (symbolp (car form)) (setq bytecomp-handler (get (car form) 'byte-hunk-handler))) (cond ((setq form (funcall bytecomp-handler form)) (byte-compile-flush-pending) @@ -2212,16 +2209,6 @@ list that represents a doc string reference. ;; so make-docfile can recognise them. Most other things can be output ;; as byte-code. -(put 'defsubst 'byte-hunk-handler 'byte-compile-file-form-defsubst) -(defun byte-compile-file-form-defsubst (form) - (when (assq (nth 1 form) byte-compile-unresolved-functions) - (setq byte-compile-current-form (nth 1 form)) - (byte-compile-warn "defsubst `%s' was used before it was defined" - (nth 1 form))) - (byte-compile-file-form form) - ;; Return nil so the form is not output twice. - nil) - (put 'autoload 'byte-hunk-handler 'byte-compile-file-form-autoload) (defun byte-compile-file-form-autoload (form) (and (let ((form form)) @@ -2914,7 +2901,6 @@ If FORM is a lambda or a macro, byte-compile it as a function." ;; Given BYTECOMP-BODY, compile it and return a new body. (defun byte-compile-top-level-body (bytecomp-body &optional for-effect) - ;; FIXME: lexbind. Check all callers! (setq bytecomp-body (byte-compile-top-level (cons 'progn bytecomp-body) for-effect t)) (cond ((eq (car-safe bytecomp-body) 'progn) @@ -2922,20 +2908,18 @@ If FORM is a lambda or a macro, byte-compile it as a function." (bytecomp-body (list bytecomp-body)))) -;; FIXME: Like defsubst's, this hunk-handler won't be called any more -;; because the macro is expanded away before we see it. -(put 'declare-function 'byte-hunk-handler 'byte-compile-declare-function) -(defun byte-compile-declare-function (form) - (push (cons (nth 1 form) - (if (and (> (length form) 3) - (listp (nth 3 form))) - (list 'declared (nth 3 form)) +;; Special macro-expander used during byte-compilation. +(defun byte-compile-macroexpand-declare-function (fn file &rest args) + (push (cons fn + (if (and (consp args) (listp (car args))) + (list 'declared (car args)) t)) ; arglist not specified byte-compile-function-environment) ;; We are stating that it _will_ be defined at runtime. (setq byte-compile-noruntime-functions - (delq (nth 1 form) byte-compile-noruntime-functions)) - nil) + (delq fn byte-compile-noruntime-functions)) + ;; Delegate the rest to the normal macro definition. + (macroexpand `(declare-function ,fn ,file ,@args))) ;; This is the recursive entry point for compiling each subform of an @@ -3005,6 +2989,8 @@ That command is designed for interactive use only" bytecomp-fn)) '(custom-declare-group custom-declare-variable custom-declare-face)) (byte-compile-nogroup-warn form)) + (when (get (car form) 'byte-obsolete-info) + (byte-compile-warn-obsolete (car form))) (byte-compile-callargs-warn form)) (if byte-compile-generate-call-tree (byte-compile-annotate-call-tree form)) @@ -3562,7 +3548,6 @@ discarding." (byte-defop-compiler-1 setq) (byte-defop-compiler-1 setq-default) (byte-defop-compiler-1 quote) -(byte-defop-compiler-1 quote-form) (defun byte-compile-setq (form) (let ((bytecomp-args (cdr form))) @@ -3606,10 +3591,6 @@ discarding." (defun byte-compile-quote (form) (byte-compile-constant (car (cdr form)))) - -(defun byte-compile-quote-form (form) - (byte-compile-constant (byte-compile-top-level (nth 1 form)))) - ;;; control structures @@ -3845,6 +3826,7 @@ Return the offset in the form (VAR . OFFSET)." (byte-compile-push-constant nil))))) (defun byte-compile-not-lexical-var-p (var) + ;; FIXME: this doesn't catch defcustoms! (or (not (symbolp var)) (special-variable-p var) (memq var byte-compile-bound-variables) @@ -4097,15 +4079,16 @@ binding slots have been popped." (defun byte-compile-defmacro (form) ;; This is not used for file-level defmacros with doc strings. - ;; FIXME handle decls, use defalias? - (let ((decls (byte-compile-defmacro-declaration form)) - (code (byte-compile-lambda (cdr (cdr form)) t)) - (for-effect nil)) - (byte-compile-push-constant (nth 1 form)) - (byte-compile-push-constant (cons 'macro code)) - (byte-compile-out 'byte-fset) - (byte-compile-discard)) - (byte-compile-constant (nth 1 form))) + (byte-compile-body-do-effect + (let ((decls (byte-compile-defmacro-declaration form)) + (code (byte-compile-byte-code-maker + (byte-compile-lambda (cdr (cdr form)) t)))) + `((defalias ',(nth 1 form) + ,(if (eq (car-safe code) 'make-byte-code) + `(cons 'macro ,code) + `'(macro . ,(eval code)))) + ,@decls + ',(nth 1 form))))) (defun byte-compile-defvar (form) ;; This is not used for file-level defvar/consts with doc strings. @@ -4153,7 +4136,7 @@ binding slots have been popped." `(if (not (default-boundp ',var)) (setq-default ,var ,value)))) (when (eq fun 'defconst) ;; This will signal an appropriate error at runtime. - `(eval ',form))) ;FIXME: lexbind + `(eval ',form))) `',var)))) (defun byte-compile-autoload (form) diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index bc7ecb1ad55..0e4b5d31699 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -82,110 +82,19 @@ (defconst cconv-liftwhen 3 "Try to do lambda lifting if the number of arguments + free variables is less than this number.") -(defvar cconv-mutated nil - "List of mutated variables in current form") -(defvar cconv-captured nil - "List of closure captured variables in current form") -(defvar cconv-captured+mutated nil - "An intersection between cconv-mutated and cconv-captured lists.") -(defvar cconv-lambda-candidates nil - "List of candidates for lambda lifting. -Each candidate has the form (VAR INCLOSURE BINDER PARENTFORM).") - -(defun cconv-freevars (form &optional fvrs) - "Find all free variables of given form. -Arguments: --- FORM is a piece of Elisp code after macroexpansion. --- FVRS(optional) is a list of variables already found. Used for recursive tree -traversal - -Returns a list of free variables." - ;; If a leaf in the tree is a symbol, but it is not a global variable, not a - ;; keyword, not 'nil or 't we consider this leaf as a variable. - ;; Free variables are the variables that are not declared above in this tree. - ;; For example free variables of (lambda (a1 a2 ..) body-forms) are - ;; free variables of body-forms excluding a1, a2 .. - ;; Free variables of (let ((v1 ..) (v2) ..)) body-forms) are - ;; free variables of body-forms excluding v1, v2 ... - ;; and so on. - - ;; A list of free variables already found(FVRS) is passed in parameter - ;; to try to use cons or push where possible, and to minimize the usage - ;; of append. - - ;; This function can return duplicates (because we use 'append instead - ;; of union of two sets - for performance reasons). - (pcase form - (`(let ,varsvalues . ,body-forms) ; let special form - (let ((fvrs-1 '())) - (dolist (exp body-forms) - (setq fvrs-1 (cconv-freevars exp fvrs-1))) - (dolist (elm varsvalues) - (setq fvrs-1 (delq (if (consp elm) (car elm) elm) fvrs-1))) - (setq fvrs (nconc fvrs-1 fvrs)) - (dolist (exp varsvalues) - (when (consp exp) (setq fvrs (cconv-freevars (cadr exp) fvrs)))) - fvrs)) - - (`(let* ,varsvalues . ,body-forms) ; let* special form - (let ((vrs '()) - (fvrs-1 '())) - (dolist (exp varsvalues) - (if (consp exp) - (progn - (setq fvrs-1 (cconv-freevars (cadr exp) fvrs-1)) - (dolist (elm vrs) (setq fvrs-1 (delq elm fvrs-1))) - (push (car exp) vrs)) - (progn - (dolist (elm vrs) (setq fvrs-1 (delq elm fvrs-1))) - (push exp vrs)))) - (dolist (exp body-forms) - (setq fvrs-1 (cconv-freevars exp fvrs-1))) - (dolist (elm vrs) (setq fvrs-1 (delq elm fvrs-1))) - (append fvrs fvrs-1))) - - (`((lambda . ,_) . ,_) ; first element is lambda expression - (dolist (exp `((function ,(car form)) . ,(cdr form))) - (setq fvrs (cconv-freevars exp fvrs))) fvrs) +;; List of all the variables that are both captured by a closure +;; and mutated. Each entry in the list takes the form +;; (BINDER . PARENTFORM) where BINDER is the (VAR VAL) that introduces the +;; variable (or is just (VAR) for variables not introduced by let). +(defvar cconv-captured+mutated) - (`(cond . ,cond-forms) ; cond special form - (dolist (exp1 cond-forms) - (dolist (exp2 exp1) - (setq fvrs (cconv-freevars exp2 fvrs)))) fvrs) - - (`(quote . ,_) fvrs) ; quote form +;; List of candidates for lambda lifting. +;; Each candidate has the form (BINDER . PARENTFORM). A candidate +;; is a variable that is only passed to `funcall' or `apply'. +(defvar cconv-lambda-candidates) - (`(function . ((lambda ,vars . ,body-forms))) - (let ((functionform (cadr form)) (fvrs-1 '())) - (dolist (exp body-forms) - (setq fvrs-1 (cconv-freevars exp fvrs-1))) - (dolist (elm vars) (setq fvrs-1 (delq elm fvrs-1))) - (append fvrs fvrs-1))) ; function form - - (`(function . ,_) fvrs) ; same as quote - ;condition-case - (`(condition-case ,var ,protected-form . ,conditions-bodies) - (let ((fvrs-1 '())) - (dolist (exp conditions-bodies) - (setq fvrs-1 (cconv-freevars (cadr exp) fvrs-1))) - (setq fvrs-1 (delq var fvrs-1)) - (setq fvrs-1 (cconv-freevars protected-form fvrs-1)) - (append fvrs fvrs-1))) - - (`(,(and sym (or `defun `defconst `defvar)) . ,_) - ;; We call cconv-freevars only for functions(lambdas) - ;; defun, defconst, defvar are not allowed to be inside - ;; a function (lambda). - ;; (error "Invalid form: %s inside a function" sym) - (cconv-freevars `(progn ,@(cddr form)) fvrs)) - - (`(,_ . ,body-forms) ; First element is (like) a function. - (dolist (exp body-forms) - (setq fvrs (cconv-freevars exp fvrs))) fvrs) - - (_ (if (byte-compile-not-lexical-var-p form) - fvrs - (cons form fvrs))))) +;; Alist associating to each function body the list of its free variables. +(defvar cconv-freevars-alist) ;;;###autoload (defun cconv-closure-convert (form) @@ -195,16 +104,12 @@ Returns a list of free variables." Returns a form where all lambdas don't have any free variables." ;; (message "Entering cconv-closure-convert...") - (let ((cconv-mutated '()) + (let ((cconv-freevars-alist '()) (cconv-lambda-candidates '()) - (cconv-captured '()) (cconv-captured+mutated '())) ;; Analyse form - fill these variables with new information. - (cconv-analyse-form form '() 0) - ;; Calculate an intersection of cconv-mutated and cconv-captured. - (dolist (mvr cconv-mutated) - (when (memq mvr cconv-captured) ; - (push mvr cconv-captured+mutated))) + (cconv-analyse-form form '()) + (setq cconv-freevars-alist (nreverse cconv-freevars-alist)) (cconv-closure-convert-rec form ; the tree '() ; @@ -213,15 +118,6 @@ Returns a form where all lambdas don't have any free variables." '() ))) -(defun cconv--lookup-let (table var binder form) - (let ((res nil)) - (dolist (elem table) - (when (and (eq (nth 2 elem) binder) - (eq (nth 3 elem) form)) - (assert (eq (car elem) var)) - (setq res elem))) - res)) - (defconst cconv--dummy-var (make-symbol "ignored")) (defun cconv--set-diff (s1 s2) @@ -261,6 +157,57 @@ Returns a form where all lambdas don't have any free variables." (unless (memq (car b) s) (push b res))) (nreverse res))) +(defun cconv-closure-convert-function (fvrs vars emvrs envs lmenvs body-forms + parentform) + (assert (equal body-forms (caar cconv-freevars-alist))) + (let* ((fvrs-new (cconv--set-diff fvrs vars)) ; Remove vars from fvrs. + (fv (cdr (pop cconv-freevars-alist))) + (body-forms-new '()) + (letbind '()) + (envector nil)) + (when fv + ;; Here we form our environment vector. + + (dolist (elm fv) + (push + (cconv-closure-convert-rec + ;; Remove `elm' from `emvrs' for this call because in case + ;; `elm' is a variable that's wrapped in a cons-cell, we + ;; want to put the cons-cell itself in the closure, rather + ;; than just a copy of its current content. + elm (remq elm emvrs) fvrs envs lmenvs) + envector)) ; Process vars for closure vector. + (setq envector (reverse envector)) + (setq envs fv) + (setq fvrs-new fv)) ; Update substitution list. + + (setq emvrs (cconv--set-diff emvrs vars)) + (setq lmenvs (cconv--map-diff-set lmenvs vars)) + + ;; The difference between envs and fvrs is explained + ;; in comment in the beginning of the function. + (dolist (var vars) + (when (member (cons (list var) parentform) cconv-captured+mutated) + (push var emvrs) + (push `(,var (list ,var)) letbind))) + (dolist (elm body-forms) ; convert function body + (push (cconv-closure-convert-rec + elm emvrs fvrs-new envs lmenvs) + body-forms-new)) + + (setq body-forms-new + (if letbind `((let ,letbind . ,(reverse body-forms-new))) + (reverse body-forms-new))) + + (cond + ;if no freevars - do nothing + ((null envector) + `(function (lambda ,vars . ,body-forms-new))) + ; 1 free variable - do not build vector + (t + `(internal-make-closure + ,vars ,envector . ,body-forms-new))))) + (defun cconv-closure-convert-rec (form emvrs fvrs envs lmenvs) ;; This function actually rewrites the tree. "Eliminates all free variables of all lambdas in given forms. @@ -303,15 +250,18 @@ Returns a form where all lambdas don't have any free variables." (dolist (binder binders) (let* ((value nil) (var (if (not (consp binder)) - binder + (prog1 binder (setq binder (list binder))) (setq value (cadr binder)) (car binder))) (new-val (cond ;; Check if var is a candidate for lambda lifting. - ((cconv--lookup-let cconv-lambda-candidates var binder form) - - (let* ((fv (delete-dups (cconv-freevars value '()))) + ((member (cons binder form) cconv-lambda-candidates) + (assert (and (eq (car value) 'function) + (eq (car (cadr value)) 'lambda))) + (assert (equal (cddr (cadr value)) + (caar cconv-freevars-alist))) + (let* ((fv (cdr (pop cconv-freevars-alist))) (funargs (cadr (cadr value))) (funcvars (append fv funargs)) (funcbodies (cddadr value)) ; function bodies @@ -338,7 +288,7 @@ Returns a form where all lambdas don't have any free variables." ,(reverse funcbodies-new)))))))) ;; Check if it needs to be turned into a "ref-cell". - ((cconv--lookup-let cconv-captured+mutated var binder form) + ((member (cons binder form) cconv-captured+mutated) ;; Declared variable is mutated and captured. (prog1 `(list ,(cconv-closure-convert-rec @@ -404,13 +354,12 @@ Returns a form where all lambdas don't have any free variables." )) ; end of dolist over binders (when (eq letsym 'let) - (let (var fvrs-1 emvrs-1 lmenvs-1) - ;; Here we update emvrs, fvrs and lmenvs lists - (setq fvrs (cconv--set-diff-map fvrs binders-new)) - (setq emvrs (cconv--set-diff-map emvrs binders-new)) - (setq emvrs (append emvrs emvrs-new)) - (setq lmenvs (cconv--set-diff-map lmenvs binders-new)) - (setq lmenvs (append lmenvs lmenvs-new))) + ;; Here we update emvrs, fvrs and lmenvs lists + (setq fvrs (cconv--set-diff-map fvrs binders-new)) + (setq emvrs (cconv--set-diff-map emvrs binders-new)) + (setq emvrs (append emvrs emvrs-new)) + (setq lmenvs (cconv--set-diff-map lmenvs binders-new)) + (setq lmenvs (append lmenvs lmenvs-new)) ;; Here we do the same letbinding as for let* above ;; to avoid situation when a free variable of a lambda lifted @@ -478,56 +427,8 @@ Returns a form where all lambdas don't have any free variables." (`(quote . ,_) form) (`(function (lambda ,vars . ,body-forms)) ; function form - (let* ((fvrs-new (cconv--set-diff fvrs vars)) ; Remove vars from fvrs. - (fv (delete-dups (cconv-freevars form '()))) - (leave fvrs-new) ; leave=non-nil if we should leave env unchanged. - (body-forms-new '()) - (letbind '()) - (mv nil) - (envector nil)) - (when fv - ;; Here we form our environment vector. - - (dolist (elm fv) - (push - (cconv-closure-convert-rec - ;; Remove `elm' from `emvrs' for this call because in case - ;; `elm' is a variable that's wrapped in a cons-cell, we - ;; want to put the cons-cell itself in the closure, rather - ;; than just a copy of its current content. - elm (remq elm emvrs) fvrs envs lmenvs) - envector)) ; Process vars for closure vector. - (setq envector (reverse envector)) - (setq envs fv) - (setq fvrs-new fv)) ; Update substitution list. - - (setq emvrs (cconv--set-diff emvrs vars)) - (setq lmenvs (cconv--map-diff-set lmenvs vars)) - - ;; The difference between envs and fvrs is explained - ;; in comment in the beginning of the function. - (dolist (elm cconv-captured+mutated) ; Find mutated arguments - (setq mv (car elm)) ; used in inner closures. - (when (and (memq mv vars) (eq form (caddr elm))) - (progn (push mv emvrs) - (push `(,mv (list ,mv)) letbind)))) - (dolist (elm body-forms) ; convert function body - (push (cconv-closure-convert-rec - elm emvrs fvrs-new envs lmenvs) - body-forms-new)) - - (setq body-forms-new - (if letbind `((let ,letbind . ,(reverse body-forms-new))) - (reverse body-forms-new))) - - (cond - ;if no freevars - do nothing - ((null envector) - `(function (lambda ,vars . ,body-forms-new))) - ; 1 free variable - do not build vector - (t - `(internal-make-closure - ,vars ,envector . ,body-forms-new))))) + (cconv-closure-convert-function + fvrs vars emvrs envs lmenvs body-forms form)) (`(internal-make-closure . ,_) (error "Internal byte-compiler error: cconv called twice")) @@ -548,21 +449,21 @@ Returns a form where all lambdas don't have any free variables." ;defun, defmacro (`(,(and sym (or `defun `defmacro)) ,func ,vars . ,body-forms) + + ;; The freevar data was pushed onto cconv-freevars-alist + ;; but we don't need it. + (assert (equal body-forms (caar cconv-freevars-alist))) + (assert (null (cdar cconv-freevars-alist))) + (setq cconv-freevars-alist (cdr cconv-freevars-alist)) + (let ((body-new '()) ; The whole body. (body-forms-new '()) ; Body w\o docstring and interactive. (letbind '())) ; Find mutable arguments. (dolist (elm vars) - (let ((lmutated cconv-captured+mutated) - (ismutated nil)) - (while (and lmutated (not ismutated)) - (when (and (eq (caar lmutated) elm) - (eq (caddar lmutated) form)) - (setq ismutated t)) - (setq lmutated (cdr lmutated))) - (when ismutated - (push elm letbind) - (push elm emvrs)))) + (when (member (cons (list elm) form) cconv-captured+mutated) + (push elm letbind) + (push elm emvrs))) ;Transform body-forms. (when (stringp (car body-forms)) ; Treat docstring well. (push (car body-forms) body-new) @@ -629,12 +530,13 @@ Returns a form where all lambdas don't have any free variables." (setq value (cconv-closure-convert-rec (cadr forms) emvrs fvrs envs lmenvs)) - (if (memq sym emvrs) - (push `(setcar ,sym-new ,value) prognlist) - (if (symbolp sym-new) - (push `(setq ,sym-new ,value) prognlist) - (debug) ;FIXME: When can this be right? - (push `(set ,sym-new ,value) prognlist))) + (cond + ((memq sym emvrs) (push `(setcar ,sym-new ,value) prognlist)) + ((symbolp sym-new) (push `(setq ,sym-new ,value) prognlist)) + ;; This should never happen, but for variables which are + ;; mutated+captured+unused, we may end up trying to `setq' + ;; on a closed-over variable, so just drop the setq. + (t (push value prognlist))) (setq forms (cddr forms))) (if (cdr prognlist) `(progn . ,(reverse prognlist)) @@ -697,54 +599,110 @@ Returns a form where all lambdas don't have any free variables." `(car ,form) ; replace form => (car form) form)))))) -(defun cconv-analyse-function (args body env parentform inclosure) - (dolist (arg args) - (cond - ((byte-compile-not-lexical-var-p arg) - (byte-compile-report-error - (format "Argument %S is not a lexical variable" arg))) - ((eq ?& (aref (symbol-name arg) 0)) nil) ;Ignore &rest, &optional, ... - (t (push (list arg inclosure parentform) env)))) ;Push vrs to vars. - (dolist (form body) ;Analyse body forms. - (cconv-analyse-form form env inclosure))) - -(defun cconv-analyse-form (form env inclosure) - "Find mutated variables and variables captured by closure. Analyse -lambdas if they are suitable for lambda lifting. +(unless (fboundp 'byte-compile-not-lexical-var-p) + ;; Only used to test the code in non-lexbind Emacs. + (defalias 'byte-compile-not-lexical-var-p 'boundp)) + +(defun cconv-analyse-use (vardata form) + ;; use = `(,binder ,read ,mutated ,captured ,called) + (pcase vardata + (`(,binder nil ,_ ,_ nil) + ;; FIXME: Don't warn about unused fun-args. + ;; FIXME: Don't warn about uninterned vars or _ vars. + ;; FIXME: This gives warnings in the wrong order and with wrong line + ;; number and without function name info. + (byte-compile-log-warning (format "Unused variable %S" (car binder)))) + ;; If it's unused, there's no point converting it into a cons-cell, even if + ;; it's captures and mutated. + (`(,binder ,_ t t ,_) + (push (cons binder form) cconv-captured+mutated)) + (`(,(and binder `(,_ (function (lambda . ,_)))) nil nil nil t) + ;; This is very rare in typical Elisp code. It's probably not really + ;; worth the trouble to try and use lambda-lifting in Elisp, but + ;; since we coded it up, we might as well use it. + (push (cons binder form) cconv-lambda-candidates)) + (`(,_ ,_ ,_ ,_ ,_) nil) + (dontcare))) + +(defun cconv-analyse-function (args body env parentform) + (let* ((newvars nil) + (freevars (list body)) + ;; We analyze the body within a new environment where all uses are + ;; nil, so we can distinguish uses within that function from uses + ;; outside of it. + (envcopy + (mapcar (lambda (vdata) (list (car vdata) nil nil nil nil)) env)) + (newenv envcopy)) + ;; Push it before recursing, so cconv-freevars-alist contains entries in + ;; the order they'll be used by closure-convert-rec. + (push freevars cconv-freevars-alist) + (dolist (arg args) + (cond + ((byte-compile-not-lexical-var-p arg) + (byte-compile-report-error + (format "Argument %S is not a lexical variable" arg))) + ((eq ?& (aref (symbol-name arg) 0)) nil) ;Ignore &rest, &optional, ... + (t (let ((varstruct (list arg nil nil nil nil))) + (push (cons (list arg) (cdr varstruct)) newvars) + (push varstruct newenv))))) + (dolist (form body) ;Analyse body forms. + (cconv-analyse-form form newenv)) + ;; Summarize resulting data about arguments. + (dolist (vardata newvars) + (cconv-analyse-use vardata parentform)) + ;; Transfer uses collected in `envcopy' (via `newenv') back to `env'; + ;; and compute free variables. + (while env + (assert (and envcopy (eq (caar env) (caar envcopy)))) + (let ((free nil) + (x (cdr (car env))) + (y (cdr (car envcopy)))) + (while x + (when (car y) (setcar x t) (setq free t)) + (setq x (cdr x) y (cdr y))) + (when free + (push (caar env) (cdr freevars)) + (setf (nth 3 (car env)) t)) + (setq env (cdr env) envcopy (cdr envcopy)))))) + +(defun cconv-analyse-form (form env) + "Find mutated variables and variables captured by closure. +Analyse lambdas if they are suitable for lambda lifting. -- FORM is a piece of Elisp code after macroexpansion. --- ENV is a list of variables visible in current lexical environment. - Each entry has the form (VAR INCLOSURE BINDER PARENTFORM) - for let-bound vars and (VAR INCLOSURE PARENTFORM) for function arguments. --- INCLOSURE is the nesting level within lambdas." +-- ENV is an alist mapping each enclosing lexical variable to its info. + I.e. each element has the form (VAR . (READ MUTATED CAPTURED CALLED)). +This function does not return anything but instead fills the +`cconv-captured+mutated' and `cconv-lambda-candidates' variables +and updates the data stored in ENV." (pcase form ; let special form (`(,(and (or `let* `let) letsym) ,binders . ,body-forms) (let ((orig-env env) + (newvars nil) (var nil) (value nil)) (dolist (binder binders) (if (not (consp binder)) (progn (setq var binder) ; treat the form (let (x) ...) well + (setq binder (list binder)) (setq value nil)) (setq var (car binder)) (setq value (cadr binder)) - (cconv-analyse-form value (if (eq letsym 'let*) env orig-env) - inclosure)) + (cconv-analyse-form value (if (eq letsym 'let*) env orig-env))) (unless (byte-compile-not-lexical-var-p var) - (let ((varstruct (list var inclosure binder form))) - (push varstruct env) ; Push a new one. + (let ((varstruct (list var nil nil nil nil))) + (push (cons binder (cdr varstruct)) newvars) + (push varstruct env)))) - (pcase value - (`(function (lambda . ,_)) - ;; If var is a function push it to lambda list. - (push varstruct cconv-lambda-candidates))))))) + (dolist (form body-forms) ; Analyse body forms. + (cconv-analyse-form form env)) - (dolist (form body-forms) ; Analyse body forms. - (cconv-analyse-form form env inclosure))) + (dolist (vardata newvars) + (cconv-analyse-use vardata form)))) ; defun special form (`(,(or `defun `defmacro) ,func ,vrs . ,body-forms) @@ -753,33 +711,28 @@ lambdas if they are suitable for lambda lifting. (format "Function %S will ignore its context %S" func (mapcar #'car env)) t :warning)) - (cconv-analyse-function vrs body-forms nil form 0)) + (cconv-analyse-function vrs body-forms nil form)) (`(function (lambda ,vrs . ,body-forms)) - (cconv-analyse-function vrs body-forms env form (1+ inclosure))) + (cconv-analyse-function vrs body-forms env form)) (`(setq . ,forms) ;; If a local variable (member of env) is modified by setq then ;; it is a mutated variable. (while forms (let ((v (assq (car forms) env))) ; v = non nil if visible - (when v - (push v cconv-mutated) - ;; Delete from candidate list for lambda lifting. - (setq cconv-lambda-candidates (delq v cconv-lambda-candidates)) - (unless (eq inclosure (cadr v)) ;Bound in a different closure level. - (push v cconv-captured)))) - (cconv-analyse-form (cadr forms) env inclosure) + (when v (setf (nth 2 v) t))) + (cconv-analyse-form (cadr forms) env) (setq forms (cddr forms)))) (`((lambda . ,_) . ,_) ; first element is lambda expression (dolist (exp `((function ,(car form)) . ,(cdr form))) - (cconv-analyse-form exp env inclosure))) + (cconv-analyse-form exp env))) (`(cond . ,cond-forms) ; cond special form (dolist (forms cond-forms) (dolist (form forms) - (cconv-analyse-form form env inclosure)))) + (cconv-analyse-form form env)))) (`(quote . ,_) nil) ; quote form (`(function . ,_) nil) ; same as quote @@ -788,63 +741,44 @@ lambdas if they are suitable for lambda lifting. ;; FIXME: The bytecode for condition-case forces us to wrap the ;; form and handlers in closures (for handlers, it's probably ;; unavoidable, but not for the protected form). - (setq inclosure (1+ inclosure)) - (cconv-analyse-form protected-form env inclosure) - (push (list var inclosure form) env) + (cconv-analyse-function () (list protected-form) env form) (dolist (handler handlers) - (dolist (form (cdr handler)) - (cconv-analyse-form form env inclosure)))) + (cconv-analyse-function (if var (list var)) (cdr handler) env form))) ;; FIXME: The bytecode for catch forces us to wrap the body. (`(,(or `catch `unwind-protect) ,form . ,body) - (cconv-analyse-form form env inclosure) - (setq inclosure (1+ inclosure)) - (dolist (form body) - (cconv-analyse-form form env inclosure))) + (cconv-analyse-form form env) + (cconv-analyse-function () body env form)) ;; FIXME: The bytecode for save-window-excursion and the lack of ;; bytecode for track-mouse forces us to wrap the body. (`(track-mouse . ,body) - (setq inclosure (1+ inclosure)) - (dolist (form body) - (cconv-analyse-form form env inclosure))) + (cconv-analyse-function () body env form)) (`(,(or `defconst `defvar) ,var ,value . ,_) (push var byte-compile-bound-variables) - (cconv-analyse-form value env inclosure)) + (cconv-analyse-form value env)) (`(,(or `funcall `apply) ,fun . ,args) ;; Here we ignore fun because funcall and apply are the only two ;; functions where we can pass a candidate for lambda lifting as ;; argument. So, if we see fun elsewhere, we'll delete it from ;; lambda candidate list. - (if (symbolp fun) - (let ((lv (assq fun cconv-lambda-candidates))) - (when lv - (unless (eq (cadr lv) inclosure) - (push lv cconv-captured) - ;; If this funcall and the definition of fun are in - ;; different closures - we delete fun from candidate - ;; list, because it is too complicated to manage free - ;; variables in this case. - (setq cconv-lambda-candidates - (delq lv cconv-lambda-candidates))))) - (cconv-analyse-form fun env inclosure)) + (let ((fdata (and (symbolp fun) (assq fun env)))) + (if fdata + (setf (nth 4 fdata) t) + (cconv-analyse-form fun env))) (dolist (form args) - (cconv-analyse-form form env inclosure))) + (cconv-analyse-form form env))) (`(,_ . ,body-forms) ; First element is a function or whatever. (dolist (form body-forms) - (cconv-analyse-form form env inclosure))) + (cconv-analyse-form form env))) ((pred symbolp) (let ((dv (assq form env))) ; dv = declared and visible (when dv - (unless (eq inclosure (cadr dv)) ; capturing condition - (push dv cconv-captured)) - ;; Delete lambda if it is found here, since it escapes. - (setq cconv-lambda-candidates - (delq dv cconv-lambda-candidates))))))) + (setf (nth 1 dv) t)))))) (provide 'cconv) ;;; cconv.el ends here diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el index 0b2ea81fb64..0bdab919434 100644 --- a/lisp/emacs-lisp/debug.el +++ b/lisp/emacs-lisp/debug.el @@ -269,6 +269,7 @@ That buffer should be current already." (setq buffer-undo-list t) (let ((standard-output (current-buffer)) (print-escape-newlines t) + (print-quoted t) ;Doesn't seem to work :-( (print-level 1000) ;8 ;; (print-length 50) ) diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 781195d034a..4377797cba8 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -1,4 +1,4 @@ -;;; macroexp.el --- Additional macro-expansion support +;;; macroexp.el --- Additional macro-expansion support -*- lexical-binding: t -*- ;; ;; Copyright (C) 2004-2011 Free Software Foundation, Inc. ;; @@ -108,7 +108,14 @@ Assumes the caller has bound `macroexpand-all-environment'." (macroexpand (macroexpand-all-forms form 1) macroexpand-all-environment) ;; Normal form; get its expansion, and then expand arguments. - (setq form (macroexpand form macroexpand-all-environment)) + (let ((new-form (macroexpand form macroexpand-all-environment))) + (when (and (not (eq form new-form)) ;It was a macro call. + (car-safe form) + (symbolp (car form)) + (get (car form) 'byte-obsolete-info) + (fboundp 'byte-compile-warn-obsolete)) + (byte-compile-warn-obsolete (car form))) + (setq form new-form)) (pcase form (`(cond . ,clauses) (maybe-cons 'cond (macroexpand-all-clauses clauses) form)) diff --git a/lisp/follow.el b/lisp/follow.el index 7e6d4e7ee35..7f4093dd442 100644 --- a/lisp/follow.el +++ b/lisp/follow.el @@ -871,8 +871,7 @@ Returns (end-pos end-of-buffer-p)" ;; XEmacs can calculate the end of the window by using ;; the 'guarantee options. GOOD! (let ((end (window-end win t))) - (if (= end (funcall (symbol-function 'point-max) - (window-buffer win))) + (if (= end (point-max (window-buffer win))) (list end t) (list (+ end 1) nil))) ;; Emacs: We have to calculate the end by ourselves. diff --git a/lisp/vc/diff-mode.el b/lisp/vc/diff-mode.el index 13d10f02b41..59e442a89c3 100644 --- a/lisp/vc/diff-mode.el +++ b/lisp/vc/diff-mode.el @@ -1,4 +1,4 @@ -;;; diff-mode.el --- a mode for viewing/editing context diffs +;;; diff-mode.el --- a mode for viewing/editing context diffs -*- lexical-binding: t -*- ;; Copyright (C) 1998-2011 Free Software Foundation, Inc. @@ -1278,7 +1278,7 @@ a diff with \\[diff-reverse-direction]. (add-hook 'after-change-functions 'diff-after-change-function nil t) (add-hook 'post-command-hook 'diff-post-command-hook nil t)) ;; Neat trick from Dave Love to add more bindings in read-only mode: - (lexical-let ((ro-bind (cons 'buffer-read-only diff-mode-shared-map))) + (let ((ro-bind (cons 'buffer-read-only diff-mode-shared-map))) (add-to-list 'minor-mode-overriding-map-alist ro-bind) ;; Turn off this little trick in case the buffer is put in view-mode. (add-hook 'view-mode-hook diff --git a/src/bytecode.c b/src/bytecode.c index 464bc3d12de..9693a5a9196 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -51,7 +51,7 @@ by Hallvard: * * define BYTE_CODE_METER to enable generation of a byte-op usage histogram. */ -/* #define BYTE_CODE_SAFE */ +#define BYTE_CODE_SAFE 1 /* #define BYTE_CODE_METER */ -- cgit v1.3 From e2abe5a13dffb08d6371b6a611bc39c3a9ac2bc6 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Sat, 5 Mar 2011 23:48:17 -0500 Subject: Fix pcase memoizing; change lexbound byte-code marker. * src/bytecode.c (exec_byte_code): Remove old lexical binding slot handling and replace it with the a integer args-desc handling. * eval.c (funcall_lambda): Adjust arglist test accordingly. * lisp/emacs-lisp/bytecomp.el (byte-compile-arglist-signature): Handle integer arglist descriptor. (byte-compile-make-args-desc): Make integer arglist descriptor. (byte-compile-lambda): Use integer arglist descriptor to mark lexical byte-coded functions instead of an extra slot. * lisp/help-fns.el (help-add-fundoc-usage): Don't add a dummy doc. (help-split-fundoc): Return a nil doc if there was no actual doc. (help-function-arglist): Generate an arglist from an integer arg-desc. * lisp/emacs-lisp/pcase.el (pcase--memoize): Rename from pcase-memoize; Make only the key weak. (pcase): Change the key used in the memoization table, so it does not always get GC'd away. * lisp/emacs-lisp/macroexp.el (macroexpand-all-1): Slight change to the pcase pattern to generate slightly better code. --- lisp/ChangeLog | 17 +++++++++ lisp/emacs-lisp/byte-opt.el | 3 +- lisp/emacs-lisp/bytecomp.el | 87 +++++++++++++++++++++++++++++++-------------- lisp/emacs-lisp/cconv.el | 11 +++--- lisp/emacs-lisp/macroexp.el | 9 ++--- lisp/emacs-lisp/pcase.el | 23 +++++++++--- lisp/help-fns.el | 26 ++++++++++++-- src/ChangeLog | 6 ++++ src/alloc.c | 13 +++++-- src/bytecode.c | 71 +++++++++++++++++++++--------------- 10 files changed, 188 insertions(+), 78 deletions(-) (limited to 'src/bytecode.c') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 10f57c2b96a..70604238117 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,20 @@ +2011-03-06 Stefan Monnier + + * emacs-lisp/bytecomp.el (byte-compile-arglist-signature): + Handle integer arglist descriptor. + (byte-compile-make-args-desc): Make integer arglist descriptor. + (byte-compile-lambda): Use integer arglist descriptor to mark lexical + byte-coded functions instead of an extra slot. + * help-fns.el (help-add-fundoc-usage): Don't add a dummy doc. + (help-split-fundoc): Return a nil doc if there was no actual doc. + (help-function-arglist): Generate an arglist from an integer arg-desc. + * emacs-lisp/pcase.el (pcase--memoize): Rename from pcase-memoize; + Make only the key weak. + (pcase): Change the key used in the memoization table, so it does not + always get GC'd away. + * emacs-lisp/macroexp.el (macroexpand-all-1): Slight change to the + pcase pattern to generate slightly better code. + 2011-03-01 Stefan Monnier * emacs-lisp/cconv.el (cconv-liftwhen): Increase threshold. diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index d86cb729081..6d6eb68535e 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -2009,8 +2009,7 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (setq lap0 (car rest) lap1 (nth 1 rest)) (if (memq (car lap0) byte-constref-ops) - (if (or (eq (car lap0) 'byte-constant) - (eq (car lap0) 'byte-constant2)) + (if (memq (car lap0) '(byte-constant byte-constant2)) (unless (memq (cdr lap0) byte-compile-constants) (setq byte-compile-constants (cons (cdr lap0) byte-compile-constants))) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 3575b10e1f1..297655a235a 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -33,6 +33,9 @@ ;;; Code: +;; FIXME: Use lexical-binding and get rid of the atrocious "bytecomp-" +;; variable prefix. + ;; ======================================================================== ;; Entry points: ;; byte-recompile-directory, byte-compile-file, @@ -1180,22 +1183,28 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." (t fn))))))) (defun byte-compile-arglist-signature (arglist) - (let ((args 0) - opts - restp) - (while arglist - (cond ((eq (car arglist) '&optional) - (or opts (setq opts 0))) - ((eq (car arglist) '&rest) - (if (cdr arglist) - (setq restp t - arglist nil))) - (t - (if opts - (setq opts (1+ opts)) + (if (integerp arglist) + ;; New style byte-code arglist. + (cons (logand arglist 127) ;Mandatory. + (if (zerop (logand arglist 128)) ;No &rest. + (lsh arglist -8))) ;Nonrest. + ;; Old style byte-code, or interpreted function. + (let ((args 0) + opts + restp) + (while arglist + (cond ((eq (car arglist) '&optional) + (or opts (setq opts 0))) + ((eq (car arglist) '&rest) + (if (cdr arglist) + (setq restp t + arglist nil))) + (t + (if opts + (setq opts (1+ opts)) (setq args (1+ args))))) - (setq arglist (cdr arglist))) - (cons args (if restp nil (if opts (+ args opts) args))))) + (setq arglist (cdr arglist))) + (cons args (if restp nil (if opts (+ args opts) args)))))) (defun byte-compile-arglist-signatures-congruent-p (old new) @@ -2645,6 +2654,26 @@ If FORM is a lambda or a macro, byte-compile it as a function." ;; Return the new lexical environment lexenv)))) +(defun byte-compile-make-args-desc (arglist) + (let ((mandatory 0) + nonrest (rest 0)) + (while (and arglist (not (memq (car arglist) '(&optional &rest)))) + (setq mandatory (1+ mandatory)) + (setq arglist (cdr arglist))) + (setq nonrest mandatory) + (when (eq (car arglist) '&optional) + (setq arglist (cdr arglist)) + (while (and arglist (not (eq (car arglist) '&rest))) + (setq nonrest (1+ nonrest)) + (setq arglist (cdr arglist)))) + (when arglist + (setq rest 1)) + (if (> mandatory 127) + (byte-compile-report-error "Too many (>127) mandatory arguments") + (logior mandatory + (lsh nonrest 8) + (lsh rest 7))))) + ;; Byte-compile a lambda-expression and return a valid function. ;; The value is usually a compiled function but may be the original ;; lambda-expression. @@ -2716,18 +2745,22 @@ If FORM is a lambda or a macro, byte-compile it as a function." ;; Build the actual byte-coded function. (if (eq 'byte-code (car-safe compiled)) (apply 'make-byte-code - (append (list bytecomp-arglist) - ;; byte-string, constants-vector, stack depth - (cdr compiled) - ;; optionally, the doc string. - (if (or bytecomp-doc bytecomp-int - lexical-binding) - (list bytecomp-doc)) - ;; optionally, the interactive spec. - (if (or bytecomp-int lexical-binding) - (list (nth 1 bytecomp-int))) - (if lexical-binding - '(t)))) + (if lexical-binding + (byte-compile-make-args-desc bytecomp-arglist) + bytecomp-arglist) + (append + ;; byte-string, constants-vector, stack depth + (cdr compiled) + ;; optionally, the doc string. + (cond (lexical-binding + (require 'help-fns) + (list (help-add-fundoc-usage + bytecomp-doc bytecomp-arglist))) + ((or bytecomp-doc bytecomp-int) + (list bytecomp-doc))) + ;; optionally, the interactive spec. + (if bytecomp-int + (list (nth 1 bytecomp-int))))) (setq compiled (nconc (if bytecomp-int (list bytecomp-int)) (cond ((eq (car-safe compiled) 'progn) (cdr compiled)) diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index 7855193fa3f..5501c13ee4f 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -66,22 +66,21 @@ ;;; Code: ;; TODO: +;; - byte-optimize-form should be applied before cconv. +;; - maybe unify byte-optimize and compiler-macros. ;; - canonize code in macro-expand so we don't have to handle (let (var) body) ;; and other oddities. -;; - Change new byte-code representation, so it directly gives the -;; number of mandatory and optional arguments as well as whether or -;; not there's a &rest arg. ;; - clean up cconv-closure-convert-rec, especially the `let' binding part. ;; - new byte codes for unwind-protect, catch, and condition-case so that ;; closures aren't needed at all. ;; - a reference to a var that is known statically to always hold a constant ;; should be turned into a byte-constant rather than a byte-stack-ref. -;; Hmm... right, that's called constant propagation and could be done here -;; But when that constant is a function, we have to be careful to make sure +;; Hmm... right, that's called constant propagation and could be done here, +;; but when that constant is a function, we have to be careful to make sure ;; the bytecomp only compiles it once. ;; - Since we know here when a variable is not mutated, we could pass that ;; info to the byte-compiler, e.g. by using a new `immutable-let'. -;; - add tail-calls to bytecode.c and the bytecompiler. +;; - add tail-calls to bytecode.c and the byte compiler. ;; (defmacro dlet (binders &rest body) ;; ;; Works in both lexical and non-lexical mode. diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 4377797cba8..168a430577d 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -176,10 +176,11 @@ Assumes the caller has bound `macroexpand-all-environment'." (macroexpand-all-forms args))))) ;; Macro expand compiler macros. ;; FIXME: Don't depend on CL. - (`(,(and (pred symbolp) fun - (guard (and (eq (get fun 'byte-compile) - 'cl-byte-compile-compiler-macro) - (functionp 'compiler-macroexpand)))) + (`(,(pred (lambda (fun) + (and (symbolp fun) + (eq (get fun 'byte-compile) + 'cl-byte-compile-compiler-macro) + (functionp 'compiler-macroexpand)))) . ,_) (let ((newform (compiler-macroexpand form))) (if (eq form newform) diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 89bbff980c4..2300ebf721a 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -42,7 +42,7 @@ ;; is in a loop, the repeated macro-expansion becomes terribly costly, so we ;; memoize previous macro expansions to try and avoid recomputing them ;; over and over again. -(defconst pcase-memoize (make-hash-table :weakness t :test 'equal)) +(defconst pcase--memoize (make-hash-table :weakness 'key :test 'eq)) (defconst pcase--dontcare-upats '(t _ dontcare)) @@ -78,10 +78,21 @@ E.g. you can match pairs where the cdr is larger than the car with a pattern like `(,a . ,(pred (< a))) or, with more checks: `(,(and a (pred numberp)) . ,(and (pred numberp) (pred (< a))))" (declare (indent 1) (debug case)) ;FIXME: edebug `guard' and vars. - (or (gethash (cons exp cases) pcase-memoize) - (puthash (cons exp cases) - (pcase--expand exp cases) - pcase-memoize))) + ;; We want to use a weak hash table as a cache, but the key will unavoidably + ;; be based on `exp' and `cases', yet `cases' is a fresh new list each time + ;; we're called so it'll be immediately GC'd. So we use (car cases) as key + ;; which does come straight from the source code and should hence not be GC'd + ;; so easily. + (let ((data (gethash (car cases) pcase--memoize))) + ;; data = (EXP CASES . EXPANSION) + (if (and (equal exp (car data)) (equal cases (cadr data))) + ;; We have the right expansion. + (cddr data) + (when data + (message "pcase-memoize: equal first branch, yet different")) + (let ((expansion (pcase--expand exp cases))) + (puthash (car cases) (cons exp (cons cases expansion)) pcase--memoize) + expansion)))) ;;;###autoload (defmacro pcase-let* (bindings &rest body) @@ -135,6 +146,8 @@ of the form (UPAT EXP)." (and (symbolp upat) (not (memq upat pcase--dontcare-upats)))) (defun pcase--expand (exp cases) + ;; (message "pid=%S (pcase--expand %S ...hash=%S)" + ;; (emacs-pid) exp (sxhash cases)) (let* ((defs (if (symbolp exp) '() (let ((sym (make-symbol "x"))) (prog1 `((,sym ,exp)) (setq exp sym))))) diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 87fb6a02bd3..58df45bc33c 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -76,15 +76,18 @@ DEF is the function whose usage we're looking for in DOCSTRING." ;; Replace `fn' with the actual function name. (if (consp def) "anonymous" def) (match-string 1 docstring)) - (substring docstring 0 (match-beginning 0))))) + (unless (zerop (match-beginning 0)) + (substring docstring 0 (match-beginning 0)))))) +;; FIXME: Move to subr.el? (defun help-add-fundoc-usage (docstring arglist) "Add the usage info to DOCSTRING. If DOCSTRING already has a usage info, then just return it unchanged. The usage info is built from ARGLIST. DOCSTRING can be nil. ARGLIST can also be t or a string of the form \"(FUN ARG1 ARG2 ...)\"." - (unless (stringp docstring) (setq docstring "Not documented")) - (if (or (string-match "\n\n(fn\\(\\( .*\\)?)\\)\\'" docstring) (eq arglist t)) + (unless (stringp docstring) (setq docstring "")) + (if (or (string-match "\n\n(fn\\(\\( .*\\)?)\\)\\'" docstring) + (eq arglist t)) docstring (concat docstring (if (string-match "\n?\n\\'" docstring) @@ -95,6 +98,7 @@ ARGLIST can also be t or a string of the form \"(FUN ARG1 ARG2 ...)\"." (concat "(fn" (match-string 1 arglist) ")") (format "%S" (help-make-usage 'fn arglist)))))) +;; FIXME: Move to subr.el? (defun help-function-arglist (def) ;; Handle symbols aliased to other symbols. (if (and (symbolp def) (fboundp def)) (setq def (indirect-function def))) @@ -103,12 +107,28 @@ ARGLIST can also be t or a string of the form \"(FUN ARG1 ARG2 ...)\"." ;; and do the same for interpreted closures (if (eq (car-safe def) 'closure) (setq def (cddr def))) (cond + ((and (byte-code-function-p def) (integerp (aref def 0))) + (let* ((args-desc (aref def 0)) + (max (lsh args-desc -8)) + (min (logand args-desc 127)) + (rest (logand args-desc 128)) + (arglist ())) + (dotimes (i min) + (push (intern (concat "arg" (number-to-string (1+ i)))) arglist)) + (when (> max min) + (push '&optional arglist) + (dotimes (i (- max min)) + (push (intern (concat "arg" (number-to-string (+ 1 i min)))) + arglist))) + (unless (zerop rest) (push '&rest arglist) (push 'rest arglist)) + (nreverse arglist))) ((byte-code-function-p def) (aref def 0)) ((eq (car-safe def) 'lambda) (nth 1 def)) ((and (eq (car-safe def) 'autoload) (not (eq (nth 4 def) 'keymap))) "[Arg list not available until function definition is loaded.]") (t t))) +;; FIXME: Move to subr.el? (defun help-make-usage (function arglist) (cons (if (symbolp function) function 'anonymous) (mapcar (lambda (arg) diff --git a/src/ChangeLog b/src/ChangeLog index c638e1fa4b5..e8b3c57fbd0 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,9 @@ +2011-03-06 Stefan Monnier + + * bytecode.c (exec_byte_code): Remove old lexical binding slot handling + and replace it with the a integer args-desc handling. + * eval.c (funcall_lambda): Adjust arglist test accordingly. + 2011-03-01 Stefan Monnier * callint.c (quotify_arg): Simplify the logic. diff --git a/src/alloc.c b/src/alloc.c index 0b7db7ec627..c7fd8747f74 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -2945,10 +2945,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 int nargs, Lisp_Object *args) { diff --git a/src/bytecode.c b/src/bytecode.c index 9693a5a9196..dbab02886e2 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -502,37 +502,50 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, stacke = stack.bottom - 1 + XFASTINT (maxdepth); #endif - if (! NILP (args_template)) - /* We should push some arguments on the stack. */ + if (INTEGERP (args_template)) { - Lisp_Object at; - int pushed = 0, optional = 0; - - for (at = args_template; CONSP (at); at = XCDR (at)) - if (EQ (XCAR (at), Qand_optional)) - optional = 1; - else if (EQ (XCAR (at), Qand_rest)) - { - PUSH (pushed < nargs - ? Flist (nargs - pushed, args) - : Qnil); - pushed = nargs; - at = Qnil; - break; - } - else if (pushed < nargs) - { - PUSH (*args++); - pushed++; - } - else if (optional) - PUSH (Qnil); - else - break; - - if (pushed != nargs || !NILP (at)) + 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 (args_template, Fcons (make_number (nargs), Qnil))); + 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) -- cgit v1.3 From ca1055060d5793e368c1a165c412944d6800c3a6 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 16 Mar 2011 16:08:39 -0400 Subject: Remove bytecomp- prefix, plus misc changes. * lisp/emacs-lisp/byte-opt.el (byte-compile-inline-expand): Make it work to inline lexbind interpreted functions into lexbind code. (bytedecomp-bytes): Not a dynamic var any more. (disassemble-offset): Get the bytes via an argument instead. (byte-decompile-bytecode-1): Use push. * lisp/emacs-lisp/bytecomp.el: Remove the bytecomp- prefix now that we use lexical-binding. (byte-compile-outbuffer): Rename from bytecomp-outbuffer. * lisp/emacs-lisp/cl-macs.el (load-time-value): * lisp/emacs-lisp/cl.el (cl-compiling-file): Adjust to new name. * lisp/emacs-lisp/pcase.el (pcase-mutually-exclusive-predicates): Add byte-code-function-p. (pcase--u1): Remove left-over code from early development. Fix case of variable shadowing in guards and predicates. (pcase--u1): Add a new `let' pattern. * src/image.c (parse_image_spec): Use Ffunctionp. * src/lisp.h: Declare Ffunctionp. --- lisp/ChangeLog | 20 ++ lisp/emacs-lisp/byte-opt.el | 164 +++++++------ lisp/emacs-lisp/bytecomp.el | 527 +++++++++++++++++++---------------------- lisp/emacs-lisp/cconv.el | 31 ++- lisp/emacs-lisp/cl-loaddefs.el | 2 +- lisp/emacs-lisp/cl-macs.el | 2 +- lisp/emacs-lisp/cl.el | 6 +- lisp/emacs-lisp/pcase.el | 63 +++-- lisp/startup.el | 1 + lisp/subr.el | 3 + src/ChangeLog | 5 + src/bytecode.c | 12 +- src/image.c | 5 +- src/lisp.h | 1 + 14 files changed, 453 insertions(+), 389 deletions(-) (limited to 'src/bytecode.c') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 34951ff37bb..8d5e2418341 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,23 @@ +2011-03-16 Stefan Monnier + + * emacs-lisp/pcase.el (pcase-mutually-exclusive-predicates): + Add byte-code-function-p. + (pcase--u1): Remove left-over code from early development. + Fix case of variable shadowing in guards and predicates. + (pcase--u1): Add a new `let' pattern. + + * emacs-lisp/bytecomp.el: Remove the bytecomp- prefix now that we use + lexical-binding. + (byte-compile-outbuffer): Rename from bytecomp-outbuffer. + * emacs-lisp/cl-macs.el (load-time-value): + * emacs-lisp/cl.el (cl-compiling-file): Adjust to new name. + + * emacs-lisp/byte-opt.el (byte-compile-inline-expand): Make it work to + inline lexbind interpreted functions into lexbind code. + (bytedecomp-bytes): Not a dynamic var any more. + (disassemble-offset): Get the bytes via an argument instead. + (byte-decompile-bytecode-1): Use push. + 2011-03-15 Stefan Monnier * makefile.w32-in (COMPILE_FIRST): Fix up last change. diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index b07d61ae0d1..6a04dfb2507 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -265,45 +265,72 @@ (defun byte-compile-inline-expand (form) (let* ((name (car form)) - (fn (or (cdr (assq name byte-compile-function-environment)) - (and (fboundp name) (symbol-function name))))) - (if (null fn) - (progn - (byte-compile-warn "attempt to inline `%s' before it was defined" - name) - form) - ;; else - (when (and (consp fn) (eq (car fn) 'autoload)) - (load (nth 1 fn)) - (setq fn (or (and (fboundp name) (symbol-function name)) - (cdr (assq name byte-compile-function-environment))))) - (if (and (consp fn) (eq (car fn) 'autoload)) - (error "File `%s' didn't define `%s'" (nth 1 fn) name)) - (cond - ((and (symbolp fn) (not (eq fn t))) ;A function alias. - (byte-compile-inline-expand (cons fn (cdr form)))) - ((and (byte-code-function-p fn) - ;; FIXME: This works to inline old-style-byte-codes into - ;; old-style-byte-codes, but not mixed cases (not sure - ;; about new-style into new-style). - (not lexical-binding) - (not (integerp (aref fn 0)))) ;New lexical byte-code. - ;; (message "Inlining %S byte-code" name) - (fetch-bytecode fn) - (let ((string (aref fn 1))) - ;; Isn't it an error for `string' not to be unibyte?? --stef - (if (fboundp 'string-as-unibyte) - (setq string (string-as-unibyte string))) - ;; `byte-compile-splice-in-already-compiled-code' - ;; takes care of inlining the body. - (cons `(lambda ,(aref fn 0) - (byte-code ,string ,(aref fn 2) ,(aref fn 3))) - (cdr form)))) - ((eq (car-safe fn) 'lambda) - (macroexpand-all (cons fn (cdr form)) - byte-compile-macro-environment)) - (t ;; Give up on inlining. - form))))) + (localfn (cdr (assq name byte-compile-function-environment))) + (fn (or localfn (and (fboundp name) (symbol-function name))))) + (when (and (consp fn) (eq (car fn) 'autoload)) + (load (nth 1 fn)) + (setq fn (or (and (fboundp name) (symbol-function name)) + (cdr (assq name byte-compile-function-environment))))) + (pcase fn + (`nil + (byte-compile-warn "attempt to inline `%s' before it was defined" + name) + form) + (`(autoload . ,_) + (error "File `%s' didn't define `%s'" (nth 1 fn) name)) + ((and (pred symbolp) (guard (not (eq fn t)))) ;A function alias. + (byte-compile-inline-expand (cons fn (cdr form)))) + ((and (pred byte-code-function-p) + ;; FIXME: This only works to inline old-style-byte-codes into + ;; old-style-byte-codes. + (guard (not (or lexical-binding + (integerp (aref fn 0)))))) + ;; (message "Inlining %S byte-code" name) + (fetch-bytecode fn) + (let ((string (aref fn 1))) + (assert (not (multibyte-string-p string))) + ;; `byte-compile-splice-in-already-compiled-code' + ;; takes care of inlining the body. + (cons `(lambda ,(aref fn 0) + (byte-code ,string ,(aref fn 2) ,(aref fn 3))) + (cdr form)))) + ((and `(lambda . ,_) + ;; With lexical-binding we have several problems: + ;; - if `fn' comes from byte-compile-function-environment, we + ;; need to preprocess `fn', so we handle it below. + ;; - else, it means that `fn' is dyn-bound (otherwise it would + ;; start with `closure') so copying the code here would cause + ;; it to be mis-interpreted. + (guard (not lexical-binding))) + (macroexpand-all (cons fn (cdr form)) + byte-compile-macro-environment)) + ((and (or (and `(lambda ,args . ,body) + (let env nil) + (guard (eq fn localfn))) + `(closure ,env ,args . ,body)) + (guard lexical-binding)) + (let ((renv ())) + (dolist (binding env) + (cond + ((consp binding) + ;; We check shadowing by the args, so that the `let' can be + ;; moved within the lambda, which can then be unfolded. + ;; FIXME: Some of those bindings might be unused in `body'. + (unless (memq (car binding) args) ;Shadowed. + (push `(,(car binding) ',(cdr binding)) renv))) + ((eq binding t)) + (t (push `(defvar ,binding) body)))) + ;; (message "Inlining closure %S" (car form)) + (let ((newfn (byte-compile-preprocess + `(lambda ,args (let ,(nreverse renv) ,@body))))) + (if (eq (car-safe newfn) 'function) + (byte-compile-unfold-lambda `(,(cadr newfn) ,@(cdr form))) + (byte-compile-log-warning + (format "Inlining closure %S failed" name)) + form)))) + + (t ;; Give up on inlining. + form)))) ;; ((lambda ...) ...) (defun byte-compile-unfold-lambda (form &optional name) @@ -1095,7 +1122,7 @@ (let ((fn (nth 1 form))) (if (memq (car-safe fn) '(quote function)) (cons (nth 1 fn) (cdr (cdr form))) - form))) + form))) (defun byte-optimize-apply (form) ;; If the last arg is a literal constant, turn this into a funcall. @@ -1318,43 +1345,42 @@ ;; Used and set dynamically in byte-decompile-bytecode-1. (defvar bytedecomp-op) (defvar bytedecomp-ptr) -(defvar bytedecomp-bytes) ;; This function extracts the bitfields from variable-length opcodes. ;; Originally defined in disass.el (which no longer uses it.) -(defun disassemble-offset () +(defun disassemble-offset (bytes) "Don't call this!" - ;; fetch and return the offset for the current opcode. - ;; return nil if this opcode has no offset + ;; Fetch and return the offset for the current opcode. + ;; Return nil if this opcode has no offset. (cond ((< bytedecomp-op byte-nth) (let ((tem (logand bytedecomp-op 7))) (setq bytedecomp-op (logand bytedecomp-op 248)) (cond ((eq tem 6) ;; Offset in next byte. (setq bytedecomp-ptr (1+ bytedecomp-ptr)) - (aref bytedecomp-bytes bytedecomp-ptr)) + (aref bytes bytedecomp-ptr)) ((eq tem 7) ;; Offset in next 2 bytes. (setq bytedecomp-ptr (1+ bytedecomp-ptr)) - (+ (aref bytedecomp-bytes bytedecomp-ptr) + (+ (aref bytes bytedecomp-ptr) (progn (setq bytedecomp-ptr (1+ bytedecomp-ptr)) - (lsh (aref bytedecomp-bytes bytedecomp-ptr) 8)))) - (t tem)))) ;offset was in opcode + (lsh (aref bytes bytedecomp-ptr) 8)))) + (t tem)))) ;Offset was in opcode. ((>= bytedecomp-op byte-constant) - (prog1 (- bytedecomp-op byte-constant) ;offset in opcode + (prog1 (- bytedecomp-op byte-constant) ;Offset in opcode. (setq bytedecomp-op byte-constant))) ((or (and (>= bytedecomp-op byte-constant2) (<= bytedecomp-op byte-goto-if-not-nil-else-pop)) (= bytedecomp-op byte-stack-set2)) ;; Offset in next 2 bytes. (setq bytedecomp-ptr (1+ bytedecomp-ptr)) - (+ (aref bytedecomp-bytes bytedecomp-ptr) + (+ (aref bytes bytedecomp-ptr) (progn (setq bytedecomp-ptr (1+ bytedecomp-ptr)) - (lsh (aref bytedecomp-bytes bytedecomp-ptr) 8)))) + (lsh (aref bytes bytedecomp-ptr) 8)))) ((and (>= bytedecomp-op byte-listN) (<= bytedecomp-op byte-discardN)) - (setq bytedecomp-ptr (1+ bytedecomp-ptr)) ;offset in next byte - (aref bytedecomp-bytes bytedecomp-ptr)))) + (setq bytedecomp-ptr (1+ bytedecomp-ptr)) ;Offset in next byte. + (aref bytes bytedecomp-ptr)))) (defvar byte-compile-tag-number) @@ -1381,24 +1407,24 @@ (defun byte-decompile-bytecode-1 (bytes constvec &optional make-spliceable) (let ((bytedecomp-bytes bytes) (length (length bytes)) - (bytedecomp-ptr 0) optr tags bytedecomp-op offset + (bytedecomp-ptr 0) optr tags bytedecomp-op offset lap tmp endtag) (while (not (= bytedecomp-ptr length)) (or make-spliceable - (setq lap (cons bytedecomp-ptr lap))) + (push bytedecomp-ptr lap)) (setq bytedecomp-op (aref bytedecomp-bytes bytedecomp-ptr) optr bytedecomp-ptr - offset (disassemble-offset)) ; this does dynamic-scope magic + ;; This uses dynamic-scope magic. + offset (disassemble-offset bytedecomp-bytes)) (setq bytedecomp-op (aref byte-code-vector bytedecomp-op)) (cond ((memq bytedecomp-op byte-goto-ops) - ;; it's a pc + ;; It's a pc. (setq offset (cdr (or (assq offset tags) - (car (setq tags - (cons (cons offset - (byte-compile-make-tag)) - tags))))))) + (let ((new (cons offset (byte-compile-make-tag)))) + (push new tags) + new))))) ((cond ((eq bytedecomp-op 'byte-constant2) (setq bytedecomp-op 'byte-constant) t) ((memq bytedecomp-op byte-constref-ops))) @@ -1408,9 +1434,9 @@ offset (if (eq bytedecomp-op 'byte-constant) (byte-compile-get-constant tmp) (or (assq tmp byte-compile-variables) - (car (setq byte-compile-variables - (cons (list tmp) - byte-compile-variables))))))) + (let ((new (list tmp))) + (push new byte-compile-variables) + new))))) ((and make-spliceable (eq bytedecomp-op 'byte-return)) (if (= bytedecomp-ptr (1- length)) @@ -1427,26 +1453,26 @@ (setq bytedecomp-op 'byte-discardN-preserve-tos) (setq offset (- offset #x80)))) ;; lap = ( [ (pc . (op . arg)) ]* ) - (setq lap (cons (cons optr (cons bytedecomp-op (or offset 0))) - lap)) + (push (cons optr (cons bytedecomp-op (or offset 0))) + lap) (setq bytedecomp-ptr (1+ bytedecomp-ptr))) - ;; take off the dummy nil op that we replaced a trailing "return" with. (let ((rest lap)) (while rest (cond ((numberp (car rest))) ((setq tmp (assq (car (car rest)) tags)) - ;; this addr is jumped to + ;; This addr is jumped to. (setcdr rest (cons (cons nil (cdr tmp)) (cdr rest))) (setq tags (delq tmp tags)) (setq rest (cdr rest)))) (setq rest (cdr rest)))) (if tags (error "optimizer error: missed tags %s" tags)) + ;; Take off the dummy nil op that we replaced a trailing "return" with. (if (null (car (cdr (car lap)))) (setq lap (cdr lap))) (if endtag (setq lap (cons (cons nil endtag) lap))) - ;; remove addrs, lap = ( [ (op . arg) | (TAG tagno) ]* ) + ;; Remove addrs, lap = ( [ (op . arg) | (TAG tagno) ]* ) (mapcar (function (lambda (elt) (if (numberp elt) elt diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 69733ed2e8e..c9a85edfca4 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -33,8 +33,6 @@ ;;; Code: -;; FIXME: get rid of the atrocious "bytecomp-" variable prefix. - ;; ======================================================================== ;; Entry points: ;; byte-recompile-directory, byte-compile-file, @@ -1563,41 +1561,33 @@ Files in subdirectories of DIRECTORY are processed also." (interactive "DByte force recompile (directory): ") (byte-recompile-directory directory nil t)) -;; The `bytecomp-' prefix is applied to all local variables with -;; otherwise common names in this and similar functions for the sake -;; of the boundp test in byte-compile-variable-ref. -;; http://lists.gnu.org/archive/html/emacs-devel/2008-01/msg00237.html -;; http://lists.gnu.org/archive/html/bug-gnu-emacs/2008-02/msg00134.html -;; Note that similar considerations apply to command-line-1 in startup.el. ;;;###autoload -(defun byte-recompile-directory (bytecomp-directory &optional bytecomp-arg - bytecomp-force) - "Recompile every `.el' file in BYTECOMP-DIRECTORY that needs recompilation. +(defun byte-recompile-directory (directory &optional arg force) + "Recompile every `.el' file in DIRECTORY that needs recompilation. This happens when a `.elc' file exists but is older than the `.el' file. -Files in subdirectories of BYTECOMP-DIRECTORY are processed also. +Files in subdirectories of DIRECTORY are processed also. If the `.elc' file does not exist, normally this function *does not* compile the corresponding `.el' file. However, if the prefix argument -BYTECOMP-ARG is 0, that means do compile all those files. A nonzero -BYTECOMP-ARG means ask the user, for each such `.el' file, whether to -compile it. A nonzero BYTECOMP-ARG also means ask about each subdirectory +ARG is 0, that means do compile all those files. A nonzero +ARG means ask the user, for each such `.el' file, whether to +compile it. A nonzero ARG also means ask about each subdirectory before scanning it. -If the third argument BYTECOMP-FORCE is non-nil, recompile every `.el' file +If the third argument FORCE is non-nil, recompile every `.el' file that already has a `.elc' file." (interactive "DByte recompile directory: \nP") - (if bytecomp-arg - (setq bytecomp-arg (prefix-numeric-value bytecomp-arg))) + (if arg (setq arg (prefix-numeric-value arg))) (if noninteractive nil (save-some-buffers) (force-mode-line-update)) (with-current-buffer (get-buffer-create byte-compile-log-buffer) - (setq default-directory (expand-file-name bytecomp-directory)) + (setq default-directory (expand-file-name directory)) ;; compilation-mode copies value of default-directory. (unless (eq major-mode 'compilation-mode) (compilation-mode)) - (let ((bytecomp-directories (list default-directory)) + (let ((directories (list default-directory)) (default-directory default-directory) (skip-count 0) (fail-count 0) @@ -1605,47 +1595,36 @@ that already has a `.elc' file." (dir-count 0) last-dir) (displaying-byte-compile-warnings - (while bytecomp-directories - (setq bytecomp-directory (car bytecomp-directories)) - (message "Checking %s..." bytecomp-directory) - (let ((bytecomp-files (directory-files bytecomp-directory)) - bytecomp-source) - (dolist (bytecomp-file bytecomp-files) - (setq bytecomp-source - (expand-file-name bytecomp-file bytecomp-directory)) - (if (and (not (member bytecomp-file '("RCS" "CVS"))) - (not (eq ?\. (aref bytecomp-file 0))) - (file-directory-p bytecomp-source) - (not (file-symlink-p bytecomp-source))) - ;; This file is a subdirectory. Handle them differently. - (when (or (null bytecomp-arg) - (eq 0 bytecomp-arg) - (y-or-n-p (concat "Check " bytecomp-source "? "))) - (setq bytecomp-directories - (nconc bytecomp-directories (list bytecomp-source)))) - ;; It is an ordinary file. Decide whether to compile it. - (if (and (string-match emacs-lisp-file-regexp bytecomp-source) - (file-readable-p bytecomp-source) - (not (auto-save-file-name-p bytecomp-source)) - (not (string-equal dir-locals-file - (file-name-nondirectory - bytecomp-source)))) - (progn (let ((bytecomp-res (byte-recompile-file - bytecomp-source - bytecomp-force bytecomp-arg))) - (cond ((eq bytecomp-res 'no-byte-compile) - (setq skip-count (1+ skip-count))) - ((eq bytecomp-res t) - (setq file-count (1+ file-count))) - ((eq bytecomp-res nil) - (setq fail-count (1+ fail-count))))) - (or noninteractive - (message "Checking %s..." bytecomp-directory)) - (if (not (eq last-dir bytecomp-directory)) - (setq last-dir bytecomp-directory - dir-count (1+ dir-count))) - ))))) - (setq bytecomp-directories (cdr bytecomp-directories)))) + (while directories + (setq directory (car directories)) + (message "Checking %s..." directory) + (dolist (file (directory-files directory)) + (let ((source (expand-file-name file directory))) + (if (and (not (member file '("RCS" "CVS"))) + (not (eq ?\. (aref file 0))) + (file-directory-p source) + (not (file-symlink-p source))) + ;; This file is a subdirectory. Handle them differently. + (when (or (null arg) (eq 0 arg) + (y-or-n-p (concat "Check " source "? "))) + (setq directories (nconc directories (list source)))) + ;; It is an ordinary file. Decide whether to compile it. + (if (and (string-match emacs-lisp-file-regexp source) + (file-readable-p source) + (not (auto-save-file-name-p source)) + (not (string-equal dir-locals-file + (file-name-nondirectory source)))) + (progn (case (byte-recompile-file source force arg) + (no-byte-compile (setq skip-count (1+ skip-count))) + ((t) (setq file-count (1+ file-count))) + ((nil) (setq fail-count (1+ fail-count)))) + (or noninteractive + (message "Checking %s..." directory)) + (if (not (eq last-dir directory)) + (setq last-dir directory + dir-count (1+ dir-count))) + ))))) + (setq directories (cdr directories)))) (message "Done (Total of %d file%s compiled%s%s%s)" file-count (if (= file-count 1) "" "s") (if (> fail-count 0) (format ", %d failed" fail-count) "") @@ -1660,100 +1639,97 @@ This is normally set in local file variables at the end of the elisp file: \;; Local Variables:\n;; no-byte-compile: t\n;; End: ") ;Backslash for compile-main. ;;;###autoload(put 'no-byte-compile 'safe-local-variable 'booleanp) -(defun byte-recompile-file (bytecomp-filename &optional bytecomp-force bytecomp-arg load) - "Recompile BYTECOMP-FILENAME file if it needs recompilation. +(defun byte-recompile-file (filename &optional force arg load) + "Recompile FILENAME file if it needs recompilation. This happens when its `.elc' file is older than itself. If the `.elc' file exists and is up-to-date, normally this -function *does not* compile BYTECOMP-FILENAME. However, if the -prefix argument BYTECOMP-FORCE is set, that means do compile -BYTECOMP-FILENAME even if the destination already exists and is +function *does not* compile FILENAME. However, if the +prefix argument FORCE is set, that means do compile +FILENAME even if the destination already exists and is up-to-date. If the `.elc' file does not exist, normally this function *does -not* compile BYTECOMP-FILENAME. If BYTECOMP-ARG is 0, that means +not* compile FILENAME. If ARG is 0, that means compile the file even if it has never been compiled before. -A nonzero BYTECOMP-ARG means ask the user. +A nonzero ARG means ask the user. If LOAD is set, `load' the file after compiling. The value returned is the value returned by `byte-compile-file', or 'no-byte-compile if the file did not need recompilation." (interactive - (let ((bytecomp-file buffer-file-name) - (bytecomp-file-name nil) - (bytecomp-file-dir nil)) - (and bytecomp-file - (eq (cdr (assq 'major-mode (buffer-local-variables))) - 'emacs-lisp-mode) - (setq bytecomp-file-name (file-name-nondirectory bytecomp-file) - bytecomp-file-dir (file-name-directory bytecomp-file))) + (let ((file buffer-file-name) + (file-name nil) + (file-dir nil)) + (and file + (derived-mode-p 'emacs-lisp-mode) + (setq file-name (file-name-nondirectory file) + file-dir (file-name-directory file))) (list (read-file-name (if current-prefix-arg "Byte compile file: " "Byte recompile file: ") - bytecomp-file-dir bytecomp-file-name nil) + file-dir file-name nil) current-prefix-arg))) - (let ((bytecomp-dest - (byte-compile-dest-file bytecomp-filename)) + (let ((dest (byte-compile-dest-file filename)) ;; Expand now so we get the current buffer's defaults - (bytecomp-filename (expand-file-name bytecomp-filename))) - (if (if (file-exists-p bytecomp-dest) + (filename (expand-file-name filename))) + (if (if (file-exists-p dest) ;; File was already compiled ;; Compile if forced to, or filename newer - (or bytecomp-force - (file-newer-than-file-p bytecomp-filename - bytecomp-dest)) - (and bytecomp-arg - (or (eq 0 bytecomp-arg) + (or force + (file-newer-than-file-p filename dest)) + (and arg + (or (eq 0 arg) (y-or-n-p (concat "Compile " - bytecomp-filename "? "))))) + filename "? "))))) (progn (if (and noninteractive (not byte-compile-verbose)) - (message "Compiling %s..." bytecomp-filename)) - (byte-compile-file bytecomp-filename load)) - (when load (load bytecomp-filename)) + (message "Compiling %s..." filename)) + (byte-compile-file filename load)) + (when load (load filename)) 'no-byte-compile))) ;;;###autoload -(defun byte-compile-file (bytecomp-filename &optional load) - "Compile a file of Lisp code named BYTECOMP-FILENAME into a file of byte code. -The output file's name is generated by passing BYTECOMP-FILENAME to the +(defun byte-compile-file (filename &optional load) + "Compile a file of Lisp code named FILENAME into a file of byte code. +The output file's name is generated by passing FILENAME to the function `byte-compile-dest-file' (which see). With prefix arg (noninteractively: 2nd arg), LOAD the file after compiling. The value is non-nil if there were no errors, nil if errors." ;; (interactive "fByte compile file: \nP") (interactive - (let ((bytecomp-file buffer-file-name) - (bytecomp-file-name nil) - (bytecomp-file-dir nil)) - (and bytecomp-file + (let ((file buffer-file-name) + (file-name nil) + (file-dir nil)) + (and file (derived-mode-p 'emacs-lisp-mode) - (setq bytecomp-file-name (file-name-nondirectory bytecomp-file) - bytecomp-file-dir (file-name-directory bytecomp-file))) + (setq file-name (file-name-nondirectory file) + file-dir (file-name-directory file))) (list (read-file-name (if current-prefix-arg "Byte compile and load file: " "Byte compile file: ") - bytecomp-file-dir bytecomp-file-name nil) + file-dir file-name nil) current-prefix-arg))) ;; Expand now so we get the current buffer's defaults - (setq bytecomp-filename (expand-file-name bytecomp-filename)) + (setq filename (expand-file-name filename)) ;; If we're compiling a file that's in a buffer and is modified, offer ;; to save it first. (or noninteractive - (let ((b (get-file-buffer (expand-file-name bytecomp-filename)))) + (let ((b (get-file-buffer (expand-file-name filename)))) (if (and b (buffer-modified-p b) (y-or-n-p (format "Save buffer %s first? " (buffer-name b)))) (with-current-buffer b (save-buffer))))) ;; Force logging of the file name for each file compiled. (setq byte-compile-last-logged-file nil) - (let ((byte-compile-current-file bytecomp-filename) + (let ((byte-compile-current-file filename) (byte-compile-current-group nil) (set-auto-coding-for-load t) target-file input-buffer output-buffer byte-compile-dest-file) - (setq target-file (byte-compile-dest-file bytecomp-filename)) + (setq target-file (byte-compile-dest-file filename)) (setq byte-compile-dest-file target-file) (with-current-buffer (setq input-buffer (get-buffer-create " *Compiler Input*")) @@ -1762,7 +1738,7 @@ The value is non-nil if there were no errors, nil if errors." ;; Always compile an Emacs Lisp file as multibyte ;; unless the file itself forces unibyte with -*-coding: raw-text;-*- (set-buffer-multibyte t) - (insert-file-contents bytecomp-filename) + (insert-file-contents filename) ;; Mimic the way after-insert-file-set-coding can make the ;; buffer unibyte when visiting this file. (when (or (eq last-coding-system-used 'no-conversion) @@ -1772,7 +1748,7 @@ The value is non-nil if there were no errors, nil if errors." (set-buffer-multibyte nil)) ;; Run hooks including the uncompression hook. ;; If they change the file name, then change it for the output also. - (letf ((buffer-file-name bytecomp-filename) + (letf ((buffer-file-name filename) ((default-value 'major-mode) 'emacs-lisp-mode) ;; Ignore unsafe local variables. ;; We only care about a few of them for our purposes. @@ -1780,15 +1756,15 @@ The value is non-nil if there were no errors, nil if errors." (enable-local-eval nil)) ;; Arg of t means don't alter enable-local-variables. (normal-mode t) - (setq bytecomp-filename buffer-file-name)) + (setq filename buffer-file-name)) ;; Set the default directory, in case an eval-when-compile uses it. - (setq default-directory (file-name-directory bytecomp-filename))) + (setq default-directory (file-name-directory filename))) ;; Check if the file's local variables explicitly specify not to ;; compile this file. (if (with-current-buffer input-buffer no-byte-compile) (progn ;; (message "%s not compiled because of `no-byte-compile: %s'" - ;; (file-relative-name bytecomp-filename) + ;; (file-relative-name filename) ;; (with-current-buffer input-buffer no-byte-compile)) (when (file-exists-p target-file) (message "%s deleted because of `no-byte-compile: %s'" @@ -1798,7 +1774,7 @@ The value is non-nil if there were no errors, nil if errors." ;; We successfully didn't compile this file. 'no-byte-compile) (when byte-compile-verbose - (message "Compiling %s..." bytecomp-filename)) + (message "Compiling %s..." filename)) (setq byte-compiler-error-flag nil) ;; It is important that input-buffer not be current at this call, ;; so that the value of point set in input-buffer @@ -1809,7 +1785,7 @@ The value is non-nil if there were no errors, nil if errors." (if byte-compiler-error-flag nil (when byte-compile-verbose - (message "Compiling %s...done" bytecomp-filename)) + (message "Compiling %s...done" filename)) (kill-buffer input-buffer) (with-current-buffer output-buffer (goto-char (point-max)) @@ -1849,9 +1825,9 @@ The value is non-nil if there were no errors, nil if errors." (if (and byte-compile-generate-call-tree (or (eq t byte-compile-generate-call-tree) (y-or-n-p (format "Report call tree for %s? " - bytecomp-filename)))) + filename)))) (save-excursion - (display-call-tree bytecomp-filename))) + (display-call-tree filename))) (if load (load target-file)) t)))) @@ -1885,11 +1861,11 @@ With argument ARG, insert value in current buffer after the form." ;; Dynamically bound in byte-compile-from-buffer. ;; NB also used in cl.el and cl-macs.el. -(defvar bytecomp-outbuffer) +(defvar byte-compile-outbuffer) -(defun byte-compile-from-buffer (bytecomp-inbuffer) - (let (bytecomp-outbuffer - (byte-compile-current-buffer bytecomp-inbuffer) +(defun byte-compile-from-buffer (inbuffer) + (let (byte-compile-outbuffer + (byte-compile-current-buffer inbuffer) (byte-compile-read-position nil) (byte-compile-last-position nil) ;; Prevent truncation of flonums and lists as we read and print them @@ -1910,23 +1886,23 @@ With argument ARG, insert value in current buffer after the form." (byte-compile-output nil) ;; This allows us to get the positions of symbols read; it's ;; new in Emacs 22.1. - (read-with-symbol-positions bytecomp-inbuffer) + (read-with-symbol-positions inbuffer) (read-symbol-positions-list nil) ;; #### This is bound in b-c-close-variables. ;; (byte-compile-warnings byte-compile-warnings) ) (byte-compile-close-variables (with-current-buffer - (setq bytecomp-outbuffer (get-buffer-create " *Compiler Output*")) + (setq byte-compile-outbuffer (get-buffer-create " *Compiler Output*")) (set-buffer-multibyte t) (erase-buffer) ;; (emacs-lisp-mode) (setq case-fold-search nil)) (displaying-byte-compile-warnings - (with-current-buffer bytecomp-inbuffer + (with-current-buffer inbuffer (and byte-compile-current-file (byte-compile-insert-header byte-compile-current-file - bytecomp-outbuffer)) + byte-compile-outbuffer)) (goto-char (point-min)) ;; Should we always do this? When calling multiple files, it ;; would be useful to delay this warning until all have been @@ -1943,7 +1919,7 @@ With argument ARG, insert value in current buffer after the form." (setq byte-compile-read-position (point) byte-compile-last-position byte-compile-read-position) (let* ((old-style-backquotes nil) - (form (read bytecomp-inbuffer))) + (form (read inbuffer))) ;; Warn about the use of old-style backquotes. (when old-style-backquotes (byte-compile-warn "!! The file uses old-style backquotes !! @@ -1959,9 +1935,9 @@ and will be removed soon. See (elisp)Backquote in the manual.")) ;; Fix up the header at the front of the output ;; if the buffer contains multibyte characters. (and byte-compile-current-file - (with-current-buffer bytecomp-outbuffer + (with-current-buffer byte-compile-outbuffer (byte-compile-fix-header byte-compile-current-file))))) - bytecomp-outbuffer)) + byte-compile-outbuffer)) (defun byte-compile-fix-header (filename) "If the current buffer has any multibyte characters, insert a version test." @@ -2070,8 +2046,8 @@ Call from the source buffer." (print-gensym t) (print-circle ; handle circular data structures (not byte-compile-disable-print-circle))) - (princ "\n" bytecomp-outbuffer) - (prin1 form bytecomp-outbuffer) + (princ "\n" byte-compile-outbuffer) + (prin1 form byte-compile-outbuffer) nil))) (defvar print-gensym-alist) ;Used before print-circle existed. @@ -2091,7 +2067,7 @@ list that represents a doc string reference. ;; We need to examine byte-compile-dynamic-docstrings ;; in the input buffer (now current), not in the output buffer. (let ((dynamic-docstrings byte-compile-dynamic-docstrings)) - (with-current-buffer bytecomp-outbuffer + (with-current-buffer byte-compile-outbuffer (let (position) ;; Insert the doc string, and make it a comment with #@LENGTH. @@ -2115,7 +2091,7 @@ list that represents a doc string reference. (if preface (progn (insert preface) - (prin1 name bytecomp-outbuffer))) + (prin1 name byte-compile-outbuffer))) (insert (car info)) (let ((print-escape-newlines t) (print-quoted t) @@ -2130,7 +2106,7 @@ list that represents a doc string reference. (print-continuous-numbering t) print-number-table (index 0)) - (prin1 (car form) bytecomp-outbuffer) + (prin1 (car form) byte-compile-outbuffer) (while (setq form (cdr form)) (setq index (1+ index)) (insert " ") @@ -2153,35 +2129,35 @@ list that represents a doc string reference. (setq position (- (position-bytes position) (point-min) -1)) (princ (format "(#$ . %d) nil" position) - bytecomp-outbuffer) + byte-compile-outbuffer) (setq form (cdr form)) (setq index (1+ index)))) ((= index (nth 1 info)) (if position (princ (format (if quoted "'(#$ . %d)" "(#$ . %d)") position) - bytecomp-outbuffer) + byte-compile-outbuffer) (let ((print-escape-newlines nil)) (goto-char (prog1 (1+ (point)) - (prin1 (car form) bytecomp-outbuffer))) + (prin1 (car form) byte-compile-outbuffer))) (insert "\\\n") (goto-char (point-max))))) (t - (prin1 (car form) bytecomp-outbuffer))))) + (prin1 (car form) byte-compile-outbuffer))))) (insert (nth 2 info))))) nil) -(defun byte-compile-keep-pending (form &optional bytecomp-handler) +(defun byte-compile-keep-pending (form &optional handler) (if (memq byte-optimize '(t source)) (setq form (byte-optimize-form form t))) - (if bytecomp-handler + (if handler (let ((byte-compile--for-effect t)) ;; To avoid consing up monstrously large forms at load time, we split ;; the output regularly. (and (memq (car-safe form) '(fset defalias)) (nthcdr 300 byte-compile-output) (byte-compile-flush-pending)) - (funcall bytecomp-handler form) + (funcall handler form) (if byte-compile--for-effect (byte-compile-discard))) (byte-compile-form form t)) @@ -2219,11 +2195,11 @@ list that represents a doc string reference. ;; byte-hunk-handlers can call this. (defun byte-compile-file-form (form) - (let (bytecomp-handler) + (let (handler) (cond ((and (consp form) (symbolp (car form)) - (setq bytecomp-handler (get (car form) 'byte-hunk-handler))) - (cond ((setq form (funcall bytecomp-handler form)) + (setq handler (get (car form) 'byte-hunk-handler))) + (cond ((setq form (funcall handler form)) (byte-compile-flush-pending) (byte-compile-output-file-form form)))) (t @@ -2385,32 +2361,30 @@ by side-effects." res)) (defun byte-compile-file-form-defmumble (form macrop) - (let* ((bytecomp-name (car (cdr form))) - (bytecomp-this-kind (if macrop 'byte-compile-macro-environment + (let* ((name (car (cdr form))) + (this-kind (if macrop 'byte-compile-macro-environment 'byte-compile-function-environment)) - (bytecomp-that-kind (if macrop 'byte-compile-function-environment + (that-kind (if macrop 'byte-compile-function-environment 'byte-compile-macro-environment)) - (bytecomp-this-one (assq bytecomp-name - (symbol-value bytecomp-this-kind))) - (bytecomp-that-one (assq bytecomp-name - (symbol-value bytecomp-that-kind))) + (this-one (assq name (symbol-value this-kind))) + (that-one (assq name (symbol-value that-kind))) (byte-compile-free-references nil) (byte-compile-free-assignments nil)) - (byte-compile-set-symbol-position bytecomp-name) + (byte-compile-set-symbol-position name) ;; When a function or macro is defined, add it to the call tree so that ;; we can tell when functions are not used. (if byte-compile-generate-call-tree - (or (assq bytecomp-name byte-compile-call-tree) + (or (assq name byte-compile-call-tree) (setq byte-compile-call-tree - (cons (list bytecomp-name nil nil) byte-compile-call-tree)))) + (cons (list name nil nil) byte-compile-call-tree)))) - (setq byte-compile-current-form bytecomp-name) ; for warnings + (setq byte-compile-current-form name) ; for warnings (if (byte-compile-warning-enabled-p 'redefine) (byte-compile-arglist-warn form macrop)) (if byte-compile-verbose (message "Compiling %s... (%s)" (or byte-compile-current-file "") (nth 1 form))) - (cond (bytecomp-that-one + (cond (that-one (if (and (byte-compile-warning-enabled-p 'redefine) ;; don't warn when compiling the stubs in byte-run... (not (assq (nth 1 form) @@ -2418,8 +2392,8 @@ by side-effects." (byte-compile-warn "`%s' defined multiple times, as both function and macro" (nth 1 form))) - (setcdr bytecomp-that-one nil)) - (bytecomp-this-one + (setcdr that-one nil)) + (this-one (when (and (byte-compile-warning-enabled-p 'redefine) ;; hack: don't warn when compiling the magic internal ;; byte-compiler macros in byte-run.el... @@ -2428,8 +2402,8 @@ by side-effects." (byte-compile-warn "%s `%s' defined multiple times in this file" (if macrop "macro" "function") (nth 1 form)))) - ((and (fboundp bytecomp-name) - (eq (car-safe (symbol-function bytecomp-name)) + ((and (fboundp name) + (eq (car-safe (symbol-function name)) (if macrop 'lambda 'macro))) (when (byte-compile-warning-enabled-p 'redefine) (byte-compile-warn "%s `%s' being redefined as a %s" @@ -2437,9 +2411,9 @@ by side-effects." (nth 1 form) (if macrop "macro" "function"))) ;; shadow existing definition - (set bytecomp-this-kind - (cons (cons bytecomp-name nil) - (symbol-value bytecomp-this-kind)))) + (set this-kind + (cons (cons name nil) + (symbol-value this-kind)))) ) (let ((body (nthcdr 3 form))) (when (and (stringp (car body)) @@ -2454,27 +2428,27 @@ by side-effects." ;; Remove declarations from the body of the macro definition. (when macrop (dolist (decl (byte-compile-defmacro-declaration form)) - (prin1 decl bytecomp-outbuffer))) + (prin1 decl byte-compile-outbuffer))) (let* ((new-one (byte-compile-lambda (nthcdr 2 form) t)) (code (byte-compile-byte-code-maker new-one))) - (if bytecomp-this-one - (setcdr bytecomp-this-one new-one) - (set bytecomp-this-kind - (cons (cons bytecomp-name new-one) - (symbol-value bytecomp-this-kind)))) + (if this-one + (setcdr this-one new-one) + (set this-kind + (cons (cons name new-one) + (symbol-value this-kind)))) (if (and (stringp (nth 3 form)) (eq 'quote (car-safe code)) (eq 'lambda (car-safe (nth 1 code)))) (cons (car form) - (cons bytecomp-name (cdr (nth 1 code)))) + (cons name (cdr (nth 1 code)))) (byte-compile-flush-pending) (if (not (stringp (nth 3 form))) ;; No doc string. Provide -1 as the "doc string index" ;; so that no element will be treated as a doc string. (byte-compile-output-docform "\n(defalias '" - bytecomp-name + name (cond ((atom code) (if macrop '(" '(macro . #[" -1 "])") '(" #[" -1 "]"))) ((eq (car code) 'quote) @@ -2489,7 +2463,7 @@ by side-effects." ;; b-c-output-file-form analyze the defalias. (byte-compile-output-docform "\n(defalias '" - bytecomp-name + name (cond ((atom code) (if macrop '(" '(macro . #[" 4 "])") '(" #[" 4 "]"))) ((eq (car code) 'quote) @@ -2500,7 +2474,7 @@ by side-effects." (and (atom code) byte-compile-dynamic 1) nil)) - (princ ")" bytecomp-outbuffer) + (princ ")" byte-compile-outbuffer) nil)))) ;; Print Lisp object EXP in the output file, inside a comment, @@ -2508,13 +2482,13 @@ by side-effects." ;; If QUOTED is non-nil, print with quoting; otherwise, print without quoting. (defun byte-compile-output-as-comment (exp quoted) (let ((position (point))) - (with-current-buffer bytecomp-outbuffer + (with-current-buffer byte-compile-outbuffer ;; Insert EXP, and make it a comment with #@LENGTH. (insert " ") (if quoted - (prin1 exp bytecomp-outbuffer) - (princ exp bytecomp-outbuffer)) + (prin1 exp byte-compile-outbuffer) + (princ exp byte-compile-outbuffer)) (goto-char position) ;; Quote certain special characters as needed. ;; get_doc_string in doc.c does the unquoting. @@ -2693,41 +2667,41 @@ If FORM is a lambda or a macro, byte-compile it as a function." ;; of the list FUN and `byte-compile-set-symbol-position' is not called. ;; Use this feature to avoid calling `byte-compile-set-symbol-position' ;; for symbols generated by the byte compiler itself. -(defun byte-compile-lambda (bytecomp-fun &optional add-lambda reserved-csts) +(defun byte-compile-lambda (fun &optional add-lambda reserved-csts) (if add-lambda - (setq bytecomp-fun (cons 'lambda bytecomp-fun)) - (unless (eq 'lambda (car-safe bytecomp-fun)) - (error "Not a lambda list: %S" bytecomp-fun)) + (setq fun (cons 'lambda fun)) + (unless (eq 'lambda (car-safe fun)) + (error "Not a lambda list: %S" fun)) (byte-compile-set-symbol-position 'lambda)) - (byte-compile-check-lambda-list (nth 1 bytecomp-fun)) - (let* ((bytecomp-arglist (nth 1 bytecomp-fun)) + (byte-compile-check-lambda-list (nth 1 fun)) + (let* ((arglist (nth 1 fun)) (byte-compile-bound-variables (append (and (not lexical-binding) - (byte-compile-arglist-vars bytecomp-arglist)) + (byte-compile-arglist-vars arglist)) byte-compile-bound-variables)) - (bytecomp-body (cdr (cdr bytecomp-fun))) - (bytecomp-doc (if (stringp (car bytecomp-body)) - (prog1 (car bytecomp-body) - ;; Discard the doc string - ;; unless it is the last element of the body. - (if (cdr bytecomp-body) - (setq bytecomp-body (cdr bytecomp-body)))))) - (bytecomp-int (assq 'interactive bytecomp-body))) + (body (cdr (cdr fun))) + (doc (if (stringp (car body)) + (prog1 (car body) + ;; Discard the doc string + ;; unless it is the last element of the body. + (if (cdr body) + (setq body (cdr body)))))) + (int (assq 'interactive body))) ;; Process the interactive spec. - (when bytecomp-int + (when int (byte-compile-set-symbol-position 'interactive) ;; Skip (interactive) if it is in front (the most usual location). - (if (eq bytecomp-int (car bytecomp-body)) - (setq bytecomp-body (cdr bytecomp-body))) - (cond ((consp (cdr bytecomp-int)) - (if (cdr (cdr bytecomp-int)) + (if (eq int (car body)) + (setq body (cdr body))) + (cond ((consp (cdr int)) + (if (cdr (cdr int)) (byte-compile-warn "malformed interactive spec: %s" - (prin1-to-string bytecomp-int))) + (prin1-to-string int))) ;; If the interactive spec is a call to `list', don't ;; compile it, because `call-interactively' looks at the ;; args of `list'. Actually, compile it to get warnings, ;; but don't use the result. - (let* ((form (nth 1 bytecomp-int)) + (let* ((form (nth 1 int)) (newform (byte-compile-top-level form))) (while (memq (car-safe form) '(let let* progn save-excursion)) (while (consp (cdr form)) @@ -2739,48 +2713,46 @@ If FORM is a lambda or a macro, byte-compile it as a function." ;; it won't be eval'd in the right mode. (not lexical-binding)) nil - (setq bytecomp-int `(interactive ,newform))))) - ((cdr bytecomp-int) + (setq int `(interactive ,newform))))) + ((cdr int) (byte-compile-warn "malformed interactive spec: %s" - (prin1-to-string bytecomp-int))))) + (prin1-to-string int))))) ;; Process the body. (let ((compiled - (byte-compile-top-level (cons 'progn bytecomp-body) nil 'lambda + (byte-compile-top-level (cons 'progn body) nil 'lambda ;; If doing lexical binding, push a new ;; lexical environment containing just the ;; args (since lambda expressions should be ;; closed by now). (and lexical-binding - (byte-compile-make-lambda-lexenv - bytecomp-fun)) + (byte-compile-make-lambda-lexenv fun)) reserved-csts))) ;; Build the actual byte-coded function. (if (eq 'byte-code (car-safe compiled)) (apply 'make-byte-code (if lexical-binding - (byte-compile-make-args-desc bytecomp-arglist) - bytecomp-arglist) + (byte-compile-make-args-desc arglist) + arglist) (append ;; byte-string, constants-vector, stack depth (cdr compiled) ;; optionally, the doc string. (cond (lexical-binding (require 'help-fns) - (list (help-add-fundoc-usage - bytecomp-doc bytecomp-arglist))) - ((or bytecomp-doc bytecomp-int) - (list bytecomp-doc))) + (list (help-add-fundoc-usage doc arglist))) + ((or doc int) + (list doc))) ;; optionally, the interactive spec. - (if bytecomp-int - (list (nth 1 bytecomp-int))))) + (if int + (list (nth 1 int))))) (setq compiled - (nconc (if bytecomp-int (list bytecomp-int)) + (nconc (if int (list int)) (cond ((eq (car-safe compiled) 'progn) (cdr compiled)) (compiled (list compiled))))) - (nconc (list 'lambda bytecomp-arglist) - (if (or bytecomp-doc (stringp (car compiled))) - (cons bytecomp-doc (cond (compiled) - (bytecomp-body (list nil)))) + (nconc (list 'lambda arglist) + (if (or doc (stringp (car compiled))) + (cons doc (cond (compiled) + (body (list nil)))) compiled)))))) (defun byte-compile-closure (form &optional add-lambda) @@ -2951,14 +2923,14 @@ If FORM is a lambda or a macro, byte-compile it as a function." ((cdr body) (cons 'progn (nreverse body))) ((car body))))) -;; Given BYTECOMP-BODY, compile it and return a new body. -(defun byte-compile-top-level-body (bytecomp-body &optional for-effect) - (setq bytecomp-body - (byte-compile-top-level (cons 'progn bytecomp-body) for-effect t)) - (cond ((eq (car-safe bytecomp-body) 'progn) - (cdr bytecomp-body)) - (bytecomp-body - (list bytecomp-body)))) +;; Given BODY, compile it and return a new body. +(defun byte-compile-top-level-body (body &optional for-effect) + (setq body + (byte-compile-top-level (cons 'progn body) for-effect t)) + (cond ((eq (car-safe body) 'progn) + (cdr body)) + (body + (list body)))) ;; Special macro-expander used during byte-compilation. (defun byte-compile-macroexpand-declare-function (fn file &rest args) @@ -3002,28 +2974,28 @@ If FORM is a lambda or a macro, byte-compile it as a function." (t (byte-compile-variable-ref form)))) ((symbolp (car form)) - (let* ((bytecomp-fn (car form)) - (bytecomp-handler (get bytecomp-fn 'byte-compile))) - (when (byte-compile-const-symbol-p bytecomp-fn) - (byte-compile-warn "`%s' called as a function" bytecomp-fn)) + (let* ((fn (car form)) + (handler (get fn 'byte-compile))) + (when (byte-compile-const-symbol-p fn) + (byte-compile-warn "`%s' called as a function" fn)) (and (byte-compile-warning-enabled-p 'interactive-only) - (memq bytecomp-fn byte-compile-interactive-only-functions) + (memq fn byte-compile-interactive-only-functions) (byte-compile-warn "`%s' used from Lisp code\n\ -That command is designed for interactive use only" bytecomp-fn)) +That command is designed for interactive use only" fn)) (if (and (fboundp (car form)) (eq (car-safe (symbol-function (car form))) 'macro)) (byte-compile-report-error (format "Forgot to expand macro %s" (car form)))) - (if (and bytecomp-handler + (if (and handler ;; Make sure that function exists. This is important ;; for CL compiler macros since the symbol may be ;; `cl-byte-compile-compiler-macro' but if CL isn't ;; loaded, this function doesn't exist. - (and (not (eq bytecomp-handler + (and (not (eq handler ;; Already handled by macroexpand-all. 'cl-byte-compile-compiler-macro)) - (functionp bytecomp-handler))) - (funcall bytecomp-handler form) + (functionp handler))) + (funcall handler form) (byte-compile-normal-call form)) (if (byte-compile-warning-enabled-p 'cl-functions) (byte-compile-cl-warn form)))) @@ -3609,14 +3581,14 @@ discarding." (byte-defop-compiler-1 quote) (defun byte-compile-setq (form) - (let ((bytecomp-args (cdr form))) - (if bytecomp-args - (while bytecomp-args - (byte-compile-form (car (cdr bytecomp-args))) - (or byte-compile--for-effect (cdr (cdr bytecomp-args)) + (let ((args (cdr form))) + (if args + (while args + (byte-compile-form (car (cdr args))) + (or byte-compile--for-effect (cdr (cdr args)) (byte-compile-out 'byte-dup 0)) - (byte-compile-variable-set (car bytecomp-args)) - (setq bytecomp-args (cdr (cdr bytecomp-args)))) + (byte-compile-variable-set (car args)) + (setq args (cdr (cdr args)))) ;; (setq), with no arguments. (byte-compile-form nil byte-compile--for-effect)) (setq byte-compile--for-effect nil))) @@ -3653,14 +3625,14 @@ discarding." ;;; control structures -(defun byte-compile-body (bytecomp-body &optional for-effect) - (while (cdr bytecomp-body) - (byte-compile-form (car bytecomp-body) t) - (setq bytecomp-body (cdr bytecomp-body))) - (byte-compile-form (car bytecomp-body) for-effect)) +(defun byte-compile-body (body &optional for-effect) + (while (cdr body) + (byte-compile-form (car body) t) + (setq body (cdr body))) + (byte-compile-form (car body) for-effect)) -(defsubst byte-compile-body-do-effect (bytecomp-body) - (byte-compile-body bytecomp-body byte-compile--for-effect) +(defsubst byte-compile-body-do-effect (body) + (byte-compile-body body byte-compile--for-effect) (setq byte-compile--for-effect nil)) (defsubst byte-compile-form-do-effect (form) @@ -3818,10 +3790,10 @@ that suppresses all warnings during execution of BODY." (defun byte-compile-and (form) (let ((failtag (byte-compile-make-tag)) - (bytecomp-args (cdr form))) - (if (null bytecomp-args) + (args (cdr form))) + (if (null args) (byte-compile-form-do-effect t) - (byte-compile-and-recursion bytecomp-args failtag)))) + (byte-compile-and-recursion args failtag)))) ;; Handle compilation of a nontrivial `and' call. ;; We use tail recursion so we can use byte-compile-maybe-guarded. @@ -3837,10 +3809,10 @@ that suppresses all warnings during execution of BODY." (defun byte-compile-or (form) (let ((wintag (byte-compile-make-tag)) - (bytecomp-args (cdr form))) - (if (null bytecomp-args) + (args (cdr form))) + (if (null args) (byte-compile-form-do-effect nil) - (byte-compile-or-recursion bytecomp-args wintag)))) + (byte-compile-or-recursion args wintag)))) ;; Handle compilation of a nontrivial `or' call. ;; We use tail recursion so we can use byte-compile-maybe-guarded. @@ -4554,57 +4526,54 @@ already up-to-date." (defvar command-line-args-left) ;Avoid 'free variable' warning (if (not noninteractive) (error "`batch-byte-compile' is to be used only with -batch")) - (let ((bytecomp-error nil)) + (let ((error nil)) (while command-line-args-left (if (file-directory-p (expand-file-name (car command-line-args-left))) ;; Directory as argument. - (let ((bytecomp-files (directory-files (car command-line-args-left))) - bytecomp-source bytecomp-dest) - (dolist (bytecomp-file bytecomp-files) - (if (and (string-match emacs-lisp-file-regexp bytecomp-file) - (not (auto-save-file-name-p bytecomp-file)) - (setq bytecomp-source - (expand-file-name bytecomp-file + (let (source dest) + (dolist (file (directory-files (car command-line-args-left))) + (if (and (string-match emacs-lisp-file-regexp file) + (not (auto-save-file-name-p file)) + (setq source + (expand-file-name file (car command-line-args-left))) - (setq bytecomp-dest (byte-compile-dest-file - bytecomp-source)) - (file-exists-p bytecomp-dest) - (file-newer-than-file-p bytecomp-source bytecomp-dest)) - (if (null (batch-byte-compile-file bytecomp-source)) - (setq bytecomp-error t))))) + (setq dest (byte-compile-dest-file source)) + (file-exists-p dest) + (file-newer-than-file-p source dest)) + (if (null (batch-byte-compile-file source)) + (setq error t))))) ;; Specific file argument (if (or (not noforce) - (let* ((bytecomp-source (car command-line-args-left)) - (bytecomp-dest (byte-compile-dest-file - bytecomp-source))) - (or (not (file-exists-p bytecomp-dest)) - (file-newer-than-file-p bytecomp-source bytecomp-dest)))) + (let* ((source (car command-line-args-left)) + (dest (byte-compile-dest-file source))) + (or (not (file-exists-p dest)) + (file-newer-than-file-p source dest)))) (if (null (batch-byte-compile-file (car command-line-args-left))) - (setq bytecomp-error t)))) + (setq error t)))) (setq command-line-args-left (cdr command-line-args-left))) - (kill-emacs (if bytecomp-error 1 0)))) + (kill-emacs (if error 1 0)))) -(defun batch-byte-compile-file (bytecomp-file) +(defun batch-byte-compile-file (file) (if debug-on-error - (byte-compile-file bytecomp-file) + (byte-compile-file file) (condition-case err - (byte-compile-file bytecomp-file) + (byte-compile-file file) (file-error (message (if (cdr err) ">>Error occurred processing %s: %s (%s)" ">>Error occurred processing %s: %s") - bytecomp-file + file (get (car err) 'error-message) (prin1-to-string (cdr err))) - (let ((bytecomp-destfile (byte-compile-dest-file bytecomp-file))) - (if (file-exists-p bytecomp-destfile) - (delete-file bytecomp-destfile))) + (let ((destfile (byte-compile-dest-file file))) + (if (file-exists-p destfile) + (delete-file destfile))) nil) (error (message (if (cdr err) ">>Error occurred processing %s: %s (%s)" ">>Error occurred processing %s: %s") - bytecomp-file + file (get (car err) 'error-message) (prin1-to-string (cdr err))) nil)))) diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index 2229be0de58..5d19bf969e6 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -65,8 +65,16 @@ ;; ;;; Code: -;; TODO: +;; TODO: (not just for cconv but also for the lexbind changes in general) +;; - inline lexical byte-code functions. +;; - investigate some old v18 stuff in bytecomp.el. +;; - optimize away unused cl-block-wrapper. +;; - let (e)debug find the value of lexical variables from the stack. ;; - byte-optimize-form should be applied before cconv. +;; OTOH, the warnings emitted by cconv-analyze need to come before optimize +;; since afterwards they can because obnoxious (warnings about an "unused +;; variable" should not be emitted when the variable use has simply been +;; optimized away). ;; - canonize code in macro-expand so we don't have to handle (let (var) body) ;; and other oddities. ;; - new byte codes for unwind-protect, catch, and condition-case so that @@ -213,7 +221,7 @@ Returns a form where all lambdas don't have any free variables." (if (assq arg new-env) (push `(,arg) new-env)) (push `(,arg . (car ,arg)) new-env) (push `(,arg (list ,arg)) letbind))) - + (setq body-new (mapcar (lambda (form) (cconv-convert form new-env nil)) body)) @@ -255,7 +263,7 @@ places where they originally did not directly appear." (cconv--set-diff (cdr (cddr mapping)) extend))) env)))) - + ;; What's the difference between fvrs and envs? ;; Suppose that we have the code ;; (lambda (..) fvr (let ((fvr 1)) (+ fvr 1))) @@ -377,6 +385,7 @@ places where they originally did not directly appear." ; first element is lambda expression (`(,(and `(lambda . ,_) fun) . ,args) ;; FIXME: it's silly to create a closure just to call it. + ;; Running byte-optimize-form earlier will resolve this. `(funcall ,(cconv-convert `(function ,fun) env extend) ,@(mapcar (lambda (form) @@ -486,9 +495,9 @@ places where they originally did not directly appear." `(interactive . ,(mapcar (lambda (form) (cconv-convert form nil nil)) forms))) - + (`(declare . ,_) form) ;The args don't contain code. - + (`(,func . ,forms) ;; First element is function or whatever function-like forms are: or, and, ;; if, progn, prog1, prog2, while, until @@ -623,7 +632,7 @@ and updates the data stored in ENV." (`(function (lambda ,vrs . ,body-forms)) (cconv--analyse-function vrs body-forms env form)) - + (`(setq . ,forms) ;; If a local variable (member of env) is modified by setq then ;; it is a mutated variable. @@ -646,8 +655,8 @@ and updates the data stored in ENV." (`(condition-case ,var ,protected-form . ,handlers) ;; FIXME: The bytecode for condition-case forces us to wrap the - ;; form and handlers in closures (for handlers, it's probably - ;; unavoidable, but not for the protected form). + ;; form and handlers in closures (for handlers, it's understandable + ;; but not for the protected form). (cconv--analyse-function () (list protected-form) env form) (dolist (handler handlers) (cconv--analyse-function (if var (list var)) (cdr handler) env form))) @@ -657,8 +666,8 @@ and updates the data stored in ENV." (cconv-analyse-form form env) (cconv--analyse-function () body env form)) - ;; FIXME: The bytecode for save-window-excursion and the lack of - ;; bytecode for track-mouse forces us to wrap the body. + ;; FIXME: The lack of bytecode for track-mouse forces us to wrap the body. + ;; `track-mouse' really should be made into a macro. (`(track-mouse . ,body) (cconv--analyse-function () body env form)) @@ -686,7 +695,7 @@ and updates the data stored in ENV." (dolist (form forms) (cconv-analyse-form form nil))) (`(declare . ,_) nil) ;The args don't contain code. - + (`(,_ . ,body-forms) ; First element is a function or whatever. (dolist (form body-forms) (cconv-analyse-form form env))) diff --git a/lisp/emacs-lisp/cl-loaddefs.el b/lisp/emacs-lisp/cl-loaddefs.el index 2795b143e47..3a6878ed16b 100644 --- a/lisp/emacs-lisp/cl-loaddefs.el +++ b/lisp/emacs-lisp/cl-loaddefs.el @@ -282,7 +282,7 @@ Not documented ;;;;;; flet progv psetq do-all-symbols do-symbols dotimes dolist ;;;;;; do* do loop return-from return block etypecase typecase ecase ;;;;;; case load-time-value eval-when destructuring-bind function* -;;;;;; defmacro* defun* gentemp gensym) "cl-macs" "cl-macs.el" "864a28dc0495ad87d39637a965387526") +;;;;;; defmacro* defun* gentemp gensym) "cl-macs" "cl-macs.el" "80cb83265399ce021c8c0c7d1a8562f2") ;;; Generated autoloads from cl-macs.el (autoload 'gensym "cl-macs" "\ diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 851355e2c75..785a45d9640 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -497,7 +497,7 @@ The result of the body appears to the compiler as a quoted constant." (symbol-function 'byte-compile-file-form))) (list 'byte-compile-file-form (list 'quote set)) '(byte-compile-file-form form))) - (print set (symbol-value 'bytecomp-outbuffer))) + (print set (symbol-value 'byte-compile-outbuffer))) (list 'symbol-value (list 'quote temp))) (list 'quote (eval form)))) diff --git a/lisp/emacs-lisp/cl.el b/lisp/emacs-lisp/cl.el index d303dab4ad3..9c626dfcfa3 100644 --- a/lisp/emacs-lisp/cl.el +++ b/lisp/emacs-lisp/cl.el @@ -278,9 +278,9 @@ definitions to shadow the loaded ones for use in file byte-compilation. (defvar cl-compiling-file nil) (defun cl-compiling-file () (or cl-compiling-file - (and (boundp 'bytecomp-outbuffer) - (bufferp (symbol-value 'bytecomp-outbuffer)) - (equal (buffer-name (symbol-value 'bytecomp-outbuffer)) + (and (boundp 'byte-compile-outbuffer) + (bufferp (symbol-value 'byte-compile-outbuffer)) + (equal (buffer-name (symbol-value 'byte-compile-outbuffer)) " *Compiler Output*")))) (defvar cl-proclaims-deferred nil) diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index e95bcac2a70..e6c4ccbbc50 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -27,16 +27,21 @@ ;; Todo: +;; - (pcase e (`(,x . ,x) foo)) signals an "x unused" warning if `foo' doesn't +;; use x, because x is bound separately for the equality constraint +;; (as well as any pred/guard) and for the body, so uses at one place don't +;; count for the other. ;; - provide ways to extend the set of primitives, with some kind of ;; define-pcase-matcher. We could easily make it so that (guard BOOLEXP) ;; could be defined this way, as a shorthand for (pred (lambda (_) BOOLEXP)). ;; But better would be if we could define new ways to match by having the ;; extension provide its own `pcase--split-' thingy. +;; - along these lines, provide patterns to match CL structs. ;; - provide something like (setq VAR) so a var can be set rather than ;; let-bound. -;; - provide a way to fallthrough to other cases. +;; - provide a way to fallthrough to subsequent cases. ;; - try and be more clever to reduce the size of the decision tree, and -;; to reduce the number of leafs that need to be turned into function: +;; to reduce the number of leaves that need to be turned into function: ;; - first, do the tests shared by all remaining branches (it will have ;; to be performed anyway, so better so it first so it's shared). ;; - then choose the test that discriminates more (?). @@ -67,6 +72,7 @@ UPatterns can take the following forms: `QPAT matches if the QPattern QPAT matches. (pred PRED) matches if PRED applied to the object returns non-nil. (guard BOOLEXP) matches if BOOLEXP evaluates to non-nil. + (let UPAT EXP) matches if EXP matches UPAT. If a SYMBOL is used twice in the same pattern (i.e. the pattern is \"non-linear\"), then the second occurrence is turned into an `eq'uality test. @@ -297,15 +303,21 @@ MATCH is the pattern that needs to be matched, of the form: (symbolp . consp) (symbolp . arrayp) (symbolp . stringp) + (symbolp . byte-code-function-p) (integerp . consp) (integerp . arrayp) (integerp . stringp) + (integerp . byte-code-function-p) (numberp . consp) (numberp . arrayp) (numberp . stringp) + (numberp . byte-code-function-p) (consp . arrayp) (consp . stringp) - (arrayp . stringp))) + (consp . byte-code-function-p) + (arrayp . stringp) + (arrayp . byte-code-function-p) + (stringp . byte-code-function-p))) (defun pcase--split-match (sym splitter match) (cond @@ -514,11 +526,10 @@ Otherwise, it defers to REST which is a list of branches of the form (cond ((memq upat '(t _)) (pcase--u1 matches code vars rest)) ((eq upat 'dontcare) :pcase--dontcare) - ((functionp upat) (error "Feature removed, use (pred %s)" upat)) ((memq (car-safe upat) '(guard pred)) (if (eq (car upat) 'pred) (put sym 'pcase-used t)) (let* ((splitrest - (pcase--split-rest + (pcase--split-rest sym (apply-partially #'pcase--split-pred upat) rest)) (then-rest (car splitrest)) (else-rest (cdr splitrest))) @@ -527,21 +538,24 @@ Otherwise, it defers to REST which is a list of branches of the form (let* ((exp (cadr upat)) ;; `vs' is an upper bound on the vars we need. (vs (pcase--fgrep (mapcar #'car vars) exp)) - (call (cond - ((eq 'guard (car upat)) exp) - ((functionp exp) `(,exp ,sym)) - (t `(,@exp ,sym))))) + (env (mapcar (lambda (var) + (list var (cdr (assq var vars)))) + vs)) + (call (if (eq 'guard (car upat)) + exp + (when (memq sym vs) + ;; `sym' is shadowed by `env'. + (let ((newsym (make-symbol "x"))) + (push (list newsym sym) env) + (setq sym newsym))) + (if (functionp exp) `(,exp ,sym) + `(,@exp ,sym))))) (if (null vs) call ;; Let's not replace `vars' in `exp' since it's ;; too difficult to do it right, instead just ;; let-bind `vars' around `exp'. - `(let ,(mapcar (lambda (var) - (list var (cdr (assq var vars)))) - vs) - ;; FIXME: `vars' can capture `sym'. E.g. - ;; (pcase x ((and `(,x . ,y) (pred (fun x))))) - ,call)))) + `(let* ,env ,call)))) (pcase--u1 matches code vars then-rest) (pcase--u else-rest)))) ((symbolp upat) @@ -552,6 +566,25 @@ Otherwise, it defers to REST which is a list of branches of the form (pcase--u1 (cons `(match ,sym . (pred (eq ,(cdr (assq upat vars))))) matches) code vars rest))) + ((eq (car-safe upat) 'let) + ;; A upat of the form (let VAR EXP). + ;; (pcase--u1 matches code + ;; (cons (cons (nth 1 upat) (nth 2 upat)) vars) rest) + (let* ((exp + (let* ((exp (nth 2 upat)) + (found (assq exp vars))) + (if found (cdr found) + (let* ((vs (pcase--fgrep (mapcar #'car vars) exp)) + (env (mapcar (lambda (v) (list v (cdr (assq v vars)))) + vs))) + (if env `(let* ,env ,exp) exp))))) + (sym (if (symbolp exp) exp (make-symbol "x"))) + (body + (pcase--u1 (cons `(match ,sym . ,(nth 1 upat)) matches) + code vars rest))) + (if (eq sym exp) + body + `(let* ((,sym ,exp)) ,body)))) ((eq (car-safe upat) '\`) (put sym 'pcase-used t) (pcase--q1 sym (cadr upat) matches code vars rest)) diff --git a/lisp/startup.el b/lisp/startup.el index 384d81391ab..4dbf41d3ac6 100644 --- a/lisp/startup.el +++ b/lisp/startup.el @@ -2082,6 +2082,7 @@ A fancy display is used on graphic displays, normal otherwise." ;; Note that any local variables in this function affect the ;; ability of -f batch-byte-compile to detect free variables. ;; So we give some of them with common names a cl1- prefix. + ;; FIXME: A better fix would be to make this file use lexical-binding. (let ((cl1-dir command-line-default-directory) cl1-tem ;; This approach loses for "-batch -L DIR --eval "(require foo)", diff --git a/lisp/subr.el b/lisp/subr.el index 3a32a2f6558..45cfb56bdc1 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -187,10 +187,13 @@ Then evaluate RESULT to get return value, default nil. ;; It would be cleaner to create an uninterned symbol, ;; but that uses a lot more space when many functions in many files ;; use dolist. + ;; FIXME: This cost disappears in byte-compiled lexical-binding files. (let ((temp '--dolist-tail--)) `(let ((,temp ,(nth 1 spec)) ,(car spec)) (while ,temp + ;; FIXME: In lexical-binding code, a `let' inside the loop might + ;; turn out to be faster than the an outside `let' this `setq'. (setq ,(car spec) (car ,temp)) ,@body (setq ,temp (cdr ,temp))) diff --git a/src/ChangeLog b/src/ChangeLog index 00d8e4b8ee3..e34cd694321 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,8 @@ +2011-03-16 Stefan Monnier + + * image.c (parse_image_spec): Use Ffunctionp. + * lisp.h: Declare Ffunctionp. + 2011-03-13 Stefan Monnier * eval.c (Ffunction): Use simpler format for closures. diff --git a/src/bytecode.c b/src/bytecode.c index b19f9687cdc..ba3c012bd1a 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -939,27 +939,27 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, 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, eval_sub, v1); /* FIXME: lexbind */ + TOP = internal_catch (TOP, eval_sub, v1); AFTER_POTENTIAL_GC (); break; } - case Bunwind_protect: - record_unwind_protect (Fprogn, POP); /* FIXME: lexbind */ + 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; body = POP; BEFORE_POTENTIAL_GC (); - TOP = internal_lisp_condition_case (TOP, body, handlers); /* FIXME: lexbind */ + TOP = internal_lisp_condition_case (TOP, body, handlers); AFTER_POTENTIAL_GC (); break; } diff --git a/src/image.c b/src/image.c index a7c6346f62c..73a45633f3b 100644 --- a/src/image.c +++ b/src/image.c @@ -835,10 +835,7 @@ parse_image_spec (Lisp_Object spec, struct image_keyword *keywords, case IMAGE_FUNCTION_VALUE: value = indirect_function (value); - /* FIXME: Shouldn't we use Ffunctionp here? */ - if (SUBRP (value) - || COMPILEDP (value) - || (CONSP (value) && EQ (XCAR (value), Qlambda))) + if (!NILP (Ffunctionp (value))) break; return 0; diff --git a/src/lisp.h b/src/lisp.h index ece96428253..e4788e63f5b 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2864,6 +2864,7 @@ 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 (Ffunctionp, 1); EXFUN (Feval, 2); extern Lisp_Object eval_sub (Lisp_Object form); EXFUN (Fapply, MANY); -- cgit v1.3 From 7200d79c65c65686495dd95e9f6dd436cf6db55e Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Fri, 1 Apr 2011 11:16:50 -0400 Subject: Miscellanous cleanups in preparation for the merge. * lisp/emacs-lisp/byte-opt.el (byte-optimize-form-code-walker): Remove debug statement. * lisp/emacs-lisp/bytecomp.el (byte-compile-single-version) (byte-compile-version-cond, byte-compile-delay-out) (byte-compile-delayed-out): Remove, unused. * src/bytecode.c (Fbyte_code): Revert to old calling convention. * src/lisp.h (COMPILED_PUSH_ARGS): Remove, unused. --- doc/lispref/variables.texi | 2 +- etc/NEWS.lexbind | 2 +- lisp/ChangeLog | 9 +++ lisp/Makefile.in | 6 +- lisp/cedet/semantic/wisent/comp.el | 3 + lisp/emacs-lisp/byte-opt.el | 16 ++-- lisp/emacs-lisp/bytecomp.el | 162 ++++++++++++------------------------- lisp/emacs-lisp/cconv.el | 8 ++ lisp/emacs-lisp/cl-loaddefs.el | 2 +- lisp/emacs-lisp/cl-macs.el | 2 +- lisp/emacs-lisp/cl.el | 6 +- lisp/emacs-lisp/disass.el | 1 - lisp/emacs-lisp/edebug.el | 2 +- lisp/emacs-lisp/eieio.el | 3 +- lisp/emacs-lisp/lisp-mode.el | 2 +- src/ChangeLog | 5 ++ src/bytecode.c | 41 ++++------ src/callint.c | 4 +- src/eval.c | 15 ++-- src/lisp.h | 3 +- src/lread.c | 33 +++----- src/window.c | 1 + test/automated/lexbind-tests.el | 4 +- 23 files changed, 138 insertions(+), 194 deletions(-) (limited to 'src/bytecode.c') diff --git a/doc/lispref/variables.texi b/doc/lispref/variables.texi index fad76ed39f8..7e2c32334a4 100644 --- a/doc/lispref/variables.texi +++ b/doc/lispref/variables.texi @@ -1137,7 +1137,7 @@ by @code{funcall}, and they are represented by a cons cell whose @code{car} is the symbol @code{closure}. @menu -* Converting to Lexical Binding:: How to start using lexical scoping +* Converting to Lexical Binding:: How to start using lexical scoping @end menu @node Converting to Lexical Binding diff --git a/etc/NEWS.lexbind b/etc/NEWS.lexbind index de5d9a07715..a55b8e38dcf 100644 --- a/etc/NEWS.lexbind +++ b/etc/NEWS.lexbind @@ -17,7 +17,7 @@ It is typically set via file-local variables, in which case it applies to all the code in that file. ** Lexically scoped interpreted functions are represented with a new form -of function value which looks like (closure ENV lambda ARGS &rest BODY). +of function value which looks like (closure ENV ARGS &rest BODY). ** New macro `letrec' to define recursive local functions. ---------------------------------------------------------------------- diff --git a/lisp/ChangeLog b/lisp/ChangeLog index b517c48738f..f977b976c4b 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,12 @@ +2011-04-01 Stefan Monnier + + * emacs-lisp/bytecomp.el (byte-compile-single-version) + (byte-compile-version-cond, byte-compile-delay-out) + (byte-compile-delayed-out): Remove, unused. + + * emacs-lisp/byte-opt.el (byte-optimize-form-code-walker): + Remove debug statement. + 2011-03-30 Stefan Monnier * subr.el (apply-partially): Use a non-nil static environment. diff --git a/lisp/Makefile.in b/lisp/Makefile.in index ab82c99ac33..083f312d613 100644 --- a/lisp/Makefile.in +++ b/lisp/Makefile.in @@ -206,8 +206,8 @@ compile-onefile: @echo Compiling $(THEFILE) @# Use byte-compile-refresh-preloaded to try and work around some of @# the most common bootstrapping problems. - @$(emacs) $(BYTE_COMPILE_FLAGS) -l bytecomp \ - -f byte-compile-refresh-preloaded \ + @$(emacs) $(BYTE_COMPILE_FLAGS) \ + -l bytecomp -f byte-compile-refresh-preloaded \ -f batch-byte-compile $(THEFILE) # Files MUST be compiled one by one. If we compile several files in a @@ -292,7 +292,7 @@ compile-always: doit compile-calc: for el in $(lisp)/calc/*.el; do \ echo Compiling $$el; \ - $(emacs) $(BYTE_COMPILE_FLAGS) -f batch-byte-compile $$el || exit 1; \ + $(emacs) $(BYTE_COMPILE_FLAGS) -f batch-byte-compile $$el || exit 1;\ done # Backup compiled Lisp files in elc.tar.gz. If that file already diff --git a/lisp/cedet/semantic/wisent/comp.el b/lisp/cedet/semantic/wisent/comp.el index 6b473f9ad81..f92ae88c14e 100644 --- a/lisp/cedet/semantic/wisent/comp.el +++ b/lisp/cedet/semantic/wisent/comp.el @@ -3484,6 +3484,9 @@ Automatically called by the Emacs Lisp byte compiler as a (macroexpand-all (wisent-automaton-lisp-form (eval form))))) +;; FIXME: We shouldn't use a `byte-compile' handler. Maybe using a hash-table +;; instead of an obarray would work around the problem that obarrays +;; aren't printable. Then (put 'wisent-compile-grammar 'side-effect-free t). (put 'wisent-compile-grammar 'byte-compile 'wisent-byte-compile-grammar) (defun wisent-automaton-lisp-form (automaton) diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 35c9a5ddf45..548fcd133df 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -534,7 +534,6 @@ (cons fn (mapcar #'byte-optimize-form (cdr form)))) ((not (symbolp fn)) - (debug) (byte-compile-warn "`%s' is a malformed function" (prin1-to-string fn)) form) @@ -1455,8 +1454,7 @@ byte-cdr-safe byte-cons byte-list1 byte-list2 byte-point byte-point-max byte-point-min byte-following-char byte-preceding-char byte-current-column byte-eolp byte-eobp byte-bolp byte-bobp - byte-current-buffer byte-stack-ref ;; byte-closed-var - )) + byte-current-buffer byte-stack-ref)) (defconst byte-compile-side-effect-free-ops (nconc @@ -2029,7 +2027,7 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (+ (cdr lap0) (cdr lap1)))) (setq lap (delq lap0 lap)) (setcdr lap1 (+ (cdr lap1) (cdr lap0)))) - + ;; ;; stack-set-M [discard/discardN ...] --> discardN-preserve-tos ;; stack-set-M [discard/discardN ...] --> discardN @@ -2053,10 +2051,9 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (setq lap (delq lap0 lap)) (setcar lap1 (if (= tmp2 tmp3) - ;; The value stored is the new TOS, so pop - ;; one more value (to get rid of the old - ;; value) using the TOS-preserving - ;; discard operator. + ;; The value stored is the new TOS, so pop one more + ;; value (to get rid of the old value) using the + ;; TOS-preserving discard operator. 'byte-discardN-preserve-tos ;; Otherwise, the value stored is lost, so just use a ;; normal discard. @@ -2071,8 +2068,7 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; discardN-(X+Y) ;; ((and (memq (car lap0) - '(byte-discard - byte-discardN + '(byte-discard byte-discardN byte-discardN-preserve-tos)) (memq (car lap1) '(byte-discard byte-discardN))) (setq lap (delq lap0 lap)) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 5e671d7e694..7d259cda574 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -128,10 +128,6 @@ ;; The feature of compiling in a specific target Emacs version ;; has been turned off because compile time options are a bad idea. -(defmacro byte-compile-single-version () nil) -(defmacro byte-compile-version-cond (cond) cond) - - (defgroup bytecomp nil "Emacs Lisp byte-compiler." :group 'lisp) @@ -404,9 +400,7 @@ specify different fields to sort on." :type '(choice (const name) (const callers) (const calls) (const calls+callers) (const nil))) -(defvar byte-compile-debug t) -(setq debug-on-error t) - +(defvar byte-compile-debug nil) (defvar byte-compile-constants nil "List of all constants encountered during compilation of this form.") (defvar byte-compile-variables nil @@ -465,7 +459,7 @@ Used for warnings about calling a function that is defined during compilation but won't necessarily be defined when the compiled file is loaded.") ;; Variables for lexical binding -(defvar byte-compile-lexical-environment nil +(defvar byte-compile--lexical-environment nil "The current lexical environment.") (defvar byte-compile-tag-number 0) @@ -586,6 +580,7 @@ Each element is (INDEX . VALUE)") (byte-defop 114 0 byte-save-current-buffer "To make a binding to record the current buffer") (byte-defop 115 0 byte-set-mark-OBSOLETE) +;; (byte-defop 116 1 byte-interactive-p) ;Let's not use it any more. ;; These ops are new to v19 (byte-defop 117 0 byte-forward-char) @@ -621,6 +616,8 @@ otherwise pop it") (byte-defop 138 0 byte-save-excursion "to make a binding to record the buffer, point and mark") +;; (byte-defop 139 0 byte-save-window-excursion ; Obsolete: It's a macro now. +;; "to make a binding to record entire window configuration") (byte-defop 140 0 byte-save-restriction "to make a binding to record the current buffer clipping restrictions") (byte-defop 141 -1 byte-catch @@ -632,16 +629,8 @@ otherwise pop it") ;; an expression for the body, and a list of clauses. (byte-defop 143 -2 byte-condition-case) -;; For entry to with-output-to-temp-buffer. -;; Takes, on stack, the buffer name. -;; Binds standard-output and does some other things. -;; Returns with temp buffer on the stack in place of buffer name. +;; Obsolete: `with-output-to-temp-buffer' is a macro now. ;; (byte-defop 144 0 byte-temp-output-buffer-setup) - -;; For exit from with-output-to-temp-buffer. -;; Expects the temp buffer on the stack underneath value to return. -;; Pops them both, then pushes the value back on. -;; Unbinds standard-output and makes the temp buffer visible. ;; (byte-defop 145 -1 byte-temp-output-buffer-show) ;; these ops are new to v19 @@ -675,15 +664,14 @@ otherwise pop it") (byte-defop 168 0 byte-integerp) ;; unused: 169-174 - (byte-defop 175 nil byte-listN) (byte-defop 176 nil byte-concatN) (byte-defop 177 nil byte-insertN) -(byte-defop 178 -1 byte-stack-set) ; stack offset in following one byte -(byte-defop 179 -1 byte-stack-set2) ; stack offset in following two bytes +(byte-defop 178 -1 byte-stack-set) ; Stack offset in following one byte. +(byte-defop 179 -1 byte-stack-set2) ; Stack offset in following two bytes. -;; if (following one byte & 0x80) == 0 +;; If (following one byte & 0x80) == 0 ;; discard (following one byte & 0x7F) stack entries ;; else ;; discard (following one byte & 0x7F) stack entries _underneath_ TOS @@ -776,12 +764,6 @@ CONST2 may be evaulated multiple times." (error "Non-symbolic opcode `%s'" op)) ((eq op 'TAG) (setcar off pc)) - ((null op) - ;; a no-op added by `byte-compile-delay-out' - (unless (zerop off) - (error - "Placeholder added by `byte-compile-delay-out' not filled in.") - )) (t (setq opcode (if (eq op 'byte-discardN-preserve-tos) @@ -793,13 +775,13 @@ CONST2 may be evaulated multiple times." (cond ((memq op byte-goto-ops) ;; goto (byte-compile-push-bytecodes opcode nil (cdr off) bytes pc) - (push bytes patchlist)) + (push bytes patchlist)) ((or (and (consp off) ;; Variable or constant reference (progn (setq off (cdr off)) (eq op 'byte-constant))) - (and (eq op 'byte-constant) ;; 'byte-closed-var + (and (eq op 'byte-constant) (integerp off))) ;; constant ref (if (< off byte-constant-limit) @@ -847,10 +829,9 @@ CONST2 may be evaulated multiple times." bytes pc)))))) ;;(if (not (= pc (length bytes))) ;; (error "Compiler error: pc mismatch - %s %s" pc (length bytes))) - - ;; Patch tag PCs into absolute jumps + ;; Patch tag PCs into absolute jumps. (dolist (bytes-tail patchlist) - (setq pc (caar bytes-tail)) ; Pick PC from goto's tag + (setq pc (caar bytes-tail)) ; Pick PC from goto's tag. (setcar (cdr bytes-tail) (logand pc 255)) (setcar bytes-tail (lsh pc -8)) ;; FIXME: Replace this by some workaround. @@ -1861,10 +1842,10 @@ With argument ARG, insert value in current buffer after the form." ;; Dynamically bound in byte-compile-from-buffer. ;; NB also used in cl.el and cl-macs.el. -(defvar byte-compile-outbuffer) +(defvar byte-compile--outbuffer) (defun byte-compile-from-buffer (inbuffer) - (let (byte-compile-outbuffer + (let (byte-compile--outbuffer (byte-compile-current-buffer inbuffer) (byte-compile-read-position nil) (byte-compile-last-position nil) @@ -1893,7 +1874,8 @@ With argument ARG, insert value in current buffer after the form." ) (byte-compile-close-variables (with-current-buffer - (setq byte-compile-outbuffer (get-buffer-create " *Compiler Output*")) + (setq byte-compile--outbuffer + (get-buffer-create " *Compiler Output*")) (set-buffer-multibyte t) (erase-buffer) ;; (emacs-lisp-mode) @@ -1902,7 +1884,7 @@ With argument ARG, insert value in current buffer after the form." (with-current-buffer inbuffer (and byte-compile-current-file (byte-compile-insert-header byte-compile-current-file - byte-compile-outbuffer)) + byte-compile--outbuffer)) (goto-char (point-min)) ;; Should we always do this? When calling multiple files, it ;; would be useful to delay this warning until all have been @@ -1935,9 +1917,9 @@ and will be removed soon. See (elisp)Backquote in the manual.")) ;; Fix up the header at the front of the output ;; if the buffer contains multibyte characters. (and byte-compile-current-file - (with-current-buffer byte-compile-outbuffer + (with-current-buffer byte-compile--outbuffer (byte-compile-fix-header byte-compile-current-file))))) - byte-compile-outbuffer)) + byte-compile--outbuffer)) (defun byte-compile-fix-header (filename) "If the current buffer has any multibyte characters, insert a version test." @@ -2046,8 +2028,8 @@ Call from the source buffer." (print-gensym t) (print-circle ; handle circular data structures (not byte-compile-disable-print-circle))) - (princ "\n" byte-compile-outbuffer) - (prin1 form byte-compile-outbuffer) + (princ "\n" byte-compile--outbuffer) + (prin1 form byte-compile--outbuffer) nil))) (defvar print-gensym-alist) ;Used before print-circle existed. @@ -2067,7 +2049,7 @@ list that represents a doc string reference. ;; We need to examine byte-compile-dynamic-docstrings ;; in the input buffer (now current), not in the output buffer. (let ((dynamic-docstrings byte-compile-dynamic-docstrings)) - (with-current-buffer byte-compile-outbuffer + (with-current-buffer byte-compile--outbuffer (let (position) ;; Insert the doc string, and make it a comment with #@LENGTH. @@ -2091,7 +2073,7 @@ list that represents a doc string reference. (if preface (progn (insert preface) - (prin1 name byte-compile-outbuffer))) + (prin1 name byte-compile--outbuffer))) (insert (car info)) (let ((print-escape-newlines t) (print-quoted t) @@ -2106,7 +2088,7 @@ list that represents a doc string reference. (print-continuous-numbering t) print-number-table (index 0)) - (prin1 (car form) byte-compile-outbuffer) + (prin1 (car form) byte-compile--outbuffer) (while (setq form (cdr form)) (setq index (1+ index)) (insert " ") @@ -2129,21 +2111,22 @@ list that represents a doc string reference. (setq position (- (position-bytes position) (point-min) -1)) (princ (format "(#$ . %d) nil" position) - byte-compile-outbuffer) + byte-compile--outbuffer) (setq form (cdr form)) (setq index (1+ index)))) ((= index (nth 1 info)) (if position (princ (format (if quoted "'(#$ . %d)" "(#$ . %d)") position) - byte-compile-outbuffer) + byte-compile--outbuffer) (let ((print-escape-newlines nil)) (goto-char (prog1 (1+ (point)) - (prin1 (car form) byte-compile-outbuffer))) + (prin1 (car form) + byte-compile--outbuffer))) (insert "\\\n") (goto-char (point-max))))) (t - (prin1 (car form) byte-compile-outbuffer))))) + (prin1 (car form) byte-compile--outbuffer))))) (insert (nth 2 info))))) nil) @@ -2428,7 +2411,7 @@ by side-effects." ;; Remove declarations from the body of the macro definition. (when macrop (dolist (decl (byte-compile-defmacro-declaration form)) - (prin1 decl byte-compile-outbuffer))) + (prin1 decl byte-compile--outbuffer))) (let* ((code (byte-compile-lambda (nthcdr 2 form) t))) (if this-one @@ -2458,7 +2441,7 @@ by side-effects." (and (atom code) byte-compile-dynamic 1) nil)) - (princ ")" byte-compile-outbuffer) + (princ ")" byte-compile--outbuffer) nil))) ;; Print Lisp object EXP in the output file, inside a comment, @@ -2466,13 +2449,13 @@ by side-effects." ;; If QUOTED is non-nil, print with quoting; otherwise, print without quoting. (defun byte-compile-output-as-comment (exp quoted) (let ((position (point))) - (with-current-buffer byte-compile-outbuffer + (with-current-buffer byte-compile--outbuffer ;; Insert EXP, and make it a comment with #@LENGTH. (insert " ") (if quoted - (prin1 exp byte-compile-outbuffer) - (princ exp byte-compile-outbuffer)) + (prin1 exp byte-compile--outbuffer) + (princ exp byte-compile--outbuffer)) (goto-char position) ;; Quote certain special characters as needed. ;; get_doc_string in doc.c does the unquoting. @@ -2732,7 +2715,7 @@ If FORM is a lambda or a macro, byte-compile it as a function." (byte-compile-tag-number 0) (byte-compile-depth 0) (byte-compile-maxdepth 0) - (byte-compile-lexical-environment lexenv) + (byte-compile--lexical-environment lexenv) (byte-compile-reserved-constants (or reserved-csts 0)) (byte-compile-output nil)) (if (memq byte-optimize '(t source)) @@ -2743,7 +2726,7 @@ If FORM is a lambda or a macro, byte-compile it as a function." (when (and lexical-binding (eq output-type 'lambda)) ;; See how many arguments there are, and set the current stack depth ;; accordingly. - (setq byte-compile-depth (length byte-compile-lexical-environment)) + (setq byte-compile-depth (length byte-compile--lexical-environment)) ;; If there are args, output a tag to record the initial ;; stack-depth for the optimizer. (when (> byte-compile-depth 0) @@ -2789,7 +2772,6 @@ If FORM is a lambda or a macro, byte-compile it as a function." ;; progn -> as <> or (progn <> atom) ;; file -> as progn, but takes both quotes and atoms, and longer forms. (let (rest - (byte-compile--for-effect for-effect) ;FIXME: Probably unused! (maycall (not (eq output-type 'lambda))) ; t if we may make a funcall. tmp body) (cond @@ -2975,6 +2957,7 @@ That command is designed for interactive use only" fn)) (byte-compile-out-tag endtag))) (defun byte-compile-unfold-bcf (form) + "Inline call to byte-code-functions." (let* ((byte-compile-bound-variables byte-compile-bound-variables) (fun (car form)) (fargs (aref fun 0)) @@ -3056,7 +3039,7 @@ If BINDING is non-nil, VAR is being bound." (defun byte-compile-variable-ref (var) "Generate code to push the value of the variable VAR on the stack." (byte-compile-check-variable var) - (let ((lex-binding (assq var byte-compile-lexical-environment))) + (let ((lex-binding (assq var byte-compile--lexical-environment))) (if lex-binding ;; VAR is lexically bound (byte-compile-stack-ref (cdr lex-binding)) @@ -3072,7 +3055,7 @@ If BINDING is non-nil, VAR is being bound." (defun byte-compile-variable-set (var) "Generate code to set the variable VAR from the top-of-stack value." (byte-compile-check-variable var) - (let ((lex-binding (assq var byte-compile-lexical-environment))) + (let ((lex-binding (assq var byte-compile--lexical-environment))) (if lex-binding ;; VAR is lexically bound (byte-compile-stack-set (cdr lex-binding)) @@ -3181,6 +3164,7 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (byte-defop-compiler bobp 0) (byte-defop-compiler current-buffer 0) ;;(byte-defop-compiler read-char 0) ;; obsolete +;; (byte-defop-compiler interactive-p 0) ;; Obsolete. (byte-defop-compiler widen 0) (byte-defop-compiler end-of-line 0-1) (byte-defop-compiler forward-char 0-1) @@ -3355,6 +3339,7 @@ discarding." (defconst byte-compile--env-var (make-symbol "env")) (defun byte-compile-make-closure (form) + "Byte-compile the special `internal-make-closure' form." (if byte-compile--for-effect (setq byte-compile--for-effect nil) (let* ((vars (nth 1 form)) (env (nth 2 form)) @@ -3366,12 +3351,11 @@ discarding." ',(aref fun 0) ',(aref fun 1) (vconcat (vector . ,env) ',(aref fun 2)) ,@(nthcdr 3 (mapcar (lambda (x) `',x) fun))))))) - (defun byte-compile-get-closed-var (form) + "Byte-compile the special `internal-get-closed-var' form." (if byte-compile--for-effect (setq byte-compile--for-effect nil) - (byte-compile-out 'byte-constant ;; byte-closed-var - (nth 1 form)))) + (byte-compile-out 'byte-constant (nth 1 form)))) ;; Compile a function that accepts one or more args and is right-associative. ;; We do it by left-associativity so that the operations @@ -3856,7 +3840,7 @@ Return the offset in the form (VAR . OFFSET)." (keywordp var))) (defun byte-compile-bind (var init-lexenv) - "Emit byte-codes to bind VAR and update `byte-compile-lexical-environment'. + "Emit byte-codes to bind VAR and update `byte-compile--lexical-environment'. INIT-LEXENV should be a lexical-environment alist describing the positions of the init value that have been pushed on the stack. Return non-nil if the TOS value was popped." @@ -3866,7 +3850,7 @@ Return non-nil if the TOS value was popped." (cond ((not (byte-compile-not-lexical-var-p var)) ;; VAR is a simple stack-allocated lexical variable (push (assq var init-lexenv) - byte-compile-lexical-environment) + byte-compile--lexical-environment) nil) ((eq var (caar init-lexenv)) ;; VAR is dynamic and is on the top of the @@ -3898,7 +3882,7 @@ binding slots have been popped." (let ((num-dynamic-bindings 0)) (dolist (clause clauses) (unless (assq (if (consp clause) (car clause) clause) - byte-compile-lexical-environment) + byte-compile--lexical-environment) (setq num-dynamic-bindings (1+ num-dynamic-bindings)))) (unless (zerop num-dynamic-bindings) (byte-compile-out 'byte-unbind num-dynamic-bindings))) @@ -3918,7 +3902,8 @@ binding slots have been popped." (push (byte-compile-push-binding-init var) init-lexenv))) ;; New scope. (let ((byte-compile-bound-variables byte-compile-bound-variables) - (byte-compile-lexical-environment byte-compile-lexical-environment)) + (byte-compile--lexical-environment + byte-compile--lexical-environment)) ;; Bind the variables. ;; For `let', do it in reverse order, because it makes no ;; semantic difference, but it is a lot more efficient since the @@ -3969,7 +3954,6 @@ binding slots have been popped." "Compiler error: `%s' has no `byte-compile-negated-op' property" (car form))) (cdr form)))) - ;;; other tricky macro-like special-forms @@ -3979,6 +3963,8 @@ binding slots have been popped." (byte-defop-compiler-1 save-excursion) (byte-defop-compiler-1 save-current-buffer) (byte-defop-compiler-1 save-restriction) +;; (byte-defop-compiler-1 save-window-excursion) ;Obsolete: now a macro. +;; (byte-defop-compiler-1 with-output-to-temp-buffer) ;Obsolete: now a macro. (byte-defop-compiler-1 track-mouse) (defun byte-compile-catch (form) @@ -4286,7 +4272,7 @@ OP and OPERAND are as passed to `byte-compile-out'." ;; that take OPERAND values off the stack and push a result, for ;; a total of 1 - OPERAND (- 1 operand)))) - + (defun byte-compile-out (op &optional operand) (push (cons op operand) byte-compile-output) (if (eq op 'byte-return) @@ -4298,50 +4284,6 @@ OP and OPERAND are as passed to `byte-compile-out'." (setq byte-compile-maxdepth (max byte-compile-depth byte-compile-maxdepth)) ;;(if (< byte-compile-depth 0) (error "Compiler error: stack underflow")) )) - -(defun byte-compile-delay-out (&optional stack-used stack-adjust) - "Add a placeholder to the output, which can be used to later add byte-codes. -Return a position tag that can be passed to `byte-compile-delayed-out' -to add the delayed byte-codes. STACK-USED is the maximum amount of -stack-spaced used by the delayed byte-codes (defaulting to 0), and -STACK-ADJUST is the amount by which the later-added code will adjust the -stack (defaulting to 0); the byte-codes added later _must_ adjust the -stack by this amount! If STACK-ADJUST is 0, then it's not necessary to -actually add anything later; the effect as if nothing was added at all." - ;; We just add a no-op to `byte-compile-output', and return a pointer to - ;; the tail of the list; `byte-compile-delayed-out' uses list surgery - ;; to add the byte-codes. - (when stack-used - (setq byte-compile-maxdepth - (max byte-compile-depth (+ byte-compile-depth (or stack-used 0))))) - (when stack-adjust - (setq byte-compile-depth - (+ byte-compile-depth stack-adjust))) - (push (cons nil (or stack-adjust 0)) byte-compile-output)) - -(defun byte-compile-delayed-out (position op &optional operand) - "Add at POSITION the byte-operation OP, with optional numeric arg OPERAND. -POSITION should a position returned by `byte-compile-delay-out'. -Return a new position, which can be used to add further operations." - (unless (null (caar position)) - (error "Bad POSITION arg to `byte-compile-delayed-out'")) - ;; This is kind of like `byte-compile-out', but we splice into the list - ;; where POSITION is. We don't bother updating `byte-compile-maxdepth' - ;; because that was already done by `byte-compile-delay-out', but we do - ;; update the relative operand stored in the no-op marker currently at - ;; POSITION; since we insert before that marker, this means that if the - ;; caller doesn't insert a sequence of byte-codes that matches the expected - ;; operand passed to `byte-compile-delay-out', then the nop will still have - ;; a non-zero operand when `byte-compile-lapcode' is called, which will - ;; cause an error to be signaled. - - ;; Adjust the cumulative stack-adjustment stored in the cdr of the no-op - (setcdr (car position) - (- (cdar position) (byte-compile-stack-adjustment op operand))) - ;; Add the new operation onto the list tail at POSITION - (setcdr position (cons (cons op operand) (cdr position))) - position) - ;;; call tree stuff diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index 46d14880a2c..5cc9ecb4cf7 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -67,15 +67,23 @@ ;; TODO: (not just for cconv but also for the lexbind changes in general) ;; - let (e)debug find the value of lexical variables from the stack. +;; - make eval-region do the eval-sexp-add-defvars danse. ;; - byte-optimize-form should be applied before cconv. ;; OTOH, the warnings emitted by cconv-analyze need to come before optimize ;; since afterwards they can because obnoxious (warnings about an "unused ;; variable" should not be emitted when the variable use has simply been ;; optimized away). +;; - turn defun and defmacro into macros (and remove special handling of +;; `declare' afterwards). +;; - let macros specify that some let-bindings come from the same source, +;; so the unused warning takes all uses into account. +;; - let interactive specs return a function to build the args (to stash into +;; command-history). ;; - canonize code in macro-expand so we don't have to handle (let (var) body) ;; and other oddities. ;; - new byte codes for unwind-protect, catch, and condition-case so that ;; closures aren't needed at all. +;; - inline source code of different binding mode by first compiling it. ;; - a reference to a var that is known statically to always hold a constant ;; should be turned into a byte-constant rather than a byte-stack-ref. ;; Hmm... right, that's called constant propagation and could be done here, diff --git a/lisp/emacs-lisp/cl-loaddefs.el b/lisp/emacs-lisp/cl-loaddefs.el index 8bcbd67f46b..4c824d4a6d4 100644 --- a/lisp/emacs-lisp/cl-loaddefs.el +++ b/lisp/emacs-lisp/cl-loaddefs.el @@ -282,7 +282,7 @@ Not documented ;;;;;; flet progv psetq do-all-symbols do-symbols dotimes dolist ;;;;;; do* do loop return-from return block etypecase typecase ecase ;;;;;; case load-time-value eval-when destructuring-bind function* -;;;;;; defmacro* defun* gentemp gensym) "cl-macs" "cl-macs.el" "c4734fbda33043d967624d39d80c3304") +;;;;;; defmacro* defun* gentemp gensym) "cl-macs" "cl-macs.el" "fe8a5acbe14e32846a77578b2165fab5") ;;; Generated autoloads from cl-macs.el (autoload 'gensym "cl-macs" "\ diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 7aac5bdaa01..9ce3dd6a7fe 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -497,7 +497,7 @@ The result of the body appears to the compiler as a quoted constant." (symbol-function 'byte-compile-file-form))) (list 'byte-compile-file-form (list 'quote set)) '(byte-compile-file-form form))) - (print set (symbol-value 'byte-compile-outbuffer))) + (print set (symbol-value 'byte-compile--outbuffer))) (list 'symbol-value (list 'quote temp))) (list 'quote (eval form)))) diff --git a/lisp/emacs-lisp/cl.el b/lisp/emacs-lisp/cl.el index 9c626dfcfa3..526475eb1bd 100644 --- a/lisp/emacs-lisp/cl.el +++ b/lisp/emacs-lisp/cl.el @@ -278,9 +278,9 @@ definitions to shadow the loaded ones for use in file byte-compilation. (defvar cl-compiling-file nil) (defun cl-compiling-file () (or cl-compiling-file - (and (boundp 'byte-compile-outbuffer) - (bufferp (symbol-value 'byte-compile-outbuffer)) - (equal (buffer-name (symbol-value 'byte-compile-outbuffer)) + (and (boundp 'byte-compile--outbuffer) + (bufferp (symbol-value 'byte-compile--outbuffer)) + (equal (buffer-name (symbol-value 'byte-compile--outbuffer)) " *Compiler Output*")))) (defvar cl-proclaims-deferred nil) diff --git a/lisp/emacs-lisp/disass.el b/lisp/emacs-lisp/disass.el index 9318876fe61..4fd10185c17 100644 --- a/lisp/emacs-lisp/disass.el +++ b/lisp/emacs-lisp/disass.el @@ -72,7 +72,6 @@ redefine OBJECT if it is a symbol." (let ((macro 'nil) (name 'nil) (doc 'nil) - (lexical-binding nil) args) (while (symbolp obj) (setq name obj diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 8135b5c4f24..f84de0308bf 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -3640,7 +3640,7 @@ Return the result of the last expression." (eval (if (bound-and-true-p cl-debug-env) (cl-macroexpand-all edebug-expr cl-debug-env) edebug-expr) - lexical-binding)) ;; FIXME: lexbind. + lexical-binding)) (defun edebug-safe-eval (edebug-expr) ;; Evaluate EXPR safely. diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index 4e443452d8b..7a119e6bbc0 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -96,6 +96,7 @@ default setting for optimization purposes.") "Non-nil means to optimize the method dispatch on primary methods.") ;; State Variables +;; FIXME: These two constants below should have an `eieio-' prefix added!! (defvar this nil "Inside a method, this variable is the object in question. DO NOT SET THIS YOURSELF unless you are trying to simulate friendly slots. @@ -122,7 +123,7 @@ execute a `call-next-method'. DO NOT SET THIS YOURSELF!") ;; while it is being built itself. (defvar eieio-default-superclass nil) -;; FIXME: The constants below should have a `eieio-' prefix added!! +;; FIXME: The constants below should have an `eieio-' prefix added!! (defconst class-symbol 1 "Class's symbol (self-referencing.).") (defconst class-parent 2 "Class parent slot.") (defconst class-children 3 "Class children class slot.") diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index 408774fbbf1..39bdb505039 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -745,7 +745,7 @@ POS specifies the starting position where EXP was found and defaults to point." (unless (special-variable-p var) (push var vars)))) `(progn ,@(mapcar (lambda (v) `(defvar ,v)) vars) ,exp))))) - + (defun eval-last-sexp (eval-last-sexp-arg-internal) "Evaluate sexp before point; print value in minibuffer. Interactively, with prefix argument, print output into current buffer. diff --git a/src/ChangeLog b/src/ChangeLog index e34cd694321..04064adbaa3 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,8 @@ +2011-04-01 Stefan Monnier + + * bytecode.c (Fbyte_code): Revert to old calling convention. + * lisp.h (COMPILED_PUSH_ARGS): Remove, unused. + 2011-03-16 Stefan Monnier * image.c (parse_image_spec): Use Ffunctionp. diff --git a/src/bytecode.c b/src/bytecode.c index 01ae8055ebf..5d94cb0fb39 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -51,7 +51,7 @@ by Hallvard: * * define BYTE_CODE_METER to enable generation of a byte-op usage histogram. */ -#define BYTE_CODE_SAFE 1 +/* #define BYTE_CODE_SAFE */ /* #define BYTE_CODE_METER */ @@ -160,7 +160,7 @@ extern Lisp_Object Qand_optional, Qand_rest; #ifdef BYTE_CODE_SAFE #define Bset_mark 0163 /* this loser is no longer generated as of v18 */ #endif -#define Binteractive_p 0164 /* Obsolete. */ +#define Binteractive_p 0164 /* Obsolete since Emacs-24.1. */ #define Bforward_char 0165 #define Bforward_word 0166 @@ -185,16 +185,16 @@ extern Lisp_Object Qand_optional, Qand_rest; #define Bdup 0211 #define Bsave_excursion 0212 -#define Bsave_window_excursion 0213 /* Obsolete. */ +#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 /* Obsolete. */ -#define Btemp_output_buffer_show 0221 /* Obsolete. */ +#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 /* Obsolete. */ +#define Bunbind_all 0222 /* Obsolete. Never used. */ #define Bset_marker 0223 #define Bmatch_beginning 0224 @@ -413,24 +413,15 @@ unmark_byte_stack (void) } while (0) -DEFUN ("byte-code", Fbyte_code, Sbyte_code, 3, MANY, 0, +DEFUN ("byte-code", Fbyte_code, Sbyte_code, 3, 3, 0, doc: /* Function used internally in byte-compiled code. The first argument, BYTESTR, is a string of byte code; the second, VECTOR, a vector of constants; the third, MAXDEPTH, the maximum stack depth used in this function. -If the third argument is incorrect, Emacs may crash. - -If ARGS-TEMPLATE is specified, it is an argument list specification, -according to which any remaining arguments are pushed on the stack -before executing BYTESTR. - -usage: (byte-code BYTESTR VECTOR MAXDEP &optional ARGS-TEMPLATE &rest ARGS) */) - (size_t nargs, Lisp_Object *args) +If the third argument is incorrect, Emacs may crash. */) + (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth) { - Lisp_Object args_tmpl = nargs >= 4 ? args[3] : Qnil; - int pnargs = nargs >= 4 ? nargs - 4 : 0; - Lisp_Object *pargs = nargs >= 4 ? args + 4 : 0; - return exec_byte_code (args[0], args[1], args[2], args_tmpl, pnargs, pargs); + return exec_byte_code (bytestr, vector, maxdepth, Qnil, 0, NULL); } /* Execute the byte-code in BYTESTR. VECTOR is the constant vector, and @@ -810,7 +801,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, AFTER_POTENTIAL_GC (); break; - case Bunbind_all: /* Obsolete. */ + 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 (); @@ -938,12 +929,12 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, save_excursion_save ()); break; - case Bsave_current_buffer: /* Obsolete. */ + 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: /* Obsolete. */ + case Bsave_window_excursion: /* Obsolete since 24.1. */ { register int count = SPECPDL_INDEX (); record_unwind_protect (Fset_window_configuration, @@ -985,7 +976,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, break; } - case Btemp_output_buffer_setup: /* Obsolete. */ + case Btemp_output_buffer_setup: /* Obsolete since 24.1. */ BEFORE_POTENTIAL_GC (); CHECK_STRING (TOP); temp_output_buffer_setup (SSDATA (TOP)); @@ -993,7 +984,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, TOP = Vstandard_output; break; - case Btemp_output_buffer_show: /* Obsolete. */ + case Btemp_output_buffer_show: /* Obsolete since 24.1. */ { Lisp_Object v1; BEFORE_POTENTIAL_GC (); @@ -1465,7 +1456,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, AFTER_POTENTIAL_GC (); break; - case Binteractive_p: /* Obsolete. */ + case Binteractive_p: /* Obsolete since 24.1. */ PUSH (Finteractive_p ()); break; diff --git a/src/callint.c b/src/callint.c index 489fa392e46..60570369d9e 100644 --- a/src/callint.c +++ b/src/callint.c @@ -171,8 +171,8 @@ 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 that will re-build the args - without user intervention. */ + interactive spec to return an expression/function that will re-build the + args without user intervention. */ if (CONSP (input)) { Lisp_Object car; diff --git a/src/eval.c b/src/eval.c index 9f90e6df4b5..0e47d7c757c 100644 --- a/src/eval.c +++ b/src/eval.c @@ -117,10 +117,10 @@ Lisp_Object Vsignaling_function; int handling_signal; -static Lisp_Object apply_lambda (Lisp_Object fun, Lisp_Object args); 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 fun, Lisp_Object args); void init_eval_once (void) @@ -684,7 +684,7 @@ usage: (defmacro NAME ARGLIST [DOCSTRING] [DECL] BODY...) */) tail = Fcons (lambda_list, tail); else tail = Fcons (lambda_list, Fcons (doc, tail)); - + defn = Fcons (Qlambda, tail); if (!NILP (Vinternal_interpreter_environment)) /* Mere optimization! */ defn = Ffunction (Fcons (defn, Qnil)); @@ -1012,11 +1012,8 @@ usage: (let* VARLIST BODY...) */) varlist = XCDR (varlist); } - UNGCPRO; - val = Fprogn (Fcdr (args)); - return unbind_to (count, val); } @@ -2083,7 +2080,8 @@ then strings and vectors are not accepted. */) return Qnil; funcar = XCAR (fun); if (EQ (funcar, Qclosure)) - return !NILP (Fassq (Qinteractive, Fcdr (Fcdr (XCDR (fun))))) ? Qt : if_prop; + 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; else if (EQ (funcar, Qautoload)) @@ -2898,7 +2896,7 @@ 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: /* Return non-nil if OBJECT is a type of object that can be called as a function. */) + doc: /* Non-nil if OBJECT is a function. */) (Lisp_Object object) { if (SYMBOLP (object) && !NILP (Ffboundp (object))) @@ -3220,7 +3218,7 @@ funcall_lambda (Lisp_Object fun, size_t nargs, 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. */ @@ -3501,7 +3499,6 @@ context where binding is lexical by default. */) } - 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. The debugger is entered when that frame exits, if the flag is non-nil. */) diff --git a/src/lisp.h b/src/lisp.h index bd70dcebbdb..580dbd11013 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -1483,7 +1483,6 @@ typedef unsigned char UCHAR; #define COMPILED_STACK_DEPTH 3 #define COMPILED_DOC_STRING 4 #define COMPILED_INTERACTIVE 5 -#define COMPILED_PUSH_ARGS 6 /* Flag bits in a character. These also get used in termhooks.h. Richard Stallman thinks that MULE @@ -3264,7 +3263,7 @@ extern int read_bytecode_char (int); /* Defined in bytecode.c */ extern Lisp_Object Qbytecode; -EXFUN (Fbyte_code, MANY); +EXFUN (Fbyte_code, 3); extern void syms_of_bytecode (void); extern struct byte_stack *byte_stack_list; #ifdef BYTE_MARK_STACK diff --git a/src/lread.c b/src/lread.c index 24183532527..6a24569f552 100644 --- a/src/lread.c +++ b/src/lread.c @@ -796,16 +796,16 @@ lisp_file_lexically_bound_p (Lisp_Object readcharfun) } 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; \ +#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. */ @@ -834,7 +834,7 @@ lisp_file_lexically_bound_p (Lisp_Object readcharfun) UPDATE_BEG_END_STATE (ch); ch = READCHAR; } - + while (var_end > var && (var_end[-1] == ' ' || var_end[-1] == '\t')) var_end--; @@ -880,7 +880,6 @@ lisp_file_lexically_bound_p (Lisp_Object readcharfun) 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 @@ -1275,7 +1274,6 @@ Return t if the file exists and loads successfully. */) specbind (Qinhibit_file_name_operation, Qnil); load_descriptor_list = Fcons (make_number (fileno (stream)), load_descriptor_list); - specbind (Qload_in_progress, Qt); instream = stream; @@ -1863,11 +1861,9 @@ This function preserves the position of point. */) specbind (Qeval_buffer_list, Fcons (buf, Veval_buffer_list)); specbind (Qstandard_output, tem); - specbind (Qlexical_binding, Qnil); record_unwind_protect (save_excursion_restore, save_excursion_save ()); BUF_TEMP_SET_PT (XBUFFER (buf), BUF_BEGV (XBUFFER (buf))); - if (lisp_file_lexically_bound_p (buf)) - Fset (Qlexical_binding, Qt); + 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); @@ -3336,7 +3332,6 @@ read_vector (Lisp_Object readcharfun, int bytecodeflag) for (i = 0; i < size; i++) { item = Fcar (tem); - /* If `load-force-doc-strings' is t when reading a lazily-loaded bytecode object, the docstring containing the bytecode and constants values must be treated as unibyte and passed to @@ -3394,7 +3389,6 @@ read_vector (Lisp_Object readcharfun, int bytecodeflag) tem = Fcdr (tem); free_cons (otem); } - return vector; } @@ -4024,7 +4018,6 @@ defvar_lisp (struct Lisp_Objfwd *o_fwd, staticpro (address); } - /* Similar but define a variable whose value is the Lisp Object stored at a particular offset in the current kboard object. */ @@ -4470,7 +4463,7 @@ to load. See also `load-dangerous-libraries'. */); 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'. */); + Lisp file read using `load'. */); Fmake_variable_buffer_local (Qlexical_binding); DEFVAR_LISP ("eval-buffer-list", Veval_buffer_list, diff --git a/src/window.c b/src/window.c index 4bd533c22ac..7e40cdff42b 100644 --- a/src/window.c +++ b/src/window.c @@ -3649,6 +3649,7 @@ displaying that buffer. */) return Qnil; } + void temp_output_buffer_show (register Lisp_Object buf) { diff --git a/test/automated/lexbind-tests.el b/test/automated/lexbind-tests.el index 1ff31e2422d..95b8bbe8858 100644 --- a/test/automated/lexbind-tests.el +++ b/test/automated/lexbind-tests.el @@ -3,7 +3,7 @@ ;; Copyright (C) 2011 Free Software Foundation, Inc. ;; Author: Stefan Monnier -;; Keywords: +;; Keywords: ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by @@ -20,7 +20,7 @@ ;;; Commentary: -;; +;; ;;; Code: -- cgit v1.3