(defstruct): Treat multi-nested :include properly.

(flet): Warn when flet rebinds a macro name.
(labels): Rewrite to be fully CL-compliant.

diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 180a3f99bc82ef80dd48bab30ad85ca29fdc2cb5..25c897ac5f6d281c51a5a2b939d8f83b9e1721e9 100644 (file)
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -1222,6 +1222,10 @@ go back to their previous definitions, or lack thereof)."
         (mapcar
          (function
           (lambda (x)
+            (if (or (and (fboundp (car x))
+                         (eq (car-safe (symbol-function (car x))) 'macro))
+                    (cdr (assq (car x) cl-macro-environment)))
+                (error "Use `labels', not `flet', to rebind macro names"))
             (let ((func (list 'function*
                               (list 'lambda (cadr x)
                                     (list* 'block (car x) (cddr x))))))
@@ -1233,7 +1237,22 @@ go back to their previous definitions, or lack thereof)."
          bindings)
         body))
 
-(defmacro labels (&rest args) (cons 'flet args))
+(defmacro labels (bindings &rest body)
+  "(labels ((FUNC ARGLIST BODY...) ...) FORM...): make temporary func bindings.
+This is like `flet', except the bindings are lexical instead of dynamic.
+Unlike `flet', this macro is fully complaint with the Common Lisp standard."
+  (let ((vars nil) (sets nil) (cl-macro-environment cl-macro-environment))
+    (while bindings
+      (let ((var (gensym)))
+       (cl-push var vars)
+       (cl-push (list 'function* (cons 'lambda (cdar bindings))) sets)
+       (cl-push var sets)
+       (cl-push (list (car (cl-pop bindings)) 'lambda '(&rest cl-labels-args)
+                      (list 'list* '(quote funcall) (list 'quote var)
+                            'cl-labels-args))
+                cl-macro-environment)))
+    (cl-macroexpand-all (list* 'lexical-let vars (cons (cons 'setq sets) body))
+                       cl-macro-environment)))
 
 ;; The following ought to have a better definition for use with newer
 ;; byte compilers.
@@ -2017,7 +2036,6 @@ copier, a `NAME-p' predicate, and setf-able `NAME-SLOT' accessors."
         (tag (intern (format "cl-struct-%s" name)))
         (tag-symbol (intern (format "cl-struct-%s-tags" name)))
         (include-descs nil)
-        (include-tag-symbol nil)
         (side-eff nil)
         (type nil)
         (named nil)
@@ -2049,9 +2067,7 @@ copier, a `NAME-p' predicate, and setf-able `NAME-SLOT' accessors."
                     include-descs (mapcar (function
                                            (lambda (x)
                                              (if (consp x) x (list x))))
-                                          (cdr args))
-                    include-tag-symbol (intern (format "cl-struct-%s-tags"
-                                                       include))))
+                                          (cdr args))))
              ((eq opt ':print-function)
               (setq print-func (car args)))
              ((eq opt ':type)
@@ -2089,8 +2105,12 @@ copier, a `NAME-p' predicate, and setf-able `NAME-SLOT' accessors."
                type (car inc-type)
                named (assq 'cl-tag-slot descs))
          (if (cadr inc-type) (setq tag name named t))
-         (cl-push (list 'pushnew (list 'quote tag) include-tag-symbol)
-                  forms))
+         (let ((incl include))
+           (while incl
+             (cl-push (list 'pushnew (list 'quote tag)
+                            (intern (format "cl-struct-%s-tags" incl)))
+                      forms)
+             (setq incl (get incl 'cl-struct-include)))))
       (if type
          (progn
            (or (memq type '(vector list))
@@ -2197,6 +2217,8 @@ copier, a `NAME-p' predicate, and setf-able `NAME-SLOT' accessors."
                          (list 'quote descs))
                    (list 'put (list 'quote name) '(quote cl-struct-type)
                          (list 'quote (list type (eq named t))))
+                   (list 'put (list 'quote name) '(quote cl-struct-include)
+                         (list 'quote include))
                    (list 'put (list 'quote name) '(quote cl-struct-print)
                          print-auto)
                    (mapcar (function (lambda (x)