[Emacs-diffs] /srv/bzr/emacs/trunk r108514: Move old compatiblity to cl.el. Remove cl-macroexpand-all.

[Stefan Monnier]

------------------------------------------------------------
revno: 108514
committer: Stefan Monnier <address@hidden>
branch nick: trunk
timestamp: Thu 2012-06-07 15:48:22 -0400
message:
  Move old compatiblity to cl.el.  Remove cl-macroexpand-all.
  * emacs-lisp/cl-extra.el (cl-map-keymap, cl-copy-tree)
  (cl-not-hash-table, cl-builtin-gethash, cl-builtin-remhash)
  (cl-builtin-clrhash, cl-builtin-maphash, cl-gethash, cl-puthash)
  (cl-remhash, cl-clrhash, cl-maphash, cl-make-hash-table)
  (cl-hash-table-p, cl-hash-table-count): Move to cl.el.
  (cl-macroexpand-cmacs): Remove var.
  (cl-macroexpand-all, cl-macroexpand-body): Remove funs.
  Use macroexpand-all instead.
  
  * emacs-lisp/cl-lib.el (cl-macro-environment): Remove decl.
  (cl-macroexpand): Move to cl-macs.el and rename to cl--sm-macroexpand.
  (cl-member): Remove old alias.
  
  * emacs-lisp/cl-macs.el (cl-macro-environment): Remove var.
  Use macroexpand-all-environment instead.
  (cl--old-macroexpand): New var.
  (cl--sm-macroexpand): New function.
  (cl-symbol-macrolet): Use it during macro expansion.
  (cl--function-convert-cache): New var.
  (cl--function-convert): New function, extracted from
  cl-macroexpand-all.
  (cl-lexical-let): Use it.
  
  * emacs-lisp/cl.el (cl-macroexpand, cl-macro-environment)
  (cl-macroexpand-all, cl-not-hash-table, cl-builtin-gethash)
  (cl-builtin-remhash, cl-builtin-clrhash, cl-builtin-maphash)
  (cl-map-keymap, cl-copy-tree, cl-gethash, cl-puthash, cl-remhash)
  (cl-clrhash, cl-maphash, cl-make-hash-table, cl-hash-table-p)
  (cl-hash-table-count): Add old compatibility aliases.
modified:
  lisp/ChangeLog
  lisp/emacs-lisp/cl-extra.el
  lisp/emacs-lisp/cl-lib.el
  lisp/emacs-lisp/cl-loaddefs.el
  lisp/emacs-lisp/cl-macs.el
  lisp/emacs-lisp/cl.el

=== modified file 'lisp/ChangeLog'
--- a/lisp/ChangeLog    2012-06-07 19:25:48 +0000
+++ b/lisp/ChangeLog    2012-06-07 19:48:22 +0000
@@ -1,5 +1,37 @@
 2012-06-07  Stefan Monnier  <address@hidden>
 
+       * emacs-lisp/cl.el (cl-macroexpand, cl-macro-environment)
+       (cl-macroexpand-all, cl-not-hash-table, cl-builtin-gethash)
+       (cl-builtin-remhash, cl-builtin-clrhash, cl-builtin-maphash)
+       (cl-map-keymap, cl-copy-tree, cl-gethash, cl-puthash, cl-remhash)
+       (cl-clrhash, cl-maphash, cl-make-hash-table, cl-hash-table-p)
+       (cl-hash-table-count): Add old compatibility aliases.
+
+       * emacs-lisp/cl-macs.el (cl-macro-environment): Remove var.
+       Use macroexpand-all-environment instead.
+       (cl--old-macroexpand): New var.
+       (cl--sm-macroexpand): New function.
+       (cl-symbol-macrolet): Use it during macro expansion.
+       (cl--function-convert-cache): New var.
+       (cl--function-convert): New function, extracted from
+       cl-macroexpand-all.
+       (cl-lexical-let): Use it.
+
+       * emacs-lisp/cl-lib.el (cl-macro-environment): Remove decl.
+       (cl-macroexpand): Move to cl-macs.el and rename to cl--sm-macroexpand.
+       (cl-member): Remove old alias.
+
+       * emacs-lisp/cl-extra.el (cl-map-keymap, cl-copy-tree)
+       (cl-not-hash-table, cl-builtin-gethash, cl-builtin-remhash)
+       (cl-builtin-clrhash, cl-builtin-maphash, cl-gethash, cl-puthash)
+       (cl-remhash, cl-clrhash, cl-maphash, cl-make-hash-table)
+       (cl-hash-table-p, cl-hash-table-count): Move to cl.el.
+       (cl-macroexpand-cmacs): Remove var.
+       (cl-macroexpand-all, cl-macroexpand-body): Remove funs.
+       Use macroexpand-all instead.
+
+2012-06-07  Stefan Monnier  <address@hidden>
+
        * emacs-lisp/macroexp.el (macroexp-progn, macroexp-let*, macroexp-if)
        (macroexp-let², macroexp--const-symbol-p, macroexp-const-p)
        (macroexp-copyable-p): New functions and macros.

=== modified file 'lisp/emacs-lisp/cl-extra.el'
--- a/lisp/emacs-lisp/cl-extra.el       2012-06-04 01:05:17 +0000
+++ b/lisp/emacs-lisp/cl-extra.el       2012-06-07 19:48:22 +0000
@@ -221,10 +221,6 @@
 \n(fn PREDICATE SEQ...)"
   (not (apply 'cl-every cl-pred cl-seq cl-rest)))
 
-;;; Support for `cl-loop'.
-;;;###autoload
-(defalias 'cl-map-keymap 'map-keymap)
-
 ;;;###autoload
 (defun cl-map-keymap-recursively (cl-func-rec cl-map &optional cl-base)
   (or cl-base
@@ -460,7 +456,7 @@
   "Return a copy of random-state STATE, or of the internal state if omitted.
 If STATE is t, return a new state object seeded from the time of day."
   (cond ((null state) (cl-make-random-state cl--random-state))
-       ((vectorp state) (cl-copy-tree state t))
+       ((vectorp state) (copy-tree state t))
        ((integerp state) (vector 'cl-random-state-tag -1 30 state))
        (t (cl-make-random-state (cl-random-time)))))
 
@@ -585,9 +581,6 @@
     (setq list (cdr list)))
   (if (numberp sublist) (equal sublist list) (eq sublist list)))
 
-(defalias 'cl-copy-tree 'copy-tree)
-
-
 ;;; Property lists.
 
 ;;;###autoload
@@ -637,36 +630,6 @@
        (progn (setplist sym (cdr (cdr plist))) t)
       (cl-do-remf plist tag))))
 
-;;; Hash tables.
-;; This is just kept for compatibility with code byte-compiled by Emacs-20.
-
-;; No idea if this might still be needed.
-(defun cl-not-hash-table (x &optional y &rest z)
-  (signal 'wrong-type-argument (list 'cl-hash-table-p (or y x))))
-
-(defvar cl-builtin-gethash (symbol-function 'gethash))
-(defvar cl-builtin-remhash (symbol-function 'remhash))
-(defvar cl-builtin-clrhash (symbol-function 'clrhash))
-(defvar cl-builtin-maphash (symbol-function 'maphash))
-
-;;;###autoload
-(defalias 'cl-gethash 'gethash)
-;;;###autoload
-(defalias 'cl-puthash 'puthash)
-;;;###autoload
-(defalias 'cl-remhash 'remhash)
-;;;###autoload
-(defalias 'cl-clrhash 'clrhash)
-;;;###autoload
-(defalias 'cl-maphash 'maphash)
-;; These three actually didn't exist in Emacs-20.
-;;;###autoload
-(defalias 'cl-make-hash-table 'make-hash-table)
-;;;###autoload
-(defalias 'cl-hash-table-p 'hash-table-p)
-;;;###autoload
-(defalias 'cl-hash-table-count 'hash-table-count)
-
 ;;; Some debugging aids.
 
 (defun cl-prettyprint (form)
@@ -710,93 +673,13 @@
              (forward-char 1))))
     (forward-sexp)))
 
-(defvar cl-macroexpand-cmacs nil)
-(defvar cl-closure-vars nil)
-
-;;;###autoload
-(defun cl-macroexpand-all (form &optional env)
-  "Expand all macro calls through a Lisp FORM.
-This also does some trivial optimizations to make the form prettier."
-  (while (or (not (eq form (setq form (macroexpand form env))))
-            (and cl-macroexpand-cmacs
-                 (not (eq form (setq form (cl-compiler-macroexpand form)))))))
-  (cond ((not (consp form)) form)
-       ((memq (car form) '(let let*))
-        (if (null (nth 1 form))
-            (cl-macroexpand-all (cons 'progn (cddr form)) env)
-          (let ((letf nil) (res nil) (lets (cadr form)))
-            (while lets
-              (push (if (consp (car lets))
-                           (let ((exp (cl-macroexpand-all (caar lets) env)))
-                             (or (symbolp exp) (setq letf t))
-                             (cons exp (cl-macroexpand-body (cdar lets) env)))
-                         (let ((exp (cl-macroexpand-all (car lets) env)))
-                           (if (symbolp exp) exp
-                             (setq letf t) (list exp nil)))) res)
-              (setq lets (cdr lets)))
-            (cl-list* (if letf (if (eq (car form) 'let) 'cl-letf 'cl-letf*) 
(car form))
-                   (nreverse res) (cl-macroexpand-body (cddr form) env)))))
-       ((eq (car form) 'cond)
-        (cons (car form)
-              (mapcar (function (lambda (x) (cl-macroexpand-body x env)))
-                      (cdr form))))
-       ((eq (car form) 'condition-case)
-        (cl-list* (car form) (nth 1 form) (cl-macroexpand-all (nth 2 form) env)
-               (mapcar (function
-                        (lambda (x)
-                          (cons (car x) (cl-macroexpand-body (cdr x) env))))
-                       (cl-cdddr form))))
-       ((memq (car form) '(quote function))
-        (if (eq (car-safe (nth 1 form)) 'lambda)
-            (let ((body (cl-macroexpand-body (cl-cddadr form) env)))
-              (if (and cl-closure-vars (eq (car form) 'function)
-                       (cl-expr-contains-any body cl-closure-vars))
-                  (let* ((new (mapcar 'cl-gensym cl-closure-vars))
-                         (sub (cl-pairlis cl-closure-vars new)) (decls nil))
-                    (while (or (stringp (car body))
-                               (eq (car-safe (car body)) 'interactive))
-                      (push (list 'quote (pop body)) decls))
-                    (put (car (last cl-closure-vars)) 'used t)
-                     `(list 'lambda '(&rest --cl-rest--)
-                            ,@(cl-sublis sub (nreverse decls))
-                            (list 'apply
-                                  (list 'quote
-                                        #'(lambda ,(append new (cl-cadadr 
form))
-                                            ,@(cl-sublis sub body)))
-                                  ,@(nconc (mapcar (lambda (x) `(list 'quote 
,x))
-                                                   cl-closure-vars)
-                                           '((quote --cl-rest--))))))
-                (list (car form) (cl-list* 'lambda (cl-cadadr form) body))))
-          (let ((found (assq (cadr form) env)))
-            (if (and found (ignore-errors
-                             (eq (cadr (cl-caddr found)) 'cl-labels-args)))
-                (cl-macroexpand-all (cadr (cl-caddr (cl-cadddr found))) env)
-              form))))
-       ((memq (car form) '(defun defmacro))
-        (cl-list* (car form) (nth 1 form) (cl-macroexpand-body (cddr form) 
env)))
-       ((and (eq (car form) 'progn) (not (cddr form)))
-        (cl-macroexpand-all (nth 1 form) env))
-       ((eq (car form) 'setq)
-        (let* ((args (cl-macroexpand-body (cdr form) env)) (p args))
-          (while (and p (symbolp (car p))) (setq p (cddr p)))
-          (if p (cl-macroexpand-all (cons 'cl-setf args)) (cons 'setq args))))
-        ((consp (car form))
-         (cl-macroexpand-all (cl-list* 'funcall
-                                    (list 'function (car form))
-                                    (cdr form))
-                             env))
-       (t (cons (car form) (cl-macroexpand-body (cdr form) env)))))
-
-(defun cl-macroexpand-body (body &optional env)
-  (mapcar (function (lambda (x) (cl-macroexpand-all x env))) body))
-
 ;;;###autoload
 (defun cl-prettyexpand (form &optional full)
   (message "Expanding...")
   (let ((cl-macroexpand-cmacs full) (cl-compiling-file full)
        (byte-compile-macro-environment nil))
-    (setq form (cl-macroexpand-all form
-                                  (and (not full) '((cl-block) 
(cl-eval-when)))))
+    (setq form (macroexpand-all form
+                                (and (not full) '((cl-block) (cl-eval-when)))))
     (message "Formatting...")
     (prog1 (cl-prettyprint form)
       (message ""))))

=== modified file 'lisp/emacs-lisp/cl-lib.el'
--- a/lisp/emacs-lisp/cl-lib.el 2012-06-05 15:41:12 +0000
+++ b/lisp/emacs-lisp/cl-lib.el 2012-06-07 19:48:22 +0000
@@ -267,29 +267,6 @@
 one value."
   (nth n expression))
 
-;;; Macros.
-
-(defvar cl-macro-environment)
-(defvar cl-old-macroexpand (prog1 (symbol-function 'macroexpand)
-                            (defalias 'macroexpand 'cl-macroexpand)))
-
-(defun cl-macroexpand (cl-macro &optional cl-env)
-  "Return result of expanding macros at top level of FORM.
-If FORM is not a macro call, it is returned unchanged.
-Otherwise, the macro is expanded and the expansion is considered
-in place of FORM.  When a non-macro-call results, it is returned.
-
-The second optional arg ENVIRONMENT specifies an environment of macro
-definitions to shadow the loaded ones for use in file byte-compilation.
-\n(fn FORM &optional ENVIRONMENT)"
-  (let ((cl-macro-environment cl-env))
-    (while (progn (setq cl-macro (funcall cl-old-macroexpand cl-macro cl-env))
-                 (and (symbolp cl-macro)
-                      (cdr (assq (symbol-name cl-macro) cl-env))))
-      (setq cl-macro (cadr (assq (symbol-name cl-macro) cl-env))))
-    cl-macro))
-
-
 ;;; Declarations.
 
 (defvar cl-compiling-file nil)
@@ -600,8 +577,6 @@
   (while (and list (not (equal item (car list)))) (setq list (cdr list)))
   list)
 
-(defalias 'cl-member 'memq)   ; for compatibility with old CL package
-
 ;; Autoloaded, but we have not loaded cl-loaddefs yet.
 (declare-function cl-floor "cl-extra" (x &optional y))
 (declare-function cl-ceiling "cl-extra" (x &optional y))

=== modified file 'lisp/emacs-lisp/cl-loaddefs.el'
--- a/lisp/emacs-lisp/cl-loaddefs.el    2012-06-07 19:25:48 +0000
+++ b/lisp/emacs-lisp/cl-loaddefs.el    2012-06-07 19:48:22 +0000
@@ -3,16 +3,15 @@
 ;;; Code:
 
 
-;;;### (autoloads (cl-prettyexpand cl-macroexpand-all cl-remprop
-;;;;;;  cl-do-remf cl-set-getf cl-getf cl-get cl-tailp cl-list-length
-;;;;;;  cl-nreconc cl-revappend cl-concatenate cl-subseq cl-float-limits
-;;;;;;  cl-random-state-p cl-make-random-state cl-random cl-signum
-;;;;;;  cl-rem cl-mod cl-round cl-truncate cl-ceiling cl-floor cl-isqrt
-;;;;;;  cl-lcm cl-gcd cl-progv-before cl-set-frame-visible-p cl-map-overlays
-;;;;;;  cl-map-intervals cl-map-keymap-recursively cl-notevery cl-notany
-;;;;;;  cl-every cl-some cl-mapcon cl-mapcan cl-mapl cl-maplist cl-map
-;;;;;;  cl-mapcar-many cl-equalp cl-coerce) "cl-extra" "cl-extra.el"
-;;;;;;  "acc0000b09b27fb51f5ba23a4b9254e2")
+;;;### (autoloads (cl-prettyexpand cl-remprop cl-do-remf cl-set-getf
+;;;;;;  cl-getf cl-get cl-tailp cl-list-length cl-nreconc cl-revappend
+;;;;;;  cl-concatenate cl-subseq cl-float-limits cl-random-state-p
+;;;;;;  cl-make-random-state cl-random cl-signum cl-rem cl-mod cl-round
+;;;;;;  cl-truncate cl-ceiling cl-floor cl-isqrt cl-lcm cl-gcd cl-progv-before
+;;;;;;  cl-set-frame-visible-p cl-map-overlays cl-map-intervals 
cl-map-keymap-recursively
+;;;;;;  cl-notevery cl-notany cl-every cl-some cl-mapcon cl-mapcan
+;;;;;;  cl-mapl cl-maplist cl-map cl-mapcar-many cl-equalp cl-coerce)
+;;;;;;  "cl-extra" "cl-extra.el" "fecce2e361fd06364d2ffd8c0d482cd0")
 ;;; Generated autoloads from cl-extra.el
 
 (autoload 'cl-coerce "cl-extra" "\
@@ -83,8 +82,6 @@
 
 \(fn PREDICATE SEQ...)" nil nil)
 
-(defalias 'cl-map-keymap 'map-keymap)
-
 (autoload 'cl-map-keymap-recursively "cl-extra" "\
 
 
@@ -248,28 +245,6 @@
 
 \(fn SYMBOL PROPNAME)" nil nil)
 
-(defalias 'cl-gethash 'gethash)
-
-(defalias 'cl-puthash 'puthash)
-
-(defalias 'cl-remhash 'remhash)
-
-(defalias 'cl-clrhash 'clrhash)
-
-(defalias 'cl-maphash 'maphash)
-
-(defalias 'cl-make-hash-table 'make-hash-table)
-
-(defalias 'cl-hash-table-p 'hash-table-p)
-
-(defalias 'cl-hash-table-count 'hash-table-count)
-
-(autoload 'cl-macroexpand-all "cl-extra" "\
-Expand all macro calls through a Lisp FORM.
-This also does some trivial optimizations to make the form prettier.
-
-\(fn FORM &optional ENV)" nil nil)
-
 (autoload 'cl-prettyexpand "cl-extra" "\
 
 
@@ -289,7 +264,7 @@
 ;;;;;;  cl-return cl-block cl-etypecase cl-typecase cl-ecase cl-case
 ;;;;;;  cl-load-time-value cl-eval-when cl-destructuring-bind cl-function
 ;;;;;;  cl-defmacro cl-defun cl-gentemp cl-gensym) "cl-macs" "cl-macs.el"
-;;;;;;  "25086e27342ec0990f35f1748a5b7b4e")
+;;;;;;  "c1e8e5391e374630452ab3d78e527086")
 ;;; Generated autoloads from cl-macs.el
 
 (autoload 'cl-gensym "cl-macs" "\

=== modified file 'lisp/emacs-lisp/cl-macs.el'
--- a/lisp/emacs-lisp/cl-macs.el        2012-06-07 19:25:48 +0000
+++ b/lisp/emacs-lisp/cl-macs.el        2012-06-07 19:48:22 +0000
@@ -310,11 +310,6 @@
 (defconst cl-lambda-list-keywords
   '(&optional &rest &key &allow-other-keys &aux &whole &body &environment))
 
-(defvar cl-macro-environment nil
-  "Keep the list of currently active macros.
-It is a list of elements of the form either:
-- (SYMBOL . FUNCTION) where FUNCTION is the macro expansion function.
-- (SYMBOL-NAME . EXPANSION) where SYMBOL-NAME is the name of a symbol macro.")
 (defvar cl-bind-block) (defvar cl-bind-defs) (defvar cl-bind-enquote)
 (defvar cl-bind-inits) (defvar cl-bind-lets) (defvar cl-bind-forms)
 
@@ -367,9 +362,10 @@
     (if (setq cl-bind-enquote (memq '&cl-quote args))
        (setq args (delq '&cl-quote args)))
     (if (memq '&whole args) (error "&whole not currently implemented"))
-    (let* ((p (memq '&environment args)) (v (cadr p)))
+    (let* ((p (memq '&environment args)) (v (cadr p))
+           (env-exp 'macroexpand-all-environment))
       (if p (setq args (nconc (delq (car p) (delq v args))
-                             (list '&aux (list v 'cl-macro-environment))))))
+                              (list '&aux (list v env-exp))))))
     (while (and args (symbolp (car args))
                (not (memq (car args) '(nil &rest &body &key &aux)))
                (not (and (eq (car args) '&optional)
@@ -1630,7 +1626,7 @@
             (lambda (x)
               (if (or (and (fboundp (car x))
                            (eq (car-safe (symbol-function (car x))) 'macro))
-                      (cdr (assq (car x) cl-macro-environment)))
+                      (cdr (assq (car x) macroexpand-all-environment)))
                   (error "Use `cl-labels', not `cl-flet', to rebind macro 
names"))
               (let ((func `(cl-function
                             (lambda ,(cadr x)
@@ -1657,7 +1653,7 @@
 
 \(fn ((FUNC ARGLIST BODY...) ...) FORM...)"
   (declare (indent 1) (debug cl-flet))
-  (let ((vars nil) (sets nil) (cl-macro-environment cl-macro-environment))
+  (let ((vars nil) (sets nil) (newenv macroexpand-all-environment))
     (while bindings
       ;; Use `cl-gensym' rather than `make-symbol'.  It's important that
       ;; (not (eq (symbol-name var1) (symbol-name var2))) because these
@@ -1670,9 +1666,8 @@
                     `(lambda (&rest cl-labels-args)
                        (cl-list* 'funcall ',var
                                  cl-labels-args)))
-              cl-macro-environment)))
-    (cl-macroexpand-all `(cl-lexical-let ,vars (setq ,@sets) ,@body)
-                       cl-macro-environment)))
+              newenv)))
+    (macroexpand-all `(cl-lexical-let ,vars (setq ,@sets) ,@body) newenv)))
 
 ;; The following ought to have a better definition for use with newer
 ;; byte compilers.
@@ -1693,9 +1688,42 @@
       (let* ((name (caar bindings))
             (res (cl--transform-lambda (cdar bindings) name)))
        (eval (car res))
-       (cl-macroexpand-all (cons 'progn body)
-                           (cons (cons name `(lambda ,@(cdr res)))
-                                 cl-macro-environment))))))
+       (macroexpand-all (cons 'progn body)
+                         (cons (cons name `(lambda ,@(cdr res)))
+                               macroexpand-all-environment))))))
+
+(defconst cl--old-macroexpand
+  (if (and (boundp 'cl--old-macroexpand)
+           (eq (symbol-function 'macroexpand)
+               #'cl--sm-macroexpand))
+      cl--old-macroexpand
+    (symbol-function 'macroexpand)))
+
+(defun cl--sm-macroexpand (cl-macro &optional cl-env)
+  "Special macro expander used inside `cl-symbol-macrolet'.
+This function replaces `macroexpand' during macro expansion
+of `cl-symbol-macrolet', and does the same thing as `macroexpand'
+except that it additionally expands symbol macros."
+  (let ((macroexpand-all-environment cl-env))
+    (while
+        (progn
+          (setq cl-macro (funcall cl--old-macroexpand cl-macro cl-env))
+          (cond
+           ((symbolp cl-macro)
+            ;; Perform symbol-macro expansion.
+            (when (cdr (assq (symbol-name cl-macro) cl-env))
+              (setq cl-macro (cadr (assq (symbol-name cl-macro) cl-env)))))
+           ((eq 'setq (car-safe cl-macro))
+            ;; Convert setq to cl-setf if required by symbol-macro expansion.
+            (let* ((args (mapcar (lambda (f) (cl--sm-macroexpand f cl-env))
+                                 (cdr cl-macro)))
+                   (p args))
+              (while (and p (symbolp (car p))) (setq p (cddr p)))
+              (if p (setq cl-macro (cons 'cl-setf args))
+                (setq cl-macro (cons 'setq args))
+                ;; Don't loop further.
+                nil))))))
+    cl-macro))
 
 ;;;###autoload
 (defmacro cl-symbol-macrolet (bindings &rest body)
@@ -1705,16 +1733,71 @@
 
 \(fn ((NAME EXPANSION) ...) FORM...)"
   (declare (indent 1) (debug ((&rest (symbol sexp)) cl-declarations body)))
-  (if (cdr bindings)
+  (cond
+   ((cdr bindings)
       `(cl-symbol-macrolet (,(car bindings))
-         (cl-symbol-macrolet ,(cdr bindings) ,@body))
-    (if (null bindings) (cons 'progn body)
-      (cl-macroexpand-all (cons 'progn body)
+       (cl-symbol-macrolet ,(cdr bindings) ,@body)))
+   ((null bindings) (macroexp-progn body))
+   (t
+    (let ((previous-macroexpand (symbol-function 'macroexpand)))
+      (unwind-protect
+          (progn
+            (fset 'macroexpand #'cl--sm-macroexpand)
+            ;; FIXME: For N bindings, this will traverse `body' N times!
+            (macroexpand-all (cons 'progn body)
                          (cons (list (symbol-name (caar bindings))
                                      (cl-cadar bindings))
-                               cl-macro-environment)))))
+                                   macroexpand-all-environment)))
+        (fset 'macroexpand previous-macroexpand))))))
 
 (defvar cl-closure-vars nil)
+(defvar cl--function-convert-cache nil)
+
+(defun cl--function-convert (f)
+  "Special macro-expander for special cases of (function F).
+The two cases that are handled are:
+- closure-conversion of lambda expressions for `cl-lexical-let'.
+- renaming of F when it's a function defined via `cl-labels'."
+  (cond
+   ;; ¡¡Big Ugly Hack!! We can't use a compiler-macro because those are checked
+   ;; *after* handling `function', but we want to stop macroexpansion from
+   ;; being applied infinitely, so we use a cache to return the exact `form'
+   ;; being expanded even though we don't receive it.
+   ((eq f (car cl--function-convert-cache)) (cdr cl--function-convert-cache))
+   ((eq (car-safe f) 'lambda)
+    (let ((body (mapcar (lambda (f)
+                          (macroexpand-all f macroexpand-all-environment))
+                        (cddr f))))
+      (if (and cl-closure-vars
+               (cl--expr-contains-any body cl-closure-vars))
+          (let* ((new (mapcar 'cl-gensym cl-closure-vars))
+                 (sub (cl-pairlis cl-closure-vars new)) (decls nil))
+            (while (or (stringp (car body))
+                       (eq (car-safe (car body)) 'interactive))
+              (push (list 'quote (pop body)) decls))
+            (put (car (last cl-closure-vars)) 'used t)
+            `(list 'lambda '(&rest --cl-rest--)
+                   ,@(cl-sublis sub (nreverse decls))
+                   (list 'apply
+                         (list 'quote
+                               #'(lambda ,(append new (cadr f))
+                                   ,@(cl-sublis sub body)))
+                         ,@(nconc (mapcar (lambda (x) `(list 'quote ,x))
+                                          cl-closure-vars)
+                                  '((quote --cl-rest--))))))
+        (let* ((newf `(lambda ,(cadr f) ,@body))
+               (res `(function ,newf)))
+          (setq cl--function-convert-cache (cons newf res))
+          res))))
+   (t
+    (let ((found (assq f macroexpand-all-environment)))
+      (if (and found (ignore-errors
+                       (eq (cadr (cl-caddr found)) 'cl-labels-args)))
+          (cadr (cl-caddr (cl-cadddr found)))
+        (let ((res `(function ,f)))
+          (setq cl--function-convert-cache (cons f res))
+          res))))))
+
 ;;;###autoload
 (defmacro cl-lexical-let (bindings &rest body)
   "Like `let', but lexically scoped.
@@ -1732,13 +1815,14 @@
                          (list (car x) (cadr x) (car cl-closure-vars))))
                       bindings))
         (ebody
-         (cl-macroexpand-all
+         (macroexpand-all
            `(cl-symbol-macrolet
                 ,(mapcar (lambda (x)
                            `(,(car x) (symbol-value ,(cl-caddr x))))
                          vars)
               ,@body)
-           cl-macro-environment)))
+          (cons (cons 'function #'cl--function-convert)
+                 macroexpand-all-environment))))
     (if (not (get (car (last cl-closure-vars)) 'used))
         ;; Turn (let ((foo (cl-gensym)))
         ;;        (set foo <val>) ...(symbol-value foo)...)
@@ -2132,7 +2216,7 @@
 ;; This is useful when you have control over the PLACE but not over
 ;; the VALUE, as is the case in define-minor-mode's :variable.
 (cl-define-setf-expander eq (place val)
-  (let ((method (cl-get-setf-method place cl-macro-environment))
+  (let ((method (cl-get-setf-method place macroexpand-all-environment))
         (val-temp (make-symbol "--eq-val--"))
         (store-temp (make-symbol "--eq-store--")))
     (list (append (nth 0 method) (list val-temp))
@@ -2146,14 +2230,14 @@
 ;;; More complex setf-methods.
 ;; These should take &environment arguments, but since full arglists aren't
 ;; available while compiling cl-macs, we fake it by referring to the global
-;; variable cl-macro-environment directly.
+;; variable macroexpand-all-environment directly.
 
 (cl-define-setf-expander apply (func arg1 &rest rest)
   (or (and (memq (car-safe func) '(quote function cl-function))
           (symbolp (car-safe (cdr-safe func))))
       (error "First arg to apply in cl-setf is not (function SYM): %s" func))
   (let* ((form (cons (nth 1 func) (cons arg1 rest)))
-        (method (cl-get-setf-method form cl-macro-environment)))
+        (method (cl-get-setf-method form macroexpand-all-environment)))
     (list (car method) (nth 1 method) (nth 2 method)
          (cl-setf-make-apply (nth 3 method) (cadr func) (car method))
          (cl-setf-make-apply (nth 4 method) (cadr func) (car method)))))
@@ -2166,7 +2250,7 @@
     `(apply ',(car form) ,@(cdr form))))
 
 (cl-define-setf-expander nthcdr (n place)
-  (let ((method (cl-get-setf-method place cl-macro-environment))
+  (let ((method (cl-get-setf-method place macroexpand-all-environment))
        (n-temp (make-symbol "--cl-nthcdr-n--"))
        (store-temp (make-symbol "--cl-nthcdr-store--")))
     (list (cons n-temp (car method))
@@ -2179,7 +2263,7 @@
          `(nthcdr ,n-temp ,(nth 4 method)))))
 
 (cl-define-setf-expander cl-getf (place tag &optional def)
-  (let ((method (cl-get-setf-method place cl-macro-environment))
+  (let ((method (cl-get-setf-method place macroexpand-all-environment))
        (tag-temp (make-symbol "--cl-getf-tag--"))
        (def-temp (make-symbol "--cl-getf-def--"))
        (store-temp (make-symbol "--cl-getf-store--")))
@@ -2192,7 +2276,7 @@
          `(cl-getf ,(nth 4 method) ,tag-temp ,def-temp))))
 
 (cl-define-setf-expander substring (place from &optional to)
-  (let ((method (cl-get-setf-method place cl-macro-environment))
+  (let ((method (cl-get-setf-method place macroexpand-all-environment))
        (from-temp (make-symbol "--cl-substring-from--"))
        (to-temp (make-symbol "--cl-substring-to--"))
        (store-temp (make-symbol "--cl-substring-store--")))
@@ -2220,7 +2304,7 @@
                    (method (get func 'setf-method))
                    (case-fold-search nil))
               (or (and method
-                       (let ((cl-macro-environment env))
+                       (let ((macroexpand-all-environment env))
                          (setq method (apply method (cdr place))))
                        (if (and (consp method) (= (length method) 5))
                            method
@@ -2240,7 +2324,7 @@
          (cl-get-setf-method place env)))))
 
 (defun cl-setf-do-modify (place opt-expr)
-  (let* ((method (cl-get-setf-method place cl-macro-environment))
+  (let* ((method (cl-get-setf-method place macroexpand-all-environment))
         (temps (car method)) (values (nth 1 method))
         (lets nil) (subs nil)
         (optimize (and (not (eq opt-expr 'no-opt))

=== modified file 'lisp/emacs-lisp/cl.el'
--- a/lisp/emacs-lisp/cl.el     2012-06-07 19:25:48 +0000
+++ b/lisp/emacs-lisp/cl.el     2012-06-07 19:48:22 +0000
@@ -330,5 +330,37 @@
       (if (get new prop)
         (put fun prop (get new prop))))))
 
+;;; Additional compatibility code
+;; For names that were clean but really aren't needed any more.
+
+(defalias 'cl-macroexpand 'macroexpand)
+(defvaralias 'cl-macro-environment 'macroexpand-all-environment)
+(defalias 'cl-macroexpand-all 'macroexpand-all)
+
+;;; Hash tables.
+;; This is just kept for compatibility with code byte-compiled by Emacs-20.
+
+;; No idea if this might still be needed.
+(defun cl-not-hash-table (x &optional y &rest z)
+  (signal 'wrong-type-argument (list 'cl-hash-table-p (or y x))))
+
+(defvar cl-builtin-gethash (symbol-function 'gethash))
+(defvar cl-builtin-remhash (symbol-function 'remhash))
+(defvar cl-builtin-clrhash (symbol-function 'clrhash))
+(defvar cl-builtin-maphash (symbol-function 'maphash))
+
+(defalias 'cl-map-keymap 'map-keymap)
+(defalias 'cl-copy-tree 'copy-tree)
+(defalias 'cl-gethash 'gethash)
+(defalias 'cl-puthash 'puthash)
+(defalias 'cl-remhash 'remhash)
+(defalias 'cl-clrhash 'clrhash)
+(defalias 'cl-maphash 'maphash)
+(defalias 'cl-make-hash-table 'make-hash-table)
+(defalias 'cl-hash-table-p 'hash-table-p)
+(defalias 'cl-hash-table-count 'hash-table-count)
+
+;; FIXME: More candidates: define-modify-macro, define-setf-expander, 
lexical-let.
+
 (provide 'cl)
 ;;; cl.el ends here