--- a/lisp/ChangeLog	Sun Sep 04 20:35:31 2011 +0100
+++ b/lisp/ChangeLog	Sun Sep 04 20:37:55 2011 +0100
@@ -1,3 +1,55 @@
+2011-09-04  Aidan Kehoe  <kehoea@parhasard.net>
+
+	* bytecomp-runtime.el:
+	* bytecomp-runtime.el (byte-compile-macro-environment): Moved from
+	bytecomp.el.
+	* bytecomp.el:
+	* bytecomp.el (byte-compile-initial-macro-environment):
+	Add implementations for #'load-time-value, #'labels here, now
+	cl-macs respects byte-compile-macro-environment.
+	* bytecomp.el (byte-compile-function-environment):
+	* bytecomp.el (byte-compile-macro-environment): Removed.
+	* bytecomp.el (symbol-value):
+	* bytecomp.el (byte-compile-symbol-value): Removed.
+	* cl-extra.el (cl-macroexpand-all):
+	* cl-macs.el:
+	* cl-macs.el (bind-block):
+	* cl-macs.el (cl-macro-environment): Removed.
+	* cl-macs.el (cl-transform-lambda):
+	* cl-macs.el (load-time-value):
+	* cl-macs.el (block):
+	* cl-macs.el (flet):
+	* cl-macs.el (labels):
+	* cl-macs.el (macrolet):
+	* cl-macs.el (symbol-macrolet):
+	* cl-macs.el (lexical-let):
+	* cl-macs.el (apply):
+	* cl-macs.el (nthcdr):
+	* cl-macs.el (getf):
+	* cl-macs.el (substring):
+	* cl-macs.el (values):
+	* cl-macs.el (get-setf-method):
+	* cl-macs.el (cl-setf-do-modify):
+	* cl.el:
+	* cl.el (cl-macro-environment): Removed.
+	* cl.el (cl-macroexpand):
+	* obsolete.el (cl-macro-environment): Moved here.
+
+	Drop cl-macro-environment, in favour of
+	byte-compile-macro-environment; make the latter available in
+	bytecomp-runtime.el. This makes byte-compile-macro-environment far
+	less useless, since previously code that used cl-macs would ignore
+	it when calling #'cl-macroexpand-all.
+
+	Add byte-compiler-specific implementations for #'load-time-value,
+	#'labels. The latter is very nice indeed; it avoids the run-time
+	consing of the current implementation, is fully lexical and avoids
+	the run-time shadowing of symbol function slots that flet uses. It
+	would now be reasonable to move most core uses of flet to use
+	labels instead. Non-core code can't rely on print-circle for
+	mutually recursive functions, though, so it's less of an evident
+	win.
+
 2011-09-04  Aidan Kehoe  <kehoea@parhasard.net>
 
 	* cl-macs.el (get-char-table): Add a defsetf for this.

--- a/lisp/bytecomp-runtime.el	Sun Sep 04 20:35:31 2011 +0100
+++ b/lisp/bytecomp-runtime.el	Sun Sep 04 20:37:55 2011 +0100
@@ -634,4 +634,9 @@
       (file-format emacs19))"
   nil)
 
+(defvar byte-compile-macro-environment nil
+  "Alist of macros defined in the file being compiled.
+Each element looks like (MACRONAME . DEFINITION).  It is
+\(MACRONAME . nil) when a macro is redefined as a function.")
+
 ;;; bytecomp-runtime.el ends here

--- a/lisp/bytecomp.el	Sun Sep 04 20:35:31 2011 +0100
+++ b/lisp/bytecomp.el	Sun Sep 04 20:37:55 2011 +0100
@@ -491,16 +491,71 @@
 		    "%s is not of type %s" form type)))
 	   (if byte-compile-delete-errors
 	       form
-	     (funcall (cdr (symbol-function 'the)) type form)))))
+	     (funcall (cdr (symbol-function 'the)) type form))))
+    (load-time-value
+     . ,#'(lambda (form &optional read-only)
+            (let* ((gensym (gensym))
+                   (byte-compile-bound-variables
+                    (acons gensym byte-compile-global-bit
+                           byte-compile-bound-variables)))
+              (setq byte-compile-output-preface
+                    (byte-compile-top-level
+                     `(progn (setq ,gensym ,form) ,byte-compile-output-preface)
+                     t 'file))
+              `(symbol-value ',gensym))))
+    (labels
+        . ,#'(lambda (bindings &rest body)
+               (let* ((bindings
+                       (mapcar (function*
+                                (lambda ((name . binding))
+                                  (list* name 'lambda
+                                         (cdr (cl-transform-lambda binding
+                                                                   name)))))
+                               bindings))
+                      ;; These placeholders are to ensure that the
+                      ;; lexically-scoped functions can be called from each
+                      ;; other.
+                      (placeholders
+                       (mapcar #'(lambda (binding)
+                                   (cons (car binding)
+                                         (make-byte-code (third binding)
+                                                         "\xc0\x87" [42] 1)))
+                               bindings))
+                      (byte-compile-macro-environment
+                       (nconc
+                        (mapcar
+                         (function*
+                          (lambda ((name . placeholder))
+                            (cons name `(lambda (&rest cl-labels-args)
+                                          (list* 'funcall ,placeholder
+                                                 cl-labels-args)))))
+                         placeholders)
+                        byte-compile-macro-environment))
+                      placeholder-map)
+                 (setq bindings
+                       (mapcar (function*
+                                (lambda ((name . lambda))
+                                  (cons name (byte-compile-lambda lambda))))
+                               bindings)
+                       placeholder-map
+                       (mapcar (function*
+                                (lambda ((name . compiled-function))
+                                  (cons (cdr (assq name placeholders))
+                                        compiled-function)))
+                               bindings))
+                 (loop
+                   for (placeholder . compiled-function)
+                   in placeholder-map
+                   do (nsubst compiled-function placeholder bindings
+                              :test 'eq :descend-structures t))
+                 (cl-macroexpand-all (cons 'progn body)
+                                     (sublis placeholder-map
+                                             byte-compile-macro-environment
+                                             :test 'eq))))))
   "The default macro-environment passed to macroexpand by the compiler.
 Placing a macro here will cause a macro to have different semantics when
 expanded by the compiler as when expanded by the interpreter.")
 
-(defvar byte-compile-macro-environment byte-compile-initial-macro-environment
-  "Alist of macros defined in the file being compiled.
-Each element looks like (MACRONAME . DEFINITION).  It is
-\(MACRONAME . nil) when a macro is redefined as a function.")
-
 (defvar byte-compile-function-environment nil
   "Alist of functions defined in the file being compiled.
 This is so we can inline them when necessary.
@@ -3086,7 +3141,7 @@
 (byte-defop-compiler car		1)
 (byte-defop-compiler cdr		1)
 (byte-defop-compiler length		1)
-(byte-defop-compiler symbol-value)
+(byte-defop-compiler symbol-value       1)
 (byte-defop-compiler symbol-function	1)
 (byte-defop-compiler (1+ byte-add1)	1)
 (byte-defop-compiler (1- byte-sub1)	1)
@@ -4237,29 +4292,6 @@
   (byte-compile-out 'byte-temp-output-buffer-setup 0)
   (byte-compile-body (cdr (cdr form)))
   (byte-compile-out 'byte-temp-output-buffer-show 0))
-
-(defun byte-compile-symbol-value (form)
-  (symbol-macrolet ((not-present '#:not-present))
-    (let ((cl-load-time-value-form not-present)
-          (byte-compile-bound-variables byte-compile-bound-variables) gensym)
-      (and (consp (cadr form))
-           (eq 'quote (caadr form))
-           (setq gensym (cadadr form))
-           (symbolp gensym)
-           (setq cl-load-time-value-form
-                 (get gensym 'cl-load-time-value-form not-present)))
-      (unless (eq cl-load-time-value-form not-present)        
-        (setq byte-compile-bound-variables
-              (acons gensym byte-compile-global-bit
-                     byte-compile-bound-variables)
-              byte-compile-output-preface
-              (byte-compile-top-level
-               (if byte-compile-output-preface
-                   `(progn (setq ,gensym ,cl-load-time-value-form)
-                           ,byte-compile-output-preface)
-                 `(setq ,gensym ,cl-load-time-value-form))
-               t 'file)))
-      (byte-compile-one-arg form))))
   
 (defun byte-compile-multiple-value-call (form)
   (if (< (length form) 2)

--- a/lisp/cl-extra.el	Sun Sep 04 20:35:31 2011 +0100
+++ b/lisp/cl-extra.el	Sun Sep 04 20:37:55 2011 +0100
@@ -609,13 +609,18 @@
 					     cl-closure-vars)
 				     '((quote --cl-rest--)))))))
 		 (list (car form) (list* 'lambda (cadadr form) body))))
-	   (let ((found (assq (cadr form) env)))
-	     ;; XEmacs: cadr/caddr operate on nil without errors. But the
-	     ;; macro definition may be compiled, in which case there's
-	     ;; nothing for us to do.
-	     (if (and (listp (cdr found))
-		      (eq (cadr (caddr found)) 'cl-labels-args))
-		 (cl-macroexpand-all (cadr (caddr (cadddr found))) env)
+           ;; This is a bit of a hack; special-case symbols with bindings as
+           ;; labels.
+	   (let ((found (cdr (assq (cadr form) env))))
+	     (if (and (consp found) (eq (nth 1 (nth 1 found)) 'cl-labels-args))
+                 (if (consp (nth 2 (nth 2 found)))
+                     ;; It's a cons; this is the implementation of
+                     ;; labels in cl-macs.el.
+                     (cl-macroexpand-all (nth 1 (nth 2 (nth 2 found))) env)
+                   ;; It's an atom, almost certainly a compiled function;
+                   ;; we're using the implementation of labels in
+                   ;; bytecomp.el.
+                  (nth 2 (nth 2 found)))
 	       form))))
 	((memq (car form) '(defun defmacro))
 	 (list* (car form) (nth 1 form) (cl-macroexpand-body (cddr form) env)))

--- a/lisp/cl-macs.el	Sun Sep 04 20:35:31 2011 +0100
+++ b/lisp/cl-macs.el	Sun Sep 04 20:37:55 2011 +0100
@@ -297,7 +297,6 @@
 (defconst lambda-list-keywords
   '(&optional &rest &key &allow-other-keys &aux &whole &body &environment))
 
-(defvar cl-macro-environment nil)
 (defvar bind-block) (defvar bind-defs) (defvar bind-enquote)
 (defvar bind-lets) (defvar bind-forms)
 
@@ -370,7 +369,7 @@
     (if (memq '&whole args) (error "&whole not currently implemented"))
     (let* ((p (memq '&environment args)) (v (cadr p)))
       (if p (setq args (nconc (delq (car p) (delq v args))
-			      (list '&aux (list v 'cl-macro-environment))))))
+                              `(&aux (,v byte-compile-macro-environment))))))
     (while (and args (symbolp (car args))
 		(not (memq (car args) '(nil &rest &body &key &aux)))
 		(not (and (eq (car args) '&optional)
@@ -626,15 +625,7 @@
 (defmacro load-time-value (form &optional read-only)
   "Like `progn', but evaluates the body at load time.
 The result of the body appears to the compiler as a quoted constant."
-  (let ((gensym (gensym)))
-    ;; The body of this macro really should be (cons 'progn form), with the
-    ;; hairier stuff in a shadowed version in
-    ;; byte-compile-initial-macro-environment. That doesn't work because
-    ;; cl-macs.el doesn't respect byte-compile-macro-environment, which is
-    ;; something we should change.
-    (put gensym 'cl-load-time-value-form form)
-    (set gensym (eval form))
-    `(symbol-value ',gensym)))
+  (list 'progn form))
 
 ;;; Conditional control structures.
 
@@ -746,7 +737,7 @@
     ;; as such it can eliminate it if that's appropriate:
     (put (cdar cl-active-block-names) 'cl-block-name name)
     `(catch ',(cdar cl-active-block-names)
-      ,(cl-macroexpand-all body cl-macro-environment))))
+      ,(cl-macroexpand-all body byte-compile-macro-environment))))
 
 ;;;###autoload
 (defmacro return (&optional result)
@@ -1738,7 +1729,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) byte-compile-macro-environment)))
 		  (error "Use `labels', not `flet', to rebind macro names"))
 	      (let ((func (list 'function*
 				(list 'lambda (cadr x)
@@ -1758,18 +1749,20 @@
 Unlike `flet', this macro is fully compliant with the Common Lisp standard.
 
 arguments: (((FUNC ARGLIST &body BODY) &rest FUNCTIONS) &body FORM)"
-  (let ((vars nil) (sets nil) (cl-macro-environment cl-macro-environment))
+  (let ((vars nil) (sets nil)
+        (byte-compile-macro-environment byte-compile-macro-environment))
     (while bindings
       (let ((var (gensym)))
 	(push var vars)
-	(push (list 'function* (cons 'lambda (cdar bindings))) sets)
+	(push `#'(lambda ,@(cdr (cl-transform-lambda (cdar bindings)
+                                                     (caar bindings)))) sets)
 	(push var sets)
 	(push (list (car (pop bindings)) 'lambda '(&rest cl-labels-args)
 		       (list 'list* '(quote funcall) (list 'quote var)
 			     'cl-labels-args))
-		 cl-macro-environment)))
+		 byte-compile-macro-environment)))
     (cl-macroexpand-all (list* 'lexical-let vars (cons (cons 'setq sets) body))
-			cl-macro-environment)))
+			byte-compile-macro-environment)))
 
 ;; The following ought to have a better definition for use with newer
 ;; byte compilers.
@@ -1785,7 +1778,7 @@
                          collect
                          (list* name 'lambda (cdr (cl-transform-lambda details
                                                                        name))))
-                       cl-macro-environment)))
+                       byte-compile-macro-environment)))
 
 ;;;###autoload
 (defmacro* symbol-macrolet ((&rest symbol-macros) &body form)
@@ -1798,7 +1791,7 @@
 			       for (name expansion) in symbol-macros
 			       do (check-type name symbol)
 			       collect (list (eq-hash name) expansion))
-			     cl-macro-environment)))
+			     byte-compile-macro-environment)))
 
 (defvar cl-closure-vars nil)
 ;;;###autoload
@@ -1824,7 +1817,7 @@
 				    t))
 			  vars)
 		  (list '(defun . cl-defun-expander))
-		  cl-macro-environment))))
+		  byte-compile-macro-environment))))
     (if (not (get (car (last cl-closure-vars)) 'used))
 	(list 'let (mapcar #'(lambda (x) (list (caddr x) (cadr x))) vars)
 	      (sublis (mapcar #'(lambda (x)
@@ -2336,14 +2329,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 byte-compile-macro-environment directly.
 
 (define-setf-method apply (func arg1 &rest rest)
   (or (and (memq (car-safe func) '(quote function function*))
 	   (symbolp (car-safe (cdr-safe func))))
       (error "First arg to apply in setf is not (function SYM): %s" func))
   (let* ((form (cons (nth 1 func) (cons arg1 rest)))
-	 (method (get-setf-method form cl-macro-environment)))
+	 (method (get-setf-method form byte-compile-macro-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)))))
@@ -2356,7 +2349,7 @@
     (list* 'apply (list 'quote (car form)) (cdr form))))
 
 (define-setf-method nthcdr (n place)
-  (let ((method (get-setf-method place cl-macro-environment))
+  (let ((method (get-setf-method place byte-compile-macro-environment))
 	(n-temp (gensym "--nthcdr-n--"))
 	(store-temp (gensym "--nthcdr-store--")))
     (list (cons n-temp (car method))
@@ -2369,7 +2362,7 @@
 	  (list 'nthcdr n-temp (nth 4 method)))))
 
 (define-setf-method getf (place tag &optional def)
-  (let ((method (get-setf-method place cl-macro-environment))
+  (let ((method (get-setf-method place byte-compile-macro-environment))
 	(tag-temp (gensym "--getf-tag--"))
 	(def-temp (gensym "--getf-def--"))
 	(store-temp (gensym "--getf-store--")))
@@ -2383,7 +2376,7 @@
 	  (list 'getf (nth 4 method) tag-temp def-temp))))
 
 (define-setf-method substring (place from &optional to)
-  (let ((method (get-setf-method place cl-macro-environment))
+  (let ((method (get-setf-method place byte-compile-macro-environment))
 	(from-temp (gensym "--substring-from--"))
 	(to-temp (gensym "--substring-to--"))
 	(store-temp (gensym "--substring-store--")))
@@ -2399,7 +2392,7 @@
 ;; XEmacs addition
 (define-setf-method values (&rest args)
   (let ((methods (mapcar #'(lambda (x)
-			     (get-setf-method x cl-macro-environment))
+			     (get-setf-method x byte-compile-macro-environment))
 			 args))
 	(store-temp (gensym "--values-store--")))
     (list (apply 'append (mapcar 'first methods))
@@ -2428,7 +2421,7 @@
 		    (method (get func 'setf-method))
 		    (case-fold-search nil))
 	       (or (and method
-			(let ((cl-macro-environment env))
+			(let ((byte-compile-macro-environment env))
 			  (setq method (apply method (cdr place))))
 			(if (and (consp method) (eql (length method) 5))
 			    method
@@ -2449,7 +2442,7 @@
 	  (get-setf-method place env)))))
 
 (defun cl-setf-do-modify (place opt-expr)
-  (let* ((method (get-setf-method place cl-macro-environment))
+  (let* ((method (get-setf-method place byte-compile-macro-environment))
 	 (temps (car method)) (values (nth 1 method))
 	 (lets nil) (subs nil)
 	 (optimize (and (not (eq opt-expr 'no-opt))

--- a/lisp/cl.el	Sun Sep 04 20:35:31 2011 +0100
+++ b/lisp/cl.el	Sun Sep 04 20:37:55 2011 +0100
@@ -213,7 +213,6 @@
 
 ;;; Macros.
 
-(defvar cl-macro-environment nil)
 ;; XEmacs: we renamed the internal function to macroexpand-internal
 ;; to avoid doc-file problems.
 (defvar cl-old-macroexpand (prog1 (symbol-function 'macroexpand-internal)
@@ -227,17 +226,19 @@
 
 The second optional arg ENVIRONMENT specifies an environment of macro
 definitions to shadow the loaded ones for use in file byte-compilation."
-  (let ((cl-macro-environment
-	 (if cl-macro-environment (append cl-env cl-macro-environment) cl-env))
+  (let ((byte-compile-macro-environment
+	 (if byte-compile-macro-environment
+             (append cl-env byte-compile-macro-environment) cl-env))
 	eq-hash)
     (while (progn (setq cl-macro
-			(macroexpand-internal cl-macro cl-macro-environment))
+			(macroexpand-internal cl-macro
+                                              byte-compile-macro-environment))
 		  (and (symbolp cl-macro)
 		       (setq eq-hash (eq-hash cl-macro))
 		       (cdr (if (fixnump eq-hash)
-                                (assq eq-hash cl-macro-environment)
-                              (assoc eq-hash cl-macro-environment)))))
-      (setq cl-macro (cadr (assoc* eq-hash cl-macro-environment))))
+                                (assq eq-hash byte-compile-macro-environment)
+                              (assoc eq-hash byte-compile-macro-environment)))))
+      (setq cl-macro (cadr (assoc* eq-hash byte-compile-macro-environment))))
     cl-macro))
 
 ;;; Declarations.

--- a/lisp/obsolete.el	Sun Sep 04 20:35:31 2011 +0100
+++ b/lisp/obsolete.el	Sun Sep 04 20:37:55 2011 +0100
@@ -449,5 +449,8 @@
 (define-function 'memql 'member*)
 (make-compatible 'memql "use the more full-featured `member*' instead.")
 
+(define-obsolete-variable-alias 'cl-macro-environment
+  'byte-compile-macro-environment)
+
 (provide 'obsolete)
 ;;; obsolete.el ends here