Rewrite the cconv conversion algorithm, for clarity.

* lisp/emacs-lisp/byte-opt.el (byte-compile-inline-expand): Adjust check for
new byte-code representation.
* lisp/emacs-lisp/cconv.el (cconv--convert-function): Rename from
cconv-closure-convert-function.
(cconv-convert): Rename from cconv-closure-convert-rec.
(cconv--analyse-use): Rename from cconv-analyse-use.
(cconv--analyse-function): Rename from cconv-analyse-function.
(cconv--analyse-use): Change some patterns to silence compiler.
(cconv-convert, cconv--convert-function): Rewrite.
* test/automated/lexbind-tests.el: New file.

6 files changed, 373 insertions, 436 deletions

diff --git a/doc/lispref/ChangeLog b/doc/lispref/ChangeLog
index 2aecc5a6b4b..ab993fe35a2 100644
--- a/doc/lispref/ChangeLog
+++ b/doc/lispref/ChangeLog
@@ -1,34 +1,34 @@
-2011-03-01  Stefan Monnier  <monnier@iro.umontreal.ca>

-

-        * variables.texi (Scope): Mention the availability of lexical scoping.

-        (Lexical Binding): New node.

-        * eval.texi (Eval): Add `eval's new `lexical' arg.

-

-2011-02-25  Stefan Monnier  <monnier@iro.umontreal.ca>

-

-        * 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.

-

-;; Local Variables:

-;; coding: utf-8

-;; End:

-

-  Copyright (C) 2011  Free Software Foundation, Inc.

-

-  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 <http://www.gnu.org/licenses/>.

+2011-03-01  Stefan Monnier  <monnier@iro.umontreal.ca>
+
+        * variables.texi (Scope): Mention the availability of lexical scoping.
+        (Lexical Binding): New node.
+        * eval.texi (Eval): Add `eval's new `lexical' arg.
+
+2011-02-25  Stefan Monnier  <monnier@iro.umontreal.ca>
+
+        * 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.
+
+;; Local Variables:
+;; coding: utf-8
+;; End:
+
+  Copyright (C) 2011  Free Software Foundation, Inc.
+
+  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 <http://www.gnu.org/licenses/>.
diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 70604238117..5e38629461b 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,16 @@
+2011-03-10  Stefan Monnier  <monnier@iro.umontreal.ca>
+
+        * emacs-lisp/cconv.el (cconv--convert-function): Rename from
+        cconv-closure-convert-function.
+        (cconv-convert): Rename from cconv-closure-convert-rec.
+        (cconv--analyse-use): Rename from cconv-analyse-use.
+        (cconv--analyse-function): Rename from cconv-analyse-function.
+        (cconv--analyse-use): Change some patterns to silence compiler.
+        (cconv-convert, cconv--convert-function): Rewrite.
+
+        * emacs-lisp/byte-opt.el (byte-compile-inline-expand): Adjust check for
+        new byte-code representation.
+
 2011-03-06  Stefan Monnier  <monnier@iro.umontreal.ca>
 
         * emacs-lisp/bytecomp.el (byte-compile-arglist-signature):
diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
index 6d6eb68535e..a49218fe02d 100644
--- a/lisp/emacs-lisp/byte-opt.el
+++ b/lisp/emacs-lisp/byte-opt.el
@@ -287,8 +287,7 @@
              ;; 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
+             (not (integerp (aref fn 0)))) ;New lexical byte-code.
         ;; (message "Inlining %S byte-code" name)
         (fetch-bytecode fn)
         (let ((string (aref fn 1)))
diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el
index 5501c13ee4f..741bc7ce74f 100644
--- a/lisp/emacs-lisp/cconv.el
+++ b/lisp/emacs-lisp/cconv.el
@@ -70,7 +70,6 @@
 ;; - 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.
-;; - 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
@@ -81,6 +80,8 @@
 ;; - 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 byte compiler.
+;; - call known non-escaping functions with gotos rather than `call'.
+;; - optimize mapcar to a while loop.
 
 ;; (defmacro dlet (binders &rest body)
 ;;   ;; Works in both lexical and non-lexical mode.
@@ -142,13 +143,7 @@ Returns a form where all lambdas don't have any free variables."
     ;; Analyse form - fill these variables with new information.
     (cconv-analyse-form form '())
     (setq cconv-freevars-alist (nreverse cconv-freevars-alist))
-    (cconv-closure-convert-rec
-     form                               ; the tree
-     '()                                ;
-     '()                                ; fvrs initially empty
-     '()                                ; envs initially empty
-     '()
-     )))
+    (cconv-convert form nil nil))) ; Env initially empty.
 
 (defconst cconv--dummy-var (make-symbol "ignored"))
 
@@ -189,71 +184,79 @@ 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 '())
+(defun cconv--convert-function (args body env parentform)
+  (assert (equal body (caar cconv-freevars-alist)))
+  (let* ((fvs (cdr (pop cconv-freevars-alist)))
+         (body-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)))
+         (envector ())
+         (i 0)
+         (new-env ()))
+    ;; Build the "formal and actual envs" for the closure-converted function.
+    (dolist (fv fvs)
+      (let ((exp (or (cdr (assq fv env)) fv)))
+        (pcase exp
+          ;; If `fv' 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.
+          (`(car ,iexp . ,_)
+           (push iexp envector)
+           (push `(,fv . (car (internal-get-closed-var ,i))) new-env))
+          (_
+           (push exp envector)
+           (push `(,fv . (internal-get-closed-var ,i)) new-env))))
+      (setq i (1+ i)))
+    (setq envector (nreverse envector))
+    (setq new-env (nreverse new-env))
+
+    (dolist (arg args)
+      (if (not (member (cons (list arg) parentform) cconv-captured+mutated))
+          (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))
+
+    (when letbind
+      (let ((special-forms '()))
+        ;; Keep special forms at the beginning of the body.
+        (while (or (stringp (car body-new)) ;docstring.
+                   (memq (car-safe (car body-new)) '(interactive declare)))
+          (push (pop body-new) special-forms))
+        (setq body-new
+              `(,@(nreverse special-forms) (let ,letbind . ,body-new)))))
 
     (cond
-                                        ;if no freevars - do nothing
-     ((null envector)
-      `(function (lambda ,vars . ,body-forms-new)))
-                                        ; 1 free variable - do not build vector
+     ((null envector)                   ;if no freevars - do nothing
+      `(function (lambda ,args . ,body-new)))
      (t
       `(internal-make-closure
-        ,vars ,envector . ,body-forms-new)))))
+        ,args ,envector . ,body-new)))))
 
-(defun cconv-closure-convert-rec (form emvrs fvrs envs lmenvs)
+(defun cconv-convert (form env extend)
   ;; 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.
-- 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.
-Initially empty.
-- FVRS is a list of variables to substitute in each context.
-Initially empty.
-
-Returns a form where all lambdas don't have any free variables."
+  "Return FORM with all its lambdas changed so they are closed.
+ENV is a lexical environment mapping variables to the expression
+used to get its value.  This is used for variables that are copied into
+closures, moved into cons cells, ...
+ENV is a list where each entry takes the shape either:
+ (VAR . (car EXP)): VAR has been moved into the car of a cons-cell, and EXP
+    is an expression that evaluates to this cons-cell.
+ (VAR . (internal-get-closed-var N)): VAR has been copied into the closure
+    environment's Nth slot.
+ (VAR . (apply-partially F ARG1 ARG2 ..)): VAR has been λ-lifted and takes
+    additional arguments ARGs.
+EXTEND is a list of variables which might need to be accessed even from places
+where they are shadowed, because some part of ENV causes them to be used at
+places where they originally did not directly appear."
+  (assert (not (delq nil (mapcar (lambda (mapping)
+                                   (if (eq (cadr mapping) 'apply-partially)
+                                       (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)))
@@ -266,18 +269,12 @@ Returns a form where all lambdas don't have any free variables."
   ;; so we never touch it(unless we enter to the other closure).
   ;;(if (listp form) (print (car form)) form)
   (pcase form
-    (`(,(and letsym (or `let* `let)) ,binders . ,body-forms)
+    (`(,(and letsym (or `let* `let)) ,binders . ,body)
 
                                         ; let and let* special forms
-     (let ((body-forms-new '())
-           (binders-new '())
-           ;; next for variables needed for delayed push
-           ;; because we should process <value(s)>
-           ;; before we change any arguments
-           (lmenvs-new '())             ;needed only in case of let
-           (emvrs-new '())              ;needed only in case of let
-           (emvr-push)                  ;needed only in case of let*
-           (lmenv-push))                ;needed only in case of let*
+     (let ((binders-new '())
+           (new-env env)
+           (new-extend extend))
 
        (dolist (binder binders)
          (let* ((value nil)
@@ -288,372 +285,223 @@ Returns a form where all lambdas don't have any free variables."
                 (new-val
                  (cond
                   ;; Check if var is a candidate for lambda lifting.
-                  ((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)))
-                   ;; Peek at the freevars to decide whether to λ-lift.
-                   (let* ((fv (cdr (car cconv-freevars-alist)))
-                          (funargs (cadr (cadr value)))
-                          (funcvars (append fv funargs))
-                          (funcbodies (cddadr value)) ; function bodies
-                          (funcbodies-new '()))
+                  ((and (member (cons binder form) cconv-lambda-candidates)
+                        (progn
+                          (assert (and (eq (car value) 'function)
+                                       (eq (car (cadr value)) 'lambda)))
+                          (assert (equal (cddr (cadr value))
+                                         (caar cconv-freevars-alist)))
+                          ;; Peek at the freevars to decide whether to λ-lift.
+                          (let* ((fvs (cdr (car cconv-freevars-alist)))
+                                 (fun (cadr value))
+                                 (funargs (cadr fun))
+                                 (funcvars (append fvs funargs)))
                                         ; lambda lifting condition
-                     (if (or (not fv) (< cconv-liftwhen (length funcvars)))
-                                        ; do not lift
-                         (progn
-                           ;; (byte-compile-log-warning
-                           ;;  (format "Not λ-lifting `%S': %d > %d"
-                           ;;          var (length funcvars) cconv-liftwhen))
-
-                           (cconv-closure-convert-rec
-                            value emvrs fvrs envs lmenvs))
-                                        ; lift
-                       (progn
-                         ;; (byte-compile-log-warning
-                         ;;  (format "λ-lifting `%S'" var))
-                         (setq cconv-freevars-alist
-                               ;; Now that we know we'll λ-lift, consume the
-                               ;; freevar data.
-                               (cdr cconv-freevars-alist))
-                         (dolist (elm2 funcbodies)
-                           (push        ; convert function bodies
-                            (cconv-closure-convert-rec
-                             elm2 emvrs nil envs lmenvs)
-                            funcbodies-new))
-                         (if (eq letsym 'let*)
-                             (setq lmenv-push (cons var fv))
-                           (push (cons var fv) lmenvs-new))
-                                        ; push lifted function
-
-                         `(function .
-                                    ((lambda ,funcvars .
-                                       ,(reverse funcbodies-new))))))))
+                            (and fvs (>= cconv-liftwhen (length funcvars))))))
+                                        ; Lift.
+                   (let* ((fvs (cdr (pop cconv-freevars-alist)))
+                          (fun (cadr value))
+                          (funargs (cadr fun))
+                          (funcvars (append fvs funargs))
+                          (funcbody (cddr fun))
+                          (funcbody-env ()))
+                     (push `(,var . (apply-partially ,var . ,fvs)) new-env)
+                     (dolist (fv fvs)
+                       (pushnew fv new-extend)
+                       (if (and (eq 'car (car-safe (cdr (assq fv env))))
+                                (not (memq fv funargs)))
+                           (push `(,fv . (car ,fv)) funcbody-env)))
+                     `(function (lambda ,funcvars .
+                                  ,(mapcar (lambda (form)
+                                             (cconv-convert
+                                              form funcbody-env nil))
+                                           funcbody)))))
 
                   ;; Check if it needs to be turned into a "ref-cell".
                   ((member (cons binder form) cconv-captured+mutated)
                    ;; Declared variable is mutated and captured.
-                   (prog1
-                       `(list ,(cconv-closure-convert-rec
-                                value emvrs
-                                fvrs envs lmenvs))
-                     (if (eq letsym 'let*)
-                         (setq emvr-push var)
-                       (push var emvrs-new))))
+                   (push `(,var . (car ,var)) new-env)
+                   `(list ,(cconv-convert value env extend)))
 
                   ;; Normal default case.
                   (t
-                   (cconv-closure-convert-rec
-                    value emvrs fvrs envs lmenvs)))))
-
-           ;; this piece of code below letbinds free
-           ;; variables  of a lambda lifted function
-           ;; if they are redefined in this let
-           ;; example:
-           ;; (let* ((fun (lambda (x) (+ x y))) (y 1)) (funcall fun 1))
-           ;; Here we can not pass y as parameter because it is
-           ;; redefined. We add a (closed-y y) declaration.
-           ;; We do that even if the function is not used inside
-           ;; this let(*). The reason why we ignore this case is
-           ;; that we can't "look forward" to see if the function
-           ;; is called there or not. To treat well this case we
-           ;; need to traverse the tree one more time to collect this
-           ;; data, and I think that it's not worth it.
+                   (if (assq var new-env) (push `(,var) new-env))
+                   (cconv-convert value env extend)))))
+
+           ;; The piece of code below letbinds free variables of a λ-lifted
+           ;; function if they are redefined in this let, example:
+           ;;   (let* ((fun (lambda (x) (+ x y))) (y 1)) (funcall fun 1))
+           ;; Here we can not pass y as parameter because it is redefined.
+           ;; So we add a (closed-y y) declaration.  We do that even if the
+           ;; function is not used inside this let(*).  The reason why we
+           ;; ignore this case is that we can't "look forward" to see if the
+           ;; function is called there or not.  To treat this case better we'd
+           ;; need to traverse the tree one more time to collect this data, and
+           ;; I think that it's not worth it.
+           (when (memq var new-extend)
+             (let ((closedsym
+                    (make-symbol (concat "closed-" (symbol-name var)))))
+               (setq new-env
+                     (mapcar (lambda (mapping)
+                               (if (not (eq (cadr mapping) 'apply-partially))
+                                   mapping
+                                 (assert (eq (car mapping) (nth 2 mapping)))
+                                 (list* (car mapping)
+                                        'apply-partially
+                                        (car mapping)
+                                        (mapcar (lambda (arg)
+                                                  (if (eq var arg)
+                                                      closedsym arg))
+                                                (nthcdr 3 mapping)))))
+                             new-env))
+               (setq new-extend (remq var new-extend))
+               (push closedsym new-extend)
+               (push `(,closedsym ,var) binders-new)))
 
-           (when (eq letsym 'let*)
-             (let ((closedsym '())
-                   (new-lmenv '())
-                   (old-lmenv '()))
-               (dolist (lmenv lmenvs)
-                 (when (memq var (cdr lmenv))
-                   (setq closedsym
-                         (make-symbol
-                          (concat "closed-" (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)))
-                   (setq new-lmenv (reverse new-lmenv))
-                   (setq old-lmenv lmenv)))
-               (when new-lmenv
-                 (setq lmenvs (remq old-lmenv lmenvs))
-                 (push new-lmenv lmenvs)
-                 (push `(,closedsym ,var) binders-new))))
            ;; 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
-             (setq fvrs (remq var fvrs))
-             (setq emvrs (remq var emvrs)) ; remove if redefined
-             (when emvr-push
-               (push emvr-push emvrs)
-               (setq emvr-push nil))
-             (setq lmenvs (cconv--map-diff-elem lmenvs var))
-             (when lmenv-push
-               (push lmenv-push lmenvs)
-               (setq lmenv-push nil)))
-           ))                          ; end of dolist over binders
-       (when (eq letsym 'let)
-
-         ;; 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
-         ;; function got redefined.
-
-         (let ((new-lmenv)
-               (var nil)
-               (closedsym nil)
-               (letbinds '()))
-           (dolist (binder binders)
-             (setq var (if (consp binder) (car binder) binder))
-
-             (let ((lmenvs-1 lmenvs))   ; just to avoid manipulating
-               (dolist (lmenv lmenvs-1) ; the counter inside the loop
-                 (when (memq var (cdr lmenv))
-                   (setq closedsym (make-symbol
-                                    (concat "closed-"
-                                            (symbol-name var))))
-
-                   (setq new-lmenv (list (car 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)
-                   (push `(,closedsym ,var) letbinds)
-                   ))))
-           (setq binders-new (append binders-new letbinds))))
-
-       (dolist (elm body-forms)         ; convert body forms
-         (push (cconv-closure-convert-rec
-                elm emvrs fvrs envs lmenvs)
-               body-forms-new))
-       `(,letsym ,(reverse binders-new) . ,(reverse body-forms-new))))
+           (when (eq letsym 'let*)
+             (setq env new-env)
+             (setq extend new-extend))
+           ))                           ; end of dolist over binders
+
+       `(,letsym ,(nreverse binders-new)
+                 . ,(mapcar (lambda (form)
+                              (cconv-convert
+                               form new-env new-extend))
+                            body))))
                                         ;end of let let* forms
 
                                   ; first element is lambda expression
-    (`(,(and `(lambda . ,_) fun) . ,other-body-forms)
-
-     (let ((other-body-forms-new '()))
-       (dolist (elm other-body-forms)
-         (push (cconv-closure-convert-rec
-                elm emvrs fvrs envs lmenvs)
-               other-body-forms-new))
-       `(funcall
-         ,(cconv-closure-convert-rec
-           (list 'function fun) emvrs fvrs envs lmenvs)
-         ,@(nreverse other-body-forms-new))))
+    (`(,(and `(lambda . ,_) fun) . ,args)
+     ;; FIXME: it's silly to create a closure just to call it.
+     `(funcall
+       ,(cconv-convert `(function ,fun) env extend)
+       ,@(mapcar (lambda (form)
+                   (cconv-convert form env extend))
+                 args)))
 
     (`(cond . ,cond-forms)              ; cond special form
-     (let ((cond-forms-new '()))
-       (dolist (elm cond-forms)
-         (push (let ((elm-new '()))
-                 (dolist (elm-2 elm)
-                   (push
-                    (cconv-closure-convert-rec
-                     elm-2 emvrs fvrs envs lmenvs)
-                    elm-new))
-                 (reverse elm-new))
-               cond-forms-new))
-       (cons 'cond
-             (reverse cond-forms-new))))
-
-    (`(quote . ,_) form)
+     `(cond . ,(mapcar (lambda (branch)
+                         (mapcar (lambda (form)
+                                   (cconv-convert form env extend))
+                                 branch))
+                       cond-forms)))
 
-    (`(function (lambda ,vars . ,body-forms)) ; function form
-     (cconv-closure-convert-function
-      fvrs vars emvrs envs lmenvs body-forms form))
+    (`(function (lambda ,args . ,body) . ,_)
+     (cconv--convert-function args body env form))
 
     (`(internal-make-closure . ,_)
-     (error "Internal byte-compiler error: cconv called twice"))
+     (byte-compile-report-error
+      "Internal error in compiler: cconv called twice?"))
 
-    (`(function . ,_) form)             ; Same as quote.
+    (`(quote . ,_) form)
+    (`(function . ,_) form)
 
                                         ;defconst, defvar
-    (`(,(and sym (or `defconst `defvar)) ,definedsymbol . ,body-forms)
-
-     (let ((body-forms-new '()))
-       (dolist (elm body-forms)
-         (push (cconv-closure-convert-rec
-                elm emvrs fvrs envs lmenvs)
-               body-forms-new))
-       (setq body-forms-new (reverse body-forms-new))
-       `(,sym ,definedsymbol . ,body-forms-new)))
+    (`(,(and sym (or `defconst `defvar)) ,definedsymbol . ,forms)
+     `(,sym ,definedsymbol
+            . ,(mapcar (lambda (form) (cconv-convert form env extend))
+                       forms)))
 
                                         ;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)))
+       ,func ,args . ,body)
+     (assert (equal body (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)
-         (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)
-         (setq body-forms (cdr body-forms)))
-       (when (eq (car-safe (car body-forms)) 'interactive)
-         (push (cconv-closure-convert-rec
-                (car body-forms)
-                emvrs fvrs envs lmenvs)
-               body-new)
-         (setq body-forms (cdr body-forms)))
-
-       (dolist (elm body-forms)
-         (push (cconv-closure-convert-rec
-                elm emvrs fvrs envs lmenvs)
-               body-forms-new))
-       (setq body-forms-new (reverse body-forms-new))
-
-       (if letbind
-                                        ; Letbind mutable arguments.
-           (let ((binders-new '()))
-             (dolist (elm letbind) (push `(,elm (list ,elm))
-                                         binders-new))
-             (push `(let ,(reverse binders-new) .
-                         ,body-forms-new) body-new)
-             (setq body-new (reverse body-new)))
-         (setq body-new (append (reverse body-new) body-forms-new)))
-
-       `(,sym ,func ,vars . ,body-new)))
+
+     (let ((new (cconv--convert-function args body env form)))
+       (pcase new
+         (`(function (lambda ,newargs . ,new-body))
+          (assert (equal args newargs))
+          `(,sym ,func ,args . ,new-body))
+         (t (byte-compile-report-error
+             (format "Internal error in cconv of (%s %s ...)" sym func))))))
 
                                         ;condition-case
     (`(condition-case ,var ,protected-form . ,handlers)
-     (let ((newform (cconv-closure-convert-rec
-                     `(function (lambda () ,protected-form))
-                     emvrs fvrs envs lmenvs)))
-       (setq fvrs (remq var fvrs))
+     (let ((newform (cconv--convert-function
+                     () (list protected-form) env form)))
        `(condition-case :fun-body ,newform
           ,@(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)))
+                            (cconv--convert-function
+                             (list (or var cconv--dummy-var))
+                             (cdr handler) env form)))
                     handlers))))
 
     (`(,(and head (or `catch `unwind-protect)) ,form . ,body)
-     `(,head ,(cconv-closure-convert-rec form emvrs fvrs envs lmenvs)
-        :fun-body
-        ,(cconv-closure-convert-rec `(function (lambda () ,@body))
-                                    emvrs fvrs envs lmenvs)))
+     `(,head ,(cconv-convert form env extend)
+        :fun-body ,(cconv--convert-function () body env form)))
 
     (`(track-mouse . ,body)
      `(track-mouse
-        :fun-body
-        ,(cconv-closure-convert-rec `(function (lambda () ,@body))
-                                    emvrs fvrs envs lmenvs)))
+        :fun-body ,(cconv--convert-function () body env form)))
 
     (`(setq . ,forms)                   ; setq special form
-     (let (prognlist sym sym-new value)
+     (let ((prognlist ()))
        (while forms
-         (setq sym (car forms))
-         (setq sym-new (cconv-closure-convert-rec
-                        sym
-                        (remq sym emvrs) fvrs envs lmenvs))
-         (setq value
-               (cconv-closure-convert-rec
-                (cadr forms) emvrs fvrs envs lmenvs))
-         (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)))
+         (let* ((sym (pop forms))
+                (sym-new (or (cdr (assq sym env)) sym))
+                (value (cconv-convert (pop forms) env extend)))
+           (push (pcase sym-new
+                   ((pred symbolp) `(setq ,sym-new ,value))
+                   (`(car ,iexp) `(setcar ,iexp ,value))
+                   ;; 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.
+                   (_ ;; (byte-compile-report-error
+                    ;;  (format "Internal error in cconv of (setq %s ..)"
+                    ;;          sym-new))
+                    value))
+                 prognlist)))
        (if (cdr prognlist)
-           `(progn . ,(reverse prognlist))
+           `(progn . ,(nreverse prognlist))
          (car prognlist))))
 
     (`(,(and (or `funcall `apply) callsym) ,fun . ,args)
-                                     ; funcall is not a special form
-                                     ; but we treat it separately
-                                     ; for the needs of lambda lifting
-     (let ((fv (cdr (assq fun lmenvs))))
-       (if fv
-           (let ((args-new '())
-                 (processed-fv '()))
-             ;; All args (free variables and actual arguments)
-             ;; should be processed, because they can be fvrs
-             ;; (free variables of another closure)
-             (dolist (fvr fv)
-               (push (cconv-closure-convert-rec
-                      fvr (remq fvr emvrs)
-                      fvrs envs lmenvs)
-                     processed-fv))
-             (setq processed-fv (reverse processed-fv))
-             (dolist (elm args)
-               (push (cconv-closure-convert-rec
-                      elm emvrs fvrs envs lmenvs)
-                     args-new))
-             (setq args-new (append processed-fv (reverse args-new)))
-             (setq fun (cconv-closure-convert-rec
-                        fun emvrs fvrs envs lmenvs))
-             `(,callsym ,fun . ,args-new))
-         (let ((cdr-new '()))
-           (dolist (elm (cdr form))
-             (push (cconv-closure-convert-rec
-                    elm emvrs fvrs envs lmenvs)
-                   cdr-new))
-           `(,callsym . ,(reverse cdr-new))))))
+     ;; These are not special forms but we treat them separately for the needs
+     ;; of lambda lifting.
+     (let ((mapping (cdr (assq fun env))))
+       (pcase mapping
+         (`(apply-partially ,_ . ,(and fvs `(,_ . ,_)))
+          (assert (eq (cadr mapping) fun))
+          `(,callsym ,fun
+                     ,@(mapcar (lambda (fv)
+                                 (let ((exp (or (cdr (assq fv env)) fv)))
+                                   (pcase exp
+                                     (`(car ,iexp . ,_) iexp)
+                                     (_ exp))))
+                               fvs)
+                     ,@(mapcar (lambda (arg)
+                                 (cconv-convert arg env extend))
+                               args)))
+         (_ `(,callsym ,@(mapcar (lambda (arg)
+                                   (cconv-convert arg env extend))
+                                 (cons fun args)))))))
 
     (`(interactive . ,forms)
-     `(interactive
-       ,@(mapcar (lambda (form)
-                   (cconv-closure-convert-rec form nil nil nil nil))
-                 forms)))
+     `(interactive . ,(mapcar (lambda (form)
+                                (cconv-convert form nil nil))
+                              forms)))
     
-    (`(,func . ,body-forms)    ; first element is function or whatever
-                               ; function-like forms are:
-                               ; or, and, if, progn, prog1, prog2,
-                               ; while, until
-     (let ((body-forms-new '()))
-       (dolist (elm body-forms)
-         (push (cconv-closure-convert-rec
-                elm emvrs fvrs envs lmenvs)
-               body-forms-new))
-       (setq body-forms-new (reverse body-forms-new))
-       `(,func . ,body-forms-new)))
-
-    (_
-     (let ((free (memq form fvrs)))
-       (if free                         ;form is a free variable
-           (let* ((numero (- (length fvrs) (length free)))
-                  ;; Replace form => (aref env #)
-                  (var `(internal-get-closed-var ,numero)))
-             (if (memq form emvrs) ; form => (car (aref env #)) if mutable
-                 `(car ,var)
-               var))
-         (if (memq form emvrs)         ; if form is a mutable variable
-             `(car ,form)              ; replace form => (car form)
-           form))))))
+    (`(,func . ,forms)
+     ;; First element is function or whatever function-like forms are: or, and,
+     ;; if, progn, prog1, prog2, while, until
+     `(,func . ,(mapcar (lambda (form)
+                          (cconv-convert form env extend))
+                        forms)))
+
+    (_ (or (cdr (assq form env)) form))))
 
 (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 varkind)
+(defun cconv--analyse-use (vardata form varkind)
   "Analyse the use of a variable.
 VARDATA should be (BINDER READ MUTATED CAPTURED CALLED).
 VARKIND is the name of the kind of variable.
@@ -663,8 +511,8 @@ FORM is the parent form that binds this var."
     (`(,_ nil nil nil nil) nil)
     (`((,(and (pred (lambda (var) (eq ?_ (aref (symbol-name var) 0)))) var) . ,_)
        ,_ ,_ ,_ ,_)
-     (byte-compile-log-warning (format "%s `%S' not left unused" varkind var)))
-    ((or `(,_ ,_ ,_ ,_ ,_) dontcare) nil))
+     (byte-compile-log-warning
+      (format "%s `%S' not left unused" varkind var))))
   (pcase vardata
     (`((,var . ,_) nil ,_ ,_ nil)
      ;; FIXME: This gives warnings in the wrong order, with imprecise line
@@ -681,11 +529,9 @@ FORM is the parent form that binds this var."
     (`(,binder ,_ t t ,_)
      (push (cons binder form) cconv-captured+mutated))
     (`(,(and binder `(,_ (function (lambda . ,_)))) nil nil nil t)
-     (push (cons binder form) cconv-lambda-candidates))
-    (`(,_ ,_ ,_ ,_ ,_) nil)
-    (dontcare)))
+     (push (cons binder form) cconv-lambda-candidates))))
 
-(defun cconv-analyse-function (args body env parentform)
+(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
@@ -710,7 +556,7 @@ FORM is the parent form that binds this var."
       (cconv-analyse-form form newenv))
     ;; Summarize resulting data about arguments.
     (dolist (vardata newvars)
-      (cconv-analyse-use vardata parentform "argument"))
+      (cconv--analyse-use vardata parentform "argument"))
     ;; Transfer uses collected in `envcopy' (via `newenv') back to `env';
     ;; and compute free variables.
     (while env
@@ -763,7 +609,7 @@ and updates the data stored in ENV."
          (cconv-analyse-form form env))
 
        (dolist (vardata newvars)
-         (cconv-analyse-use vardata form "variable"))))
+         (cconv--analyse-use vardata form "variable"))))
 
                                         ; defun special form
     (`(,(or `defun `defmacro) ,func ,vrs . ,body-forms)
@@ -772,10 +618,10 @@ and updates the data stored in ENV."
         (format "Function %S will ignore its context %S"
                 func (mapcar #'car env))
         t :warning))
-     (cconv-analyse-function vrs body-forms nil form))
+     (cconv--analyse-function vrs body-forms nil form))
 
     (`(function (lambda ,vrs . ,body-forms))
-     (cconv-analyse-function vrs body-forms env form))
+     (cconv--analyse-function vrs body-forms env form))
      
     (`(setq . ,forms)
      ;; If a local variable (member of env) is modified by setq then
@@ -801,19 +647,19 @@ and updates the data stored in ENV."
      ;; 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).
-     (cconv-analyse-function () (list protected-form) env form)
+     (cconv--analyse-function () (list protected-form) env form)
      (dolist (handler handlers)
-       (cconv-analyse-function (if var (list var)) (cdr handler) env form)))
+       (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)
-     (cconv-analyse-function () body env form))
+     (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)
-     (cconv-analyse-function () body env form))
+     (cconv--analyse-function () body env form))
 
     (`(,(or `defconst `defvar) ,var ,value . ,_)
      (push var byte-compile-bound-variables)
diff --git a/test/ChangeLog b/test/ChangeLog
index b247b88bc94..dc9b87adfac 100644
--- a/test/ChangeLog
+++ b/test/ChangeLog
@@ -1,3 +1,7 @@
+2011-03-10  Stefan Monnier  <monnier@iro.umontreal.ca>
+
+        * automated/lexbind-tests.el: New file.
+
 2011-03-05  Glenn Morris  <rgm@gnu.org>
 
         * eshell.el: Move here from lisp/eshell/esh-test.el.
diff --git a/test/automated/lexbind-tests.el b/test/automated/lexbind-tests.el
new file mode 100644
index 00000000000..1ff31e2422d
--- /dev/null
+++ b/test/automated/lexbind-tests.el
@@ -0,0 +1,75 @@
+;;; lexbind-tests.el --- Testing the lexbind byte-compiler
+
+;; Copyright (C) 2011  Free Software Foundation, Inc.
+
+;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
+;; 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
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program 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 this program.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; 
+
+;;; Code:
+
+(require 'ert)
+
+(defconst lexbind-tests
+  `(
+    (let ((f #'car))
+      (let ((f (lambda (x) (cons (funcall f x) (cdr x)))))
+        (funcall f '(1 . 2))))
+    )
+  "List of expression for test.
+Each element will be executed by interpreter and with
+bytecompiled code, and their results compared.")
+
+
+
+(defun lexbind-check-1 (pat)
+  "Return non-nil if PAT is the same whether directly evalled or compiled."
+  (let ((warning-minimum-log-level :emergency)
+        (byte-compile-warnings nil)
+        (v0 (condition-case nil
+                (eval pat t)
+              (error nil)))
+        (v1 (condition-case nil
+                (funcall (let ((lexical-binding t))
+                           (byte-compile `(lambda nil ,pat))))
+              (error nil))))
+    (equal v0 v1)))
+
+(put 'lexbind-check-1 'ert-explainer 'lexbind-explain-1)
+
+(defun lexbind-explain-1 (pat)
+  (let ((v0 (condition-case nil
+                (eval pat t)
+              (error nil)))
+        (v1 (condition-case nil
+                (funcall (let ((lexical-binding t))
+                           (byte-compile (list 'lambda nil pat))))
+              (error nil))))
+    (format "Expression `%s' gives `%s' if directly evalled, `%s' if compiled."
+            pat v0 v1)))
+
+(ert-deftest lexbind-tests ()
+  "Test the Emacs byte compiler lexbind handling."
+  (dolist (pat lexbind-tests)
+    (should (lexbind-check-1 pat))))
+
+
+
+(provide 'lexbind-tests)
+;;; lexbind-tests.el ends here