From b38b1ec071ee9752da53f2485902165fe728e8fa Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 17 Feb 2011 16:19:13 -0500 Subject: [PATCH] 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(-) 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; -- 2.39.5