* 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.
+2011-02-17 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * 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 <monnier@iro.umontreal.ca>
* emacs-lisp/byte-lexbind.el: Delete.
-;;; -*- 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.
;;
;; 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))
(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)
(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)
(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.
;; 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)))
(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))
;; 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)
(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)))))
(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)))
(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
;; 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)
(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)))
(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)))
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)
(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)))))))
\f
(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)))
;;
;;; 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
-- 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)))
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.
(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
(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)))
(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
(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)
(`(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)
(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))
(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
; 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
(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))
;;;;;; 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" "\
(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))
-;;; -*- 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.
;;
;; 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))))
(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)
+2011-02-17 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * 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 <monnier@iro.umontreal.ca>
* bytecode.c (Bvec_ref, Bvec_set): Remove.
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;
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))
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;
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;
}
}
+EXFUN (Funintern, 2);
+
void
syms_of_eval (void)
{
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);
/* 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;
projects / emacs.git / commitdiff