Let cconv use :fun-body in special forms that need it.

[emacs.git] / lisp / emacs-lisp / byte-lexbind.el

;;; byte-lexbind.el --- Lexical binding support for byte-compiler
;;
;; Copyright (C) 2001, 2002, 2010, 2011 Free Software Foundation, Inc.
;;
;; Author: Miles Bader <miles@gnu.org>
;; Keywords: lisp, compiler, lexical binding

;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Commentary:
;;

;;; Code:

(require 'bytecomp-preload "bytecomp")

;; Downward closures aren't implemented yet, so this should always be nil
(defconst byte-compile-use-downward-closures nil
  "If true, use `downward closures', which are closures that don't cons.")

(defconst byte-compile-save-window-excursion-uses-eval t
  "If true, the bytecode for `save-window-excursion' uses eval.
This means that the body of the form must be put into a closure.")

(defun byte-compile-arglist-vars (arglist)
  "Return a list of the variables in the lambda argument list ARGLIST."
  (remq '&rest (remq '&optional arglist)))

\f
;;; Variable extent analysis.

;; A `lforminfo' holds information about lexical bindings in a form, and some
;; other info for analysis.  It is a cons-cell, where the car is a list of
;; `lvarinfo' stuctures, which form an alist indexed by variable name, and the
;; cdr is the number of closures found in the form:
;;
;;   LFORMINFO : ((LVARINFO ...) . NUM-CLOSURES)"
;;
;; A `lvarinfo' holds information about a single lexical variable.  It is a
;; list whose car is the variable name (so an lvarinfo is suitable as an alist
;; entry), and the rest of the of which holds information about the variable:
;;
;;   LVARINFO : (VAR NUM-REFS NUM-SETS CLOSED-OVER)
;;
;; NUM-REFS is the number of times the variable's value is used
;; NUM-SETS is the number of times the variable's value is set
;; CLOSED-OVER is non-nil if the variable is referenced
;;     anywhere but in its original function-level"

;;; lvarinfo:

;; constructor
(defsubst byte-compile-make-lvarinfo (var &optional already-set)
  (list var 0 (if already-set 1 0) 0 nil))
;; accessors
(defsubst byte-compile-lvarinfo-var (vinfo) (car vinfo))
(defsubst byte-compile-lvarinfo-num-refs (vinfo) (cadr vinfo))
(defsubst byte-compile-lvarinfo-num-sets (vinfo) (nth 3 vinfo))
(defsubst byte-compile-lvarinfo-closed-over-p (vinfo) (nth 4 vinfo))
;; setters
(defsubst byte-compile-lvarinfo-note-ref (vinfo)
  (setcar (cdr vinfo) (1+ (cadr vinfo))))
(defsubst byte-compile-lvarinfo-note-set (vinfo)
  (setcar (cddr vinfo) (1+ (nth 3 vinfo))))
(defsubst byte-compile-lvarinfo-note-closure (vinfo)
  (setcar (nthcdr 4 vinfo) t))

;;; lforminfo:

;; constructor
(defsubst byte-compile-make-lforminfo ()
  (cons nil 0))
;; accessors
(defalias 'byte-compile-lforminfo-vars 'car)
(defalias 'byte-compile-lforminfo-num-closures 'cdr)
;; setters
(defsubst byte-compile-lforminfo-add-var (finfo var &optional already-set)
  (setcar finfo (cons (byte-compile-make-lvarinfo var already-set)
                      (car finfo))))

(defun byte-compile-lforminfo-make-closure-flag ()
  "Return a new `closure-flag'."
  (cons nil nil))

(defsubst byte-compile-lforminfo-note-closure (lforminfo lvarinfo closure-flag)
  "If a variable reference or definition is inside a closure, record that fact.
LFORMINFO describes the form currently being analyzed, and LVARINFO
describes the variable.  CLOSURE-FLAG is either nil, if currently _not_
inside a closure, and otherwise a `closure flag' returned by
`byte-compile-lforminfo-make-closure-flag'."
  (when closure-flag
    (byte-compile-lvarinfo-note-closure lvarinfo)
    (unless (car closure-flag)
      (setcdr lforminfo (1+ (cdr lforminfo)))
      (setcar closure-flag t))))

(defun byte-compile-compute-lforminfo (form &optional special)
  "Return information about variables lexically bound by FORM.
SPECIAL is a list of variables that are special, and so shouldn't be
bound lexically (in addition to variable that are considered special
because they are declared with `defvar', et al).

The result is an `lforminfo' data structure."
  (and
   (consp form)
   (let ((lforminfo (byte-compile-make-lforminfo)))
     (cond ((eq (car form) 'let)
            ;; Find the bound variables
            (dolist (clause (cadr form))
              (let ((var (if (consp clause) (car clause) clause)))
                (unless (or (special-variable-p var) (memq var special))
                  (byte-compile-lforminfo-add-var lforminfo var t))))
            ;; Analyze the body
            (unless (null (byte-compile-lforminfo-vars lforminfo))
              (byte-compile-lforminfo-analyze-forms lforminfo form 2
                                                    special nil)))
           ((eq (car form) 'let*)
            (dolist (clause (cadr form))
              (let ((var (if (consp clause) (car clause) clause)))
                ;; Analyze each initializer based on the previously
                ;; bound variables.
                (when (and (consp clause) lforminfo)
                  (byte-compile-lforminfo-analyze lforminfo (cadr clause)
                                                  special nil))
                (unless (or (special-variable-p var) (memq var special))
                  (byte-compile-lforminfo-add-var lforminfo var t))))
            ;; Analyze the body
            (unless (null (byte-compile-lforminfo-vars lforminfo))
              (byte-compile-lforminfo-analyze-forms lforminfo form 2
                                                    special nil)))
           ((eq (car form) 'condition-case)
            ;; `condition-case' currently must dynamically bind the
            ;; error variable, so do nothing.
            )
           ((memq (car form) '(defun defmacro))
            (byte-compile-lforminfo-from-lambda lforminfo (cdr form) special))
           ((eq (car form) 'lambda)
            (byte-compile-lforminfo-from-lambda lforminfo form special))
           ((and (consp (car form)) (eq (caar form) 'lambda))
            ;; An embedded lambda, which is basically just a `let'
            (byte-compile-lforminfo-from-lambda lforminfo (cdr form) special)))
     (if (byte-compile-lforminfo-vars lforminfo)
         lforminfo
       nil))))

(defun byte-compile-lforminfo-from-lambda (lforminfo lambda special)
  "Initialize LFORMINFO from the lambda expression LAMBDA.
SPECIAL is a list of variables to ignore.
The first element of LAMBDA is ignored; it need not actually be `lambda'."
  ;; Add the arguments
  (dolist (arg (byte-compile-arglist-vars (cadr lambda)))
    (byte-compile-lforminfo-add-var lforminfo arg t))
  ;; Analyze the body
  (unless (null (byte-compile-lforminfo-vars lforminfo))
    (byte-compile-lforminfo-analyze-forms lforminfo lambda 2 special nil)))

(defun byte-compile-lforminfo-analyze (lforminfo form &optional ignore closure-flag)
  "Update variable information in LFORMINFO by analyzing FORM.
IGNORE is a list of variables that shouldn't be analyzed (usually because
they're special, or because some inner binding shadows the version in
LFORMINFO).  CLOSURE-FLAG should be either nil or a `closure flag' created
with `byte-compile-lforminfo-make-closure-flag'; the latter indicates that
FORM is inside a lambda expression that may close over some variable in
LFORMINFO."
  (cond ((symbolp form)
         ;; variable reference
         (unless (member form ignore)
           (let ((vinfo (assq form (byte-compile-lforminfo-vars lforminfo))))
             (when vinfo
               (byte-compile-lvarinfo-note-ref vinfo)
               (byte-compile-lforminfo-note-closure lforminfo vinfo
                                                    closure-flag)))))
        ;; function call/special form
        ((consp form)
         (let ((fun (car form)))
           (cond
            ((eq fun 'setq)
             (pop form)
             (while form
               (let ((var (pop form)))
                 (byte-compile-lforminfo-analyze lforminfo (pop form)
                                                 ignore closure-flag)
                 (unless (member var ignore)
                   (let ((vinfo
                          (assq var (byte-compile-lforminfo-vars lforminfo))))
                     (when vinfo
                       (byte-compile-lvarinfo-note-set vinfo)
                       (byte-compile-lforminfo-note-closure lforminfo vinfo
                                                            closure-flag)))))))
            ((and (eq fun 'catch) (not (eq :fun-body (nth 2 form))))
             ;; tag
             (byte-compile-lforminfo-analyze lforminfo (cadr form)
                                             ignore closure-flag)
             ;; `catch' uses a closure for the body
             (byte-compile-lforminfo-analyze-forms
              lforminfo form 2
              ignore
              (or closure-flag
                  (and (not byte-compile-use-downward-closures)
                       (byte-compile-lforminfo-make-closure-flag)))))
            ((eq fun 'cond)
             (byte-compile-lforminfo-analyze-clauses lforminfo (cdr form) 0
                                                     ignore closure-flag))
            ((eq fun 'condition-case)
             ;; `condition-case' separates its body/handlers into
             ;; separate closures.
             (unless (or (eq (nth 1 form) :fun-body)
                         closure-flag byte-compile-use-downward-closures)
               ;; condition case is implemented by calling a function
               (setq closure-flag (byte-compile-lforminfo-make-closure-flag)))
             ;; value form
             (byte-compile-lforminfo-analyze lforminfo (nth 2 form)
                                             ignore closure-flag)
             ;; the error variable is always bound dynamically (because
             ;; of the implementation)
             (when (cadr form)
               (push (cadr form) ignore))
             ;; handlers
             (byte-compile-lforminfo-analyze-clauses lforminfo
                                                     (nthcdr 2 form) 1
                                                     ignore closure-flag))
            ((eq fun '(defvar defconst))
             (byte-compile-lforminfo-analyze lforminfo (nth 2 form)
                                             ignore closure-flag))
            ((memq fun '(defun defmacro))
             (byte-compile-lforminfo-analyze-forms lforminfo form 3
                                                   ignore closure-flag))
            ((eq fun 'function)
             ;; Analyze an embedded lambda expression [note: we only recognize
             ;; it within (function ...) as the (lambda ...) for is actually a
             ;; macro returning (function (lambda ...))].
             (when (and (consp (cadr form)) (eq (car (cadr form)) 'lambda))
               ;; shadow bound variables
               (setq ignore
                     (append (byte-compile-arglist-vars (cadr (cadr form)))
                             ignore))
               ;; analyze body of lambda
               (byte-compile-lforminfo-analyze-forms
                lforminfo (cadr form) 2
                ignore
                (or closure-flag
                    (byte-compile-lforminfo-make-closure-flag)))))
            ((eq fun 'let)
             ;; analyze variable inits
             (byte-compile-lforminfo-analyze-clauses lforminfo (cadr form) 1
                                                     ignore closure-flag)
             ;; shadow bound variables
             (dolist (clause (cadr form))
               (push (if (symbolp clause) clause (car clause))
                     ignore))
             ;; analyze body
             (byte-compile-lforminfo-analyze-forms lforminfo form 2
                                                   ignore closure-flag))
            ((eq fun 'let*)
             (dolist (clause (cadr form))
               (if (symbolp clause)
                   ;; shadow bound (to nil) variable
                   (push clause ignore)
                 ;; analyze variable init
                 (byte-compile-lforminfo-analyze lforminfo (cadr clause)
                                                 ignore closure-flag)
                 ;; shadow bound variable
                 (push (car clause) ignore)))
             ;; analyze body
             (byte-compile-lforminfo-analyze-forms lforminfo form 2
                                                   ignore closure-flag))
            ((eq fun 'quote)
             ;; do nothing
             )
            ((and (eq fun 'save-window-excursion)
                  (not (eq :fun-body (nth 1 form))))
             ;; `save-window-excursion' currently uses a funny implementation
             ;; that requires its body forms be put into a closure (it should
             ;; be fixed to work more like `save-excursion' etc., do).
             (byte-compile-lforminfo-analyze-forms
              lforminfo form 2
              ignore
              (or closure-flag
                  (and byte-compile-save-window-excursion-uses-eval
                       (not byte-compile-use-downward-closures)
                       (byte-compile-lforminfo-make-closure-flag)))))
            ((and (consp fun) (eq (car fun) 'lambda))
             ;; Embedded lambda.  These are inlined by the compiler, so
             ;; we don't treat them like a real closure, more like `let'.
             ;; analyze inits
             (byte-compile-lforminfo-analyze-forms lforminfo form 2
                                                   ignore closure-flag)
             
             ;; shadow bound variables
             (setq ignore (nconc (byte-compile-arglist-vars (cadr fun))
                                 ignore))
             ;; analyze body
             (byte-compile-lforminfo-analyze-forms lforminfo fun 2
                                                   ignore closure-flag))
            (t
             ;; For everything else, we just expand each argument (for
             ;; setq/setq-default this works alright because the
             ;; variable names are symbols).
             (byte-compile-lforminfo-analyze-forms lforminfo form 1
                                                   ignore closure-flag)))))))

(defun byte-compile-lforminfo-analyze-forms
  (lforminfo forms skip ignore closure-flag)
  "Update variable information in LFORMINFO by analyzing each form in FORMS.
The first SKIP elements of FORMS are skipped without analysis.  IGNORE
is a list of variables that shouldn't be analyzed (usually because
they're special, or because some inner binding shadows the version in
LFORMINFO).  CLOSURE-FLAG should be either nil or a `closure flag' created with
`byte-compile-lforminfo-make-closure-flag'; the latter indicates that FORM is
inside a lambda expression that may close over some variable in LFORMINFO."
  (when skip
    (setq forms (nthcdr skip forms)))
  (while forms
    (byte-compile-lforminfo-analyze lforminfo (pop forms)
                                    ignore closure-flag)))

(defun byte-compile-lforminfo-analyze-clauses
  (lforminfo clauses skip ignore closure-flag)
  "Update variable information in LFORMINFO by analyzing each clause in CLAUSES.
Each clause is a list of forms; any clause that's not a list is ignored.  The
first SKIP elements of each clause are skipped without analysis.  IGNORE is a
list of variables that shouldn't be analyzed (usually because they're special,
or because some inner binding shadows the version in LFORMINFO).
CLOSURE-FLAG should be either nil or a `closure flag' created with
`byte-compile-lforminfo-make-closure-flag'; the latter indicates that FORM is
inside a lambda expression that may close over some variable in LFORMINFO."
  (while clauses
    (let ((clause (pop clauses)))
      (when (consp clause)
        (byte-compile-lforminfo-analyze-forms lforminfo clause skip
                                              ignore closure-flag)))))

\f
;;; Lexical environments

;; A lexical environment is an alist, where each element is of the form
;; (VAR . (OFFSET . ENV)) where VAR is either a symbol, for normal
;; variables, or an `heapenv' descriptor for references to heap environment
;; vectors.  ENV is either an atom, meaning a `stack allocated' variable
;; (the particular atom serves to indicate the particular function context
;; on whose stack it's allocated), or an `heapenv' descriptor (see above),
;; meaning a variable allocated in a heap environment vector.  For the
;; later case, an anonymous `variable' holding a pointer to the environment
;; vector may be located by recursively looking up ENV in the environment
;; as if it were a variable (so the entry for that `variable' will have a
;; non-symbol VAR).

;; We call a lexical environment a `lexenv', and an entry in it a `lexvar'.

;; constructor
(defsubst byte-compile-make-lexvar (name offset &optional env)
  (cons name (cons offset env)))
;; accessors
(defsubst byte-compile-lexvar-name (lexvar) (car lexvar))
(defsubst byte-compile-lexvar-offset (lexvar) (cadr lexvar))
(defsubst byte-compile-lexvar-environment (lexvar) (cddr lexvar))
(defsubst byte-compile-lexvar-variable-p (lexvar) (symbolp (car lexvar)))
(defsubst byte-compile-lexvar-environment-p (lexvar)
  (not (symbolp (car lexvar))))
(defsubst byte-compile-lexvar-on-stack-p (lexvar)
  (atom (byte-compile-lexvar-environment lexvar)))
(defsubst byte-compile-lexvar-in-heap-p (lexvar)
  (not (byte-compile-lexvar-on-stack-p lexvar)))

(defun byte-compile-make-lambda-lexenv (form closed-over-lexenv)
  "Return a new lexical environment for a lambda expression FORM.
CLOSED-OVER-LEXENV is the lexical environment in which FORM occurs.
The returned lexical environment contains two sets of variables:
  * Variables that were in CLOSED-OVER-LEXENV and used by FORM
    (all of these will be `heap' variables)
  * Arguments to FORM (all of these will be `stack' variables)."
  ;; See if this is a closure or not
  (let ((closure nil)
        (lforminfo (byte-compile-make-lforminfo))
        (args (byte-compile-arglist-vars (cadr form))))
    ;; Add variables from surrounding lexical environment to analysis set
    (dolist (lexvar closed-over-lexenv)
      (when (and (byte-compile-lexvar-in-heap-p lexvar)
                 (not (memq (car lexvar) args)))
        ;; The variable is located in a heap-allocated environment
        ;; vector, so FORM may use it.  Add it to the set of variables
        ;; that we'll search for in FORM.
        (byte-compile-lforminfo-add-var lforminfo (car lexvar))))
    ;; See how FORM uses these potentially closed-over variables.
    (byte-compile-lforminfo-analyze lforminfo form args)
    (let ((lexenv nil))
      (dolist (vinfo (byte-compile-lforminfo-vars lforminfo))
        (when (> (byte-compile-lvarinfo-num-refs vinfo) 0)
          ;; FORM uses VINFO's variable, so it must be a closure.
          (setq closure t)
          ;; Make sure that the environment in which the variable is
          ;; located is accessible (since we only ever pass the
          ;; innermost environment to closures, if it's in some other
          ;; envionment, there must be path to it from the innermost
          ;; one).
          (unless (byte-compile-lexvar-in-heap-p vinfo)
            ;; To access the variable from FORM, it must be in the heap.
            (error
    "Compiler error: lexical variable `%s' should be heap-allocated but is not"
             (car vinfo)))
          (let ((closed-over-lexvar (assq (car vinfo) closed-over-lexenv)))
            (byte-compile-heapenv-ensure-access
             byte-compile-current-heap-environment
             (byte-compile-lexvar-environment closed-over-lexvar))
            ;; Put this variable in the new lexical environment
            (push closed-over-lexvar lexenv))))
      ;; Fill in the initial stack contents
      (let ((stackpos 0))
        (when closure
          ;; Add the magic first argument that holds the environment pointer
          (push (byte-compile-make-lexvar byte-compile-current-heap-environment
                                          0)
                lexenv)
          (setq stackpos (1+ stackpos)))
        ;; Add entries for each argument
        (dolist (arg args)
          (push (byte-compile-make-lexvar arg stackpos) lexenv)
          (setq stackpos (1+ stackpos)))
        ;; Return the new lexical environment
        lexenv))))

(defun byte-compile-closure-initial-lexenv-p (lexenv)
  "Return non-nil if LEXENV is the initial lexical environment for a closure.
This only works correctly when passed a new lexical environment as
returned by `byte-compile-make-lambda-lexenv' (it works by checking to
see whether there are any heap-allocated lexical variables in LEXENV)."
  (let ((closure nil))
    (while (and lexenv (not closure))
      (when (byte-compile-lexvar-environment-p (pop lexenv))
        (setq closure t)))
    closure))

\f
;;; Heap environment vectors

;; A `heap environment vector' is heap-allocated vector used to store
;; variable that can't be put onto the stack.
;;
;; They are represented in the compiler by a list of the form
;;
;;    (SIZE SIZE-CONST-ID INIT-POSITION . ENVS)
;;
;; SIZE is the current size of the vector (which may be
;; incremented if another variable or environment-reference is added to
;; the end).  SIZE-CONST-ID is an `unknown constant id' (as returned by
;; `byte-compile-push-unknown-constant') representing the constant used
;; in the vector initialization code, and INIT-POSITION is a position
;; in the byte-code output (as returned by `byte-compile-delay-out')
;; at which more initialization code can be added.
;; ENVS is a list of other environment vectors accessible form this one,
;; where each element is of the form (ENV . OFFSET).

;; constructor
(defsubst byte-compile-make-heapenv (size-const-id init-position)
  (list 0 size-const-id init-position))
;; accessors
(defsubst byte-compile-heapenv-size (heapenv) (car heapenv))
(defsubst byte-compile-heapenv-size-const-id (heapenv) (cadr heapenv))
(defsubst byte-compile-heapenv-init-position (heapenv) (nth 2 heapenv))
(defsubst byte-compile-heapenv-accessible-envs (heapenv) (nthcdr 3 heapenv))

(defun byte-compile-heapenv-add-slot (heapenv)
  "Add a slot to the heap environment HEAPENV and return its offset."
  (prog1 (car heapenv) (setcar heapenv (1+ (car heapenv)))))

(defun byte-compile-heapenv-add-accessible-env (heapenv env offset)
  "Add to HEAPENV's list of accessible environments, ENV at OFFSET."
  (setcdr (nthcdr 2 heapenv)
          (cons (cons env offset)
                (byte-compile-heapenv-accessible-envs heapenv))))

(defun byte-compile-push-heapenv ()
  "Generate byte-code to push a new heap environment vector.
Sets `byte-compile-current-heap-environment' to the compiler descriptor
for the new heap environment.
Return a `lexvar' descriptor for the new heap environment."
  (let ((env-stack-pos byte-compile-depth)
        size-const-id init-position)
    ;; Generate code to push the vector
    (byte-compile-push-constant 'make-vector)
    (setq size-const-id (byte-compile-push-unknown-constant))
    (byte-compile-push-constant nil)
    (byte-compile-out 'byte-call 2)
    (setq init-position (byte-compile-delay-out 3))
    ;; Now make a heap-environment for the compiler to use
    (setq byte-compile-current-heap-environment
          (byte-compile-make-heapenv size-const-id init-position))
    (byte-compile-make-lexvar byte-compile-current-heap-environment
                              env-stack-pos)))

(defun byte-compile-heapenv-ensure-access (heapenv other-heapenv)
  "Make sure that HEAPENV can be used to access OTHER-HEAPENV.
If not, then add a new slot to HEAPENV pointing to OTHER-HEAPENV."
  (unless (memq heapenv (byte-compile-heapenv-accessible-envs heapenv))
    (let ((offset (byte-compile-heapenv-add-slot heapenv)))
      (byte-compile-heapenv-add-accessible-env heapenv other-heapenv offset))))

\f
;;; Variable binding/unbinding

(defun byte-compile-non-stack-bindings-p (clauses lforminfo)
  "Return non-nil if any lexical bindings in CLAUSES are not stack-allocated.
LFORMINFO should be information about lexical variables being bound."
  (let ((vars (byte-compile-lforminfo-vars lforminfo)))
    (or (not (= (length clauses) (length vars)))
        (progn
          (while (and vars clauses)
            (when (byte-compile-lvarinfo-closed-over-p (pop vars))
              (setq clauses nil)))
          (not clauses)))))

(defun byte-compile-let-clauses-trivial-init-p (clauses)
  "Return true if let binding CLAUSES all have a `trivial' init value.
Trivial means either a constant value, or a simple variable initialization."
  (or (null clauses)
      (and (or (atom (car clauses))
               (atom (cadr (car clauses)))
               (eq (car (cadr (car clauses))) 'quote))
           (byte-compile-let-clauses-trivial-init-p (cdr clauses)))))

(defun byte-compile-rearrange-let-clauses (clauses lforminfo)
  "Return CLAUSES rearranged so non-stack variables come last if possible.
Care is taken to only do so when it's clear that the meaning is the same.
LFORMINFO should be information about lexical variables being bound."
  ;; We currently do a very simple job by only exchanging clauses when
  ;; one has a constant init, or one has a variable init and the other
  ;; doesn't have a function call init (because that could change the
  ;; value of the variable).  This could be more clever and actually
  ;; attempt to analyze which variables could possible be changed, etc.
  (let ((unchanged nil)
        (lex-non-stack nil)
        (dynamic nil))
    (while clauses
      (let* ((clause (pop clauses))
             (var (if (consp clause) (car clause) clause))
             (init (and (consp clause) (cadr clause)))
             (vinfo (assq var (byte-compile-lforminfo-vars lforminfo))))
        (cond
         ((or (and vinfo
                   (not (byte-compile-lvarinfo-closed-over-p vinfo)))
              (not
               (or (eq init nil) (eq init t)
                   (and (atom init) (not (symbolp init)))
                   (and (consp init) (eq (car init) 'quote))
                   (byte-compile-let-clauses-trivial-init-p clauses))))
          (push clause unchanged))
         (vinfo
          (push clause lex-non-stack))
         (t
          (push clause dynamic)))))
    (nconc (nreverse unchanged) (nreverse lex-non-stack) (nreverse dynamic))))

(defun byte-compile-maybe-push-heap-environment (&optional lforminfo)
  "Push a new heap environment if necessary.
LFORMINFO should be information about lexical variables being bound.
Return a lexical environment containing only the heap vector (or
nil if nothing was pushed).
Also, `byte-compile-current-heap-environment' and
`byte-compile-current-num-closures' are updated to reflect any change (so they
should probably be bound by the caller to ensure that the new values have the
proper scope)."
  ;; We decide whether a new heap environment is required by seeing if
  ;; the number of closures inside the form described by LFORMINFO is
  ;; the same as the number inside the binding form that created the
  ;; currently active heap environment.
  (let ((nclosures
         (and lforminfo (byte-compile-lforminfo-num-closures lforminfo))))
    (if (or (null lforminfo)
            (zerop nclosures)
            (= nclosures byte-compile-current-num-closures))
        ;; No need to push a heap environment.
        nil
      (error "Should have been handled by cconv")
      ;; Have to push one.  A heap environment is really just a vector, so
      ;; we emit bytecodes to create a vector.  However, the size is not
      ;; fixed yet (the vector can grow if subforms use it to store
      ;; values, and if `access points' to parent heap environments are
      ;; added), so we use `byte-compile-push-unknown-constant' to push the
      ;; vector size.
      (setq byte-compile-current-num-closures nclosures)
      (list (byte-compile-push-heapenv)))))

(defun byte-compile-bind (var init-lexenv &optional lforminfo)
  "Emit byte-codes to bind VAR and update `byte-compile-lexical-environment'.
INIT-LEXENV should be a lexical-environment alist describing the
positions of the init value that have been pushed on the stack, and
LFORMINFO should be information about lexical variables being bound.
Return non-nil if the TOS value was popped."
  ;; The presence of lexical bindings mean that we may have to
  ;; juggle things on the stack, either to move them to TOS for
  ;; dynamic binding, or to put them in a non-stack environment
  ;; vector.
  (let ((vinfo (assq var (byte-compile-lforminfo-vars lforminfo))))
    (cond ((and (null vinfo) (eq var (caar init-lexenv)))
           ;; VAR is dynamic and is on the top of the
           ;; stack, so we can just bind it like usual
           (byte-compile-dynamic-variable-bind var)
           t)
          ((null vinfo)
           ;; VAR is dynamic, but we have to get its
           ;; value out of the middle of the stack
           (let ((stack-pos (cdr (assq var init-lexenv))))
             (byte-compile-stack-ref stack-pos)
             (byte-compile-dynamic-variable-bind var)
             ;; Now we have to store nil into its temporary
             ;; stack position to avoid problems with GC
             (byte-compile-push-constant nil)
             (byte-compile-stack-set stack-pos))
           nil)
          ((byte-compile-lvarinfo-closed-over-p vinfo)
           ;; VAR is lexical, but needs to be in a
           ;; heap-allocated environment.
           (unless byte-compile-current-heap-environment
             (error "No current heap-environment to allocate `%s' in!" var))
           (let ((init-stack-pos
                  ;; nil if the init value is on the top of the stack,
                  ;; otherwise the position of the init value on the stack.
                  (and (not (eq var (caar init-lexenv)))
                       (byte-compile-lexvar-offset (assq var init-lexenv))))
                 (env-vec-pos
                  ;; Position of VAR in the environment vector
                  (byte-compile-lexvar-offset
                   (assq var byte-compile-lexical-environment)))
                 (env-vec-stack-pos
                  ;; Position of the the environment vector on the stack
                  ;; (the heap-environment must _always_ be available on
                  ;; the stack!)
                  (byte-compile-lexvar-offset
                   (assq byte-compile-current-heap-environment
                         byte-compile-lexical-environment))))
             (unless env-vec-stack-pos
               (error "Couldn't find location of current heap environment!"))
             (when init-stack-pos
               ;; VAR is not on the top of the stack, so get it
               (byte-compile-stack-ref init-stack-pos))
             (byte-compile-stack-ref env-vec-stack-pos)
             ;; Store the variable into the vector
             (byte-compile-out 'byte-vec-set env-vec-pos)
             (when init-stack-pos
               ;; Store nil into VAR's temporary stack
               ;; position to avoid problems with GC
               (byte-compile-push-constant nil)
               (byte-compile-stack-set init-stack-pos))
             ;; Push a record of VAR's new lexical binding
             (push (byte-compile-make-lexvar
                    var env-vec-pos byte-compile-current-heap-environment)
                   byte-compile-lexical-environment)
             (not init-stack-pos)))
          (t
           ;; VAR is a simple stack-allocated lexical variable
           (push (assq var init-lexenv)
                 byte-compile-lexical-environment)
           nil))))

(defun byte-compile-unbind (clauses init-lexenv
                                    &optional lforminfo preserve-body-value)
  "Emit byte-codes to unbind the variables bound by CLAUSES.
CLAUSES is a `let'-style variable binding list.  INIT-LEXENV should be a
lexical-environment alist describing the positions of the init value that
have been pushed on the stack, and LFORMINFO should be information about
the lexical variables that were bound.  If PRESERVE-BODY-VALUE is true,
then an additional value on the top of the stack, above any lexical binding
slots, is preserved, so it will be on the top of the stack after all
binding slots have been popped."
  ;; Unbind dynamic variables
  (let ((num-dynamic-bindings 0))
    (if lforminfo
        (dolist (clause clauses)
          (unless (assq (if (consp clause) (car clause) clause)
                        (byte-compile-lforminfo-vars lforminfo))
            (setq num-dynamic-bindings (1+ num-dynamic-bindings))))
      (setq num-dynamic-bindings (length clauses)))
    (unless (zerop num-dynamic-bindings)
      (byte-compile-out 'byte-unbind num-dynamic-bindings)))
  ;; Pop lexical variables off the stack, possibly preserving the
  ;; return value of the body.
  (when init-lexenv
    ;; INIT-LEXENV contains all init values left on the stack
    (byte-compile-discard (length init-lexenv) preserve-body-value)))


(provide 'byte-lexbind)

;;; byte-lexbind.el ends here