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

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

1 files changed, 29 insertions, 7 deletions

diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 180a3f99bc8..25c897ac5f6 100644
--- 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)