Add classes as run-time descriptors of cl-structs.

* lisp/emacs-lisp/cl-preloaded.el (cl--struct-get-class): New function.
(cl--make-slot-desc): New constructor.
(cl--plist-remove, cl--struct-register-child): New functions.
(cl-struct-define): Rewrite.
(cl-structure-class, cl-structure-object, cl-slot-descriptor)
(cl--class): New structs.
(cl--struct-default-parent): Initialize it here.
* lisp/emacs-lisp/cl-macs.el (cl--find-class): New macro.
(cl-defsubst, cl--defsubst-expand, cl--sublis): Move before first use.
(cl--struct-default-parent): New var.
(cl-defstruct): Adjust to new representation of classes; add
default parent.  In accessors, signal `wrong-type-argument' rather than
a generic error.
(cl-struct-sequence-type, cl-struct-slot-info)
(cl-struct-slot-offset): Rewrite.
* lisp/emacs-lisp/cl-generic.el (cl--generic-struct-specializers)
(cl-generic-generalizers): Rewrite.
* src/alloc.c (purecopy): Handle hash-tables.

* lisp/emacs-lisp/debug.el (debug--implement-debug-on-entry):
Bind inhibit-debug-on-entry here...
(debug): Instead of here.

* lisp/emacs-lisp/macroexp.el (macroexp--debug-eager): New var.
(internal-macroexpand-for-load): Use it.

* lwlib/xlwmenu.c (pop_up_menu): Remove debugging code.

5 files changed, 362 insertions, 147 deletions

diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index 41c760e960e..c9ca92d7c09 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -857,6 +857,18 @@ Can only be used from within the lexical body of a primary or around method."
 ;;; Support for cl-defstructs specializers.
 
 (defun cl--generic-struct-tag (name)
+  ;; It's tempting to use (and (vectorp ,name) (aref ,name 0))
+  ;; but that would suffer from some problems:
+  ;; - the vector may have size 0.
+  ;; - when called on an actual vector (rather than an object), we'd
+  ;;   end up returning an arbitrary value, possibly colliding with
+  ;;   other tagcode's values.
+  ;; - it can also result in returning all kinds of irrelevant
+  ;;   values which would end up filling up the method-cache with
+  ;;   lots of irrelevant/redundant entries.
+  ;; FIXME: We could speed this up by introducing a dedicated
+  ;; vector type at the C level, so we could do something like
+  ;; (and (vector-objectp ,name) (aref ,name 0))
   `(and (vectorp ,name)
         (> (length ,name) 0)
         (let ((tag (aref ,name 0)))
@@ -864,14 +876,18 @@ Can only be used from within the lexical body of a primary or around method."
               tag))))
 
 (defun cl--generic-struct-specializers (tag)
-  (and (symbolp tag)
-       ;; A method call shouldn't itself mess with the match-data.
-       (string-match-p "\\`cl-struct-\\(.*\\)" (symbol-name tag))
-       (let ((types (list (intern (substring (symbol-name tag) 10)))))
-	 (while (get (car types) 'cl-struct-include)
-	   (push (get (car types) 'cl-struct-include) types))
-	 (push 'cl-structure-object types) ;The "parent type" of all cl-structs.
-	 (nreverse types))))
+  (and (symbolp tag) (boundp tag)
+       (let ((class (symbol-value tag)))
+         (when (cl-typep class 'cl-structure-class)
+           (let ((types ())
+                 (classes (list class)))
+             ;; BFS precedence.
+             (while (let ((class (pop classes)))
+                      (push (cl--class-name class) types)
+                      (setq classes
+                            (append classes
+                                    (cl--class-parents class)))))
+             (nreverse types))))))
 
 (defconst cl--generic-struct-generalizer
   (cl-generic-make-generalizer
@@ -881,27 +897,17 @@ Can only be used from within the lexical body of a primary or around method."
 (cl-defmethod cl-generic-generalizers :extra "cl-struct" (type)
   "Support for dispatch on cl-struct types."
   (or
-   (and (symbolp type)
-        (get type 'cl-struct-type)
-        (or (null (car (get type 'cl-struct-type)))
-            (error "Can't dispatch on cl-struct %S: type is %S"
-                   type (car (get type 'cl-struct-type))))
-        (or (equal '(cl-tag-slot) (car (get type 'cl-struct-slots)))
-            (error "Can't dispatch on cl-struct %S: no tag in slot 0"
-                   type))
-        ;; It's tempting to use (and (vectorp ,name) (aref ,name 0))
-        ;; but that would suffer from some problems:
-        ;; - the vector may have size 0.
-        ;; - when called on an actual vector (rather than an object), we'd
-        ;;   end up returning an arbitrary value, possibly colliding with
-        ;;   other tagcode's values.
-        ;; - it can also result in returning all kinds of irrelevant
-        ;;   values which would end up filling up the method-cache with
-        ;;   lots of irrelevant/redundant entries.
-        ;; FIXME: We could speed this up by introducing a dedicated
-        ;; vector type at the C level, so we could do something like
-        ;; (and (vector-objectp ,name) (aref ,name 0))
-        (list cl--generic-struct-generalizer))
+   (when (symbolp type)
+     ;; Use the "cl--struct-class*" (inlinable) functions/macros rather than
+     ;; the "cl-struct-*" variants which aren't inlined, so that dispatch can
+     ;; take place without requiring cl-lib.
+     (let ((class (cl--find-class type)))
+       (and (cl-typep class 'cl-structure-class)
+            (when (cl--struct-class-type class)
+              (error "Can't dispatch on cl-struct %S: type is %S"
+                     type (cl--struct-class-type class)))
+            (progn (cl-assert (null (cl--struct-class-named class))) t)
+            (list cl--generic-struct-generalizer))))
    (cl-call-next-method)))
 
 ;;; Dispatch on "system types".
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 56fbcf0b2fd..d3866783447 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -2434,8 +2434,79 @@ Like `cl-callf', but PLACE is the second argument of FUNC, not the first.
                    (if (symbolp func) (cons func rargs)
                      `(funcall #',func ,@rargs))))))))
 
+;;;###autoload
+(defmacro cl-defsubst (name args &rest body)
+  "Define NAME as a function.
+Like `defun', except the function is automatically declared `inline' and
+the arguments are immutable.
+ARGLIST allows full Common Lisp conventions, and BODY is implicitly
+surrounded by (cl-block NAME ...).
+The function's arguments should be treated as immutable.
+
+\(fn NAME ARGLIST [DOCSTRING] BODY...)"
+  (declare (debug cl-defun) (indent 2))
+  (let* ((argns (cl--arglist-args args))
+         (p argns)
+         ;; (pbody (cons 'progn body))
+         )
+    (while (and p (eq (cl--expr-contains args (car p)) 1)) (pop p))
+    `(progn
+       ,(if p nil   ; give up if defaults refer to earlier args
+          `(cl-define-compiler-macro ,name
+             ,(if (memq '&key args)
+                  `(&whole cl-whole &cl-quote ,@args)
+                (cons '&cl-quote args))
+             (cl--defsubst-expand
+              ',argns '(cl-block ,name ,@body)
+              ;; We used to pass `simple' as
+              ;; (not (or unsafe (cl-expr-access-order pbody argns)))
+              ;; But this is much too simplistic since it
+              ;; does not pay attention to the argvs (and
+              ;; cl-expr-access-order itself is also too naive).
+              nil
+              ,(and (memq '&key args) 'cl-whole) nil ,@argns)))
+       (cl-defun ,name ,args ,@body))))
+
+(defun cl--defsubst-expand (argns body simple whole _unsafe &rest argvs)
+  (if (and whole (not (cl--safe-expr-p (cons 'progn argvs)))) whole
+    (if (cl--simple-exprs-p argvs) (setq simple t))
+    (let* ((substs ())
+           (lets (delq nil
+                       (cl-mapcar (lambda (argn argv)
+                                    (if (or simple (macroexp-const-p argv))
+                                        (progn (push (cons argn argv) substs)
+                                               nil)
+                                      (list argn argv)))
+                                  argns argvs))))
+      ;; FIXME: `sublis/subst' will happily substitute the symbol
+      ;; `argn' in places where it's not used as a reference
+      ;; to a variable.
+      ;; FIXME: `sublis/subst' will happily copy `argv' to a different
+      ;; scope, leading to name capture.
+      (setq body (cond ((null substs) body)
+                       ((null (cdr substs))
+                        (cl-subst (cdar substs) (caar substs) body))
+                       (t (cl--sublis substs body))))
+      (if lets `(let ,lets ,body) body))))
+
+(defun cl--sublis (alist tree)
+  "Perform substitutions indicated by ALIST in TREE (non-destructively)."
+  (let ((x (assq tree alist)))
+    (cond
+     (x (cdr x))
+     ((consp tree)
+      (cons (cl--sublis alist (car tree)) (cl--sublis alist (cdr tree))))
+     (t tree))))
+
 ;;; Structures.
 
+(defmacro cl--find-class (type)
+  `(get ,type 'cl--class))
+
+;; Rather than hard code cl-structure-object, we indirect through this variable
+;; for bootstrapping reasons.
+(defvar cl--struct-default-parent nil)
+
 ;;;###autoload
 (defmacro cl-defstruct (struct &rest descs)
   "Define a struct type.
@@ -2491,6 +2562,7 @@ non-nil value, that slot cannot be set via `setf'.
 	 (tag (intern (format "cl-struct-%s" name)))
 	 (tag-symbol (intern (format "cl-struct-%s-tags" name)))
 	 (include-descs nil)
+	 (include-name nil)
 	 (type nil)
 	 (named nil)
 	 (forms nil)
@@ -2520,12 +2592,14 @@ non-nil value, that slot cannot be set via `setf'.
 	      ((eq opt :predicate)
 	       (if args (setq predicate (car args))))
 	      ((eq opt :include)
-               (when include (error "Can't :include more than once"))
-	       (setq include (car args)
-		     include-descs (mapcar (function
-					    (lambda (x)
-					      (if (consp x) x (list x))))
-					   (cdr args))))
+               ;; FIXME: Actually, we can include more than once as long as
+               ;; we include EIEIO classes rather than cl-structs!
+               (when include-name (error "Can't :include more than once"))
+               (setq include-name (car args))
+               (setq include-descs (mapcar (function
+                                            (lambda (x)
+                                              (if (consp x) x (list x))))
+                                           (cdr args))))
 	      ((eq opt :print-function)
 	       (setq print-func (car args)))
 	      ((eq opt :type)
@@ -2537,19 +2611,21 @@ non-nil value, that slot cannot be set via `setf'.
 				  descs)))
 	      (t
 	       (error "Slot option %s unrecognized" opt)))))
+    (unless (or include-name type)
+      (setq include-name cl--struct-default-parent))
+    (when include-name (setq include (cl--struct-get-class include-name)))
     (if print-func
 	(setq print-func
               `(progn (funcall #',print-func cl-x cl-s cl-n) t))
-      (or type (and include (not (get include 'cl-struct-print)))
+      (or type (and include (not (cl--struct-class-print include)))
 	  (setq print-auto t
 		print-func (and (or (not (or include type)) (null print-func))
 				`(progn
                                    (princ ,(format "#S(%s" name) cl-s))))))
     (if include
-	(let ((inc-type (get include 'cl-struct-type))
-	      (old-descs (get include 'cl-struct-slots)))
-	  (or inc-type (error "%s is not a struct name" include))
-	  (and type (not (eq (car inc-type) type))
+	(let* ((inc-type (cl--struct-class-type include))
+               (old-descs (cl-struct-slot-info include)))
+	  (and type (not (eq inc-type type))
 	       (error ":type disagrees with :include for %s" name))
 	  (while include-descs
 	    (setcar (memq (or (assq (caar include-descs) old-descs)
@@ -2558,9 +2634,9 @@ non-nil value, that slot cannot be set via `setf'.
 			  old-descs)
 		    (pop include-descs)))
 	  (setq descs (append old-descs (delq (assq 'cl-tag-slot descs) descs))
-		type (car inc-type)
-		named (assq 'cl-tag-slot descs))
-	  (if (cadr inc-type) (setq tag name named t)))
+		type inc-type
+		named (if type (assq 'cl-tag-slot descs) 'true))
+	  (if (cl--struct-class-named include) (setq tag name named t)))
       (if type
 	  (progn
 	    (or (memq type '(vector list))
@@ -2605,8 +2681,8 @@ non-nil value, that slot cannot be set via `setf'.
                        (declare (side-effect-free t))
                        ,@(and pred-check
 			      (list `(or ,pred-check
-                                         (error "%s accessing a non-%s"
-                                                ',accessor ',name))))
+                                         (signal 'wrong-type-argument
+                                                 (list ',name cl-x)))))
                        ,(if (memq type '(nil vector)) `(aref cl-x ,pos)
                           (if (= pos 0) '(car cl-x)
                             `(nth ,pos cl-x))))
@@ -2682,8 +2758,11 @@ non-nil value, that slot cannot be set via `setf'.
     `(progn
        (defvar ,tag-symbol)
        ,@(nreverse forms)
+       ;; Call cl-struct-define during compilation as well, so that
+       ;; a subsequent cl-defstruct in the same file can correctly include this
+       ;; struct as a parent.
        (eval-and-compile
-         (cl-struct-define ',name ,docstring ',include
+         (cl-struct-define ',name ,docstring ',include-name
                            ',type ,(eq named t) ',descs ',tag-symbol ',tag
                            ',print-auto))
        ',name)))
@@ -2693,7 +2772,7 @@ non-nil value, that slot cannot be set via `setf'.
 STRUCT-TYPE is a symbol naming a struct type.  Return 'vector or
 'list, or nil if STRUCT-TYPE is not a struct type. "
   (declare (side-effect-free t) (pure t))
-  (car (get struct-type 'cl-struct-type)))
+  (cl--struct-class-type (cl--struct-get-class struct-type)))
 
 (defun cl-struct-slot-info (struct-type)
   "Return a list of slot names of struct STRUCT-TYPE.
@@ -2702,7 +2781,19 @@ slot name symbol and OPTS is a list of slot options given to
 `cl-defstruct'.  Dummy slots that represent the struct name and
 slots skipped by :initial-offset may appear in the list."
   (declare (side-effect-free t) (pure t))
-  (get struct-type 'cl-struct-slots))
+  (let* ((class (cl--struct-get-class struct-type))
+         (slots (cl--struct-class-slots class))
+         (type (cl--struct-class-type class))
+         (descs (if type () (list '(cl-tag-slot)))))
+    (dotimes (i (length slots))
+      (let ((slot (aref slots i)))
+        (push `(,(cl--slot-descriptor-name slot)
+                ,(cl--slot-descriptor-initform slot)
+                ,@(if (not (eq (cl--slot-descriptor-type slot) t))
+                      `(:type ,(cl--slot-descriptor-type slot)))
+                ,@(cl--slot-descriptor-props slot))
+              descs)))
+    (nreverse descs)))
 
 (defun cl-struct-slot-offset (struct-type slot-name)
   "Return the offset of slot SLOT-NAME in STRUCT-TYPE.
@@ -2711,9 +2802,8 @@ the structure data type and is adjusted for any structure name
 and :initial-offset slots.  Signal error if struct STRUCT-TYPE
 does not contain SLOT-NAME."
   (declare (side-effect-free t) (pure t))
-  (or (cl-position slot-name
-                   (cl-struct-slot-info struct-type)
-                   :key #'car :test #'eq)
+  (or (gethash slot-name
+               (cl--class-index-table (cl--struct-get-class struct-type)))
       (error "struct %s has no slot %s" struct-type slot-name)))
 
 (defvar byte-compile-function-environment)
@@ -2898,70 +2988,6 @@ macro that returns its `&whole' argument."
     (if cl-found (setcdr cl-found t)))
   `(throw ,cl-tag ,cl-value))
 
-;;;###autoload
-(defmacro cl-defsubst (name args &rest body)
-  "Define NAME as a function.
-Like `defun', except the function is automatically declared `inline' and
-the arguments are immutable.
-ARGLIST allows full Common Lisp conventions, and BODY is implicitly
-surrounded by (cl-block NAME ...).
-The function's arguments should be treated as immutable.
-
-\(fn NAME ARGLIST [DOCSTRING] BODY...)"
-  (declare (debug cl-defun) (indent 2))
-  (let* ((argns (cl--arglist-args args))
-         (p argns)
-         ;; (pbody (cons 'progn body))
-         )
-    (while (and p (eq (cl--expr-contains args (car p)) 1)) (pop p))
-    `(progn
-       ,(if p nil   ; give up if defaults refer to earlier args
-          `(cl-define-compiler-macro ,name
-             ,(if (memq '&key args)
-                  `(&whole cl-whole &cl-quote ,@args)
-                (cons '&cl-quote args))
-             (cl--defsubst-expand
-              ',argns '(cl-block ,name ,@body)
-              ;; We used to pass `simple' as
-              ;; (not (or unsafe (cl-expr-access-order pbody argns)))
-              ;; But this is much too simplistic since it
-              ;; does not pay attention to the argvs (and
-              ;; cl-expr-access-order itself is also too naive).
-              nil
-              ,(and (memq '&key args) 'cl-whole) nil ,@argns)))
-       (cl-defun ,name ,args ,@body))))
-
-(defun cl--defsubst-expand (argns body simple whole _unsafe &rest argvs)
-  (if (and whole (not (cl--safe-expr-p (cons 'progn argvs)))) whole
-    (if (cl--simple-exprs-p argvs) (setq simple t))
-    (let* ((substs ())
-           (lets (delq nil
-                       (cl-mapcar (lambda (argn argv)
-                                    (if (or simple (macroexp-const-p argv))
-                                        (progn (push (cons argn argv) substs)
-                                               nil)
-                                      (list argn argv)))
-                                  argns argvs))))
-      ;; FIXME: `sublis/subst' will happily substitute the symbol
-      ;; `argn' in places where it's not used as a reference
-      ;; to a variable.
-      ;; FIXME: `sublis/subst' will happily copy `argv' to a different
-      ;; scope, leading to name capture.
-      (setq body (cond ((null substs) body)
-                       ((null (cdr substs))
-                        (cl-subst (cdar substs) (caar substs) body))
-                       (t (cl--sublis substs body))))
-      (if lets `(let ,lets ,body) body))))
-
-(defun cl--sublis (alist tree)
-  "Perform substitutions indicated by ALIST in TREE (non-destructively)."
-  (let ((x (assq tree alist)))
-    (cond
-     (x (cdr x))
-     ((consp tree)
-      (cons (cl--sublis alist (car tree)) (cl--sublis alist (cdr tree))))
-     (t tree))))
-
 ;; Compile-time optimizations for some functions defined in this package.
 
 (defun cl--compiler-macro-member (form a list &rest keys)
diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el
index 401d34b449e..a18e0e57b05 100644
--- a/lisp/emacs-lisp/cl-preloaded.el
+++ b/lisp/emacs-lisp/cl-preloaded.el
@@ -21,36 +21,22 @@
 
 ;;; Commentary:
 
-;; The expectation is that structs defined with cl-defstruct do not
-;; need cl-lib at run-time, but we'd like to hide the details of the
-;; cl-struct metadata behind the cl-struct-define function, so we put
-;; it in this pre-loaded file.
+;; The cl-defstruct macro is full of circularities, since it uses the
+;; cl-structure-class type (and its accessors) which is defined with itself,
+;; and it setups a default parent (cl-structure-object) which is also defined
+;; with cl-defstruct, and to make things more interesting, the class of
+;; cl-structure-object is of course an object of type cl-structure-class while
+;; cl-structure-class's parent is cl-structure-object.
+;; Furthermore, the code generated by cl-defstruct generally assumes that the
+;; parent will be loaded when the child is loaded.  But at the same time, the
+;; expectation is that structs defined with cl-defstruct do not need cl-lib at
+;; run-time, which means that the `cl-structure-object' parent can't be in
+;; cl-lib but should be preloaded.  So here's this preloaded circular setup.
 
 ;;; Code:
 
 (eval-when-compile (require 'cl-lib))
-
-(defun cl-struct-define (name docstring parent type named slots children-sym
-                              tag print-auto)
-  (cl-assert (or type (equal '(cl-tag-slot) (car slots))))
-  (cl-assert (or type (not named)))
-  (if (boundp children-sym)
-      (add-to-list children-sym tag)
-    (set children-sym (list tag)))
-  (let* ((parent-class parent))
-    (while parent-class
-      (add-to-list (intern (format "cl-struct-%s-tags" parent-class)) tag)
-      (setq parent-class (get parent-class 'cl-struct-include))))
-  ;; If the cl-generic support, we need to be able to check
-  ;; if a vector is a cl-struct object, without knowing its particular type.
-  ;; So we use the (otherwise) unused function slots of the tag symbol
-  ;; to put a special witness value, to make the check easy and reliable.
-  (unless named (fset tag :quick-object-witness-check))
-  (put name 'cl-struct-slots slots)
-  (put name 'cl-struct-type (list type named))
-  (if parent (put name 'cl-struct-include parent))
-  (if print-auto (put name 'cl-struct-print print-auto))
-  (if docstring (put name 'structure-documentation docstring)))
+(eval-when-compile (require 'cl-macs))  ;For cl--struct-class.
 
 ;; The `assert' macro from the cl package signals
 ;; `cl-assertion-failed' at runtime so always define it.
@@ -63,6 +49,199 @@
         (apply #'error string (append sargs args))
       (signal 'cl-assertion-failed `(,form ,@sargs)))))
 
+;; When we load this (compiled) file during pre-loading, the cl--struct-class
+;; code below will need to access the `cl-struct' info, since it's considered
+;; already as its parent (because `cl-struct' was defined while the file was
+;; compiled).  So let's temporarily setup a fake.
+(defvar cl-struct-cl-structure-object-tags nil)
+(unless (cl--find-class 'cl-structure-object)
+  (setf (cl--find-class 'cl-structure-object) 'dummy))
+
+(fset 'cl--make-slot-desc
+      ;; To break circularity, we pre-define the slot constructor by hand.
+      ;; It's redefined a bit further down as part of the cl-defstruct of
+      ;; cl--slot-descriptor.
+      ;; BEWARE: Obviously, it's important to keep the two in sync!
+      (lambda (name &optional initform type props)
+        (vector 'cl-struct-cl-slot-descriptor
+                name initform type props)))
+
+(defun cl--struct-get-class (name)
+  (or (if (not (symbolp name)) name)
+      (cl--find-class name)
+      (if (not (get name 'cl-struct-type))
+          ;; FIXME: Add a conversion for `eieio--class' so we can
+          ;; create a cl-defstruct that inherits from an eieio class?
+          (error "%S is not a struct name" name)
+        ;; Backward compatibility with a defstruct compiled with a version
+        ;; cl-defstruct from Emacs<25.  Convert to new format.
+        (let ((tag (intern (format "cl-struct-%s" name)))
+              (type-and-named (get name 'cl-struct-type))
+              (descs (get name 'cl-struct-slots)))
+          (cl-struct-define name nil (get name 'cl-struct-include)
+                            (unless (and (eq (car type-and-named) 'vector)
+                                         (null (cadr type-and-named))
+                                         (assq 'cl-tag-slot descs))
+                              (car type-and-named))
+                            (cadr type-and-named)
+                            descs
+                            (intern (format "cl-struct-%s-tags" name))
+                            tag
+                            (get name 'cl-struct-print))
+          (cl--find-class name)))))
+
+(defun cl--plist-remove (plist member)
+  (cond
+   ((null plist) nil)
+   ((null member) plist)
+   ((eq plist member) (cddr plist))
+   (t `(,(car plist) ,(cadr plist) ,@(cl--plist-remove (cddr plist) member)))))
+
+(defun cl--struct-register-child (parent tag)
+  ;; Can't use (cl-typep parent 'cl-structure-class) at this stage
+  ;; because `cl-structure-class' is defined later.
+  (while (vectorp parent)
+    (add-to-list (cl--struct-class-children-sym parent) tag)
+    ;; Only register ourselves as a child of the leftmost parent since structs
+    ;; can only only have one parent.
+    (setq parent (car (cl--struct-class-parents parent)))))
+
+;;;###autoload
+(defun cl-struct-define (name docstring parent type named slots children-sym
+                              tag print)
+  (cl-assert (or type (not named)))
+  (if (boundp children-sym)
+      (add-to-list children-sym tag)
+    (set children-sym (list tag)))
+  (and (null type) (eq (caar slots) 'cl-tag-slot)
+       ;; Hide the tag slot from "standard" (i.e. non-`type'd) structs.
+       (setq slots (cdr slots)))
+  (let* ((parent-class (when parent (cl--struct-get-class parent)))
+         (n (length slots))
+         (index-table (make-hash-table :test 'eq :size n))
+         (vslots (let ((v (make-vector n nil))
+                       (i 0)
+                       (offset (if type 0 1)))
+                   (dolist (slot slots)
+                     (let* ((props (cddr slot))
+                            (typep (plist-member props :type))
+                            (type (if typep (cadr typep) t)))
+                       (aset v i (cl--make-slot-desc
+                                  (car slot) (nth 1 slot)
+                                  type (cl--plist-remove props typep))))
+                     (puthash (car slot) (+ i offset) index-table)
+                     (cl-incf i))
+                   v))
+         (class (cl--struct-new-class
+                 name docstring
+                 (unless (symbolp parent-class) (list parent-class))
+                 type named vslots index-table children-sym tag print)))
+    (unless (symbolp parent-class)
+      (let ((pslots (cl--struct-class-slots parent-class)))
+        (or (>= n (length pslots))
+            (let ((ok t))
+              (dotimes (i (length pslots))
+                (unless (eq (cl--slot-descriptor-name (aref pslots i))
+                            (cl--slot-descriptor-name (aref vslots i)))
+                  (setq ok nil)))
+              ok)
+            (error "Included struct %S has changed since compilation of %S"
+                   parent name))))
+    (cl--struct-register-child parent-class tag)
+    (unless (eq named t)
+      (eval `(defconst ,tag ',class) t)
+      ;; In the cl-generic support, we need to be able to check
+      ;; if a vector is a cl-struct object, without knowing its particular type.
+      ;; So we use the (otherwise) unused function slots of the tag symbol
+      ;; to put a special witness value, to make the check easy and reliable.
+      (fset tag :quick-object-witness-check))
+    (setf (cl--find-class name) class)))
+
+(cl-defstruct (cl-structure-class
+               (:conc-name cl--struct-class-)
+               (:predicate cl--struct-class-p)
+               (:constructor nil)
+               (:constructor cl--struct-new-class
+                (name docstring parents type named slots index-table
+                      children-sym tag print))
+               (:copier nil))
+  "The type of CL structs descriptors."
+  ;; The first few fields here are actually inherited from cl--class, but we
+  ;; have to define this one before, to break the circularity, so we manually
+  ;; list the fields here and later "backpatch" cl--class as the parent.
+  ;; BEWARE: Obviously, it's indispensable to keep these two structs in sync!
+  (name nil :type symbol)               ;The type name.
+  (docstring nil :type string)
+  (parents nil :type (list-of cl--class)) ;The included struct.
+  (slots nil :type (vector cl--slot-descriptor))
+  (index-table nil :type hash-table)
+  (tag nil :type symbol) ;Placed in cl-tag-slot.  Holds the struct-class object.
+  (type nil :type (memq (vector list)))
+  (named nil :type bool)
+  (print nil :type bool)
+  (children-sym nil :type symbol) ;This sym's value holds the tags of children.
+  )
+
+(cl-defstruct (cl-structure-object
+               (:predicate cl-struct-p)
+               (:constructor nil)
+               (:copier nil))
+  "The root parent of all \"normal\" CL structs")
+
+(setq cl--struct-default-parent 'cl-structure-object)
+
+(cl-defstruct (cl-slot-descriptor
+               (:conc-name cl--slot-descriptor-)
+               (:constructor nil)
+               (:constructor cl--make-slot-descriptor
+                (name &optional initform type props))
+               (:copier cl--copy-slot-descriptor))
+  ;; FIXME: This is actually not used yet, for circularity reasons!
+  "Descriptor of structure slot."
+  name                                  ;Attribute name (symbol).
+  initform
+  type
+  ;; Extra properties, kept in an alist, can include:
+  ;;  :documentation, :protection, :custom, :label, :group, :printer.
+  (props nil :type alist))
+
+(cl-defstruct (cl--class
+               (:constructor nil)
+               (:copier nil))
+  "Type of descriptors for any kind of structure-like data."
+  ;; Intended to be shared between defstruct and defclass.
+  (name nil :type symbol)               ;The type name.
+  (docstring nil :type string)
+  (parents nil :type (or cl--class (list-of cl--class)))
+  (slots nil :type (vector cl-slot-descriptor))
+  (index-table nil :type hash-table))
+
+(cl-assert
+ (let ((sc-slots (cl--struct-class-slots (cl--find-class 'cl-structure-class)))
+       (c-slots (cl--struct-class-slots (cl--find-class 'cl--class)))
+       (eq t))
+   (dotimes (i (length c-slots))
+     (let ((sc-slot (aref sc-slots i))
+           (c-slot (aref c-slots i)))
+       (unless (eq (cl--slot-descriptor-name sc-slot)
+                   (cl--slot-descriptor-name c-slot))
+         (setq eq nil))))
+   eq))
+
+;; Close the recursion between cl-structure-object and cl-structure-class.
+(setf (cl--struct-class-parents (cl--find-class 'cl-structure-class))
+      (list (cl--find-class 'cl--class)))
+(cl--struct-register-child
+ (cl--find-class 'cl--class)
+ (cl--struct-class-tag (cl--find-class 'cl-structure-class)))
+
+(cl-assert (cl--find-class 'cl-structure-class))
+(cl-assert (cl--find-class 'cl-structure-object))
+(cl-assert (cl-struct-p (cl--find-class 'cl-structure-class)))
+(cl-assert (cl-struct-p (cl--find-class 'cl-structure-object)))
+(cl-assert (cl--class-p (cl--find-class 'cl-structure-class)))
+(cl-assert (cl--class-p (cl--find-class 'cl-structure-object)))
+
 ;; Make sure functions defined with cl-defsubst can be inlined even in
 ;; packages which do not require CL.  We don't put an autoload cookie
 ;; directly on that function, since those cookies only go to cl-loaddefs.
diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el
index 8c1440d02f3..83213285d4e 100644
--- a/lisp/emacs-lisp/debug.el
+++ b/lisp/emacs-lisp/debug.el
@@ -106,10 +106,10 @@ This is to optimize `debugger-make-xrefs'.")
   "Non-nil if we expect to get back in the debugger soon.")
 
 (defvar inhibit-debug-on-entry nil
-  "Non-nil means that debug-on-entry is disabled.")
+  "Non-nil means that `debug-on-entry' is disabled.")
 
 (defvar debugger-jumping-flag nil
-  "Non-nil means that debug-on-entry is disabled.
+  "Non-nil means that `debug-on-entry' is disabled.
 This variable is used by `debugger-jump', `debugger-step-through',
 and `debugger-reenable' to temporarily disable debug-on-entry.")
 
@@ -165,7 +165,6 @@ first will be printed into the backtrace buffer."
       ;; Don't let these magic variables affect the debugger itself.
       (let ((last-command nil) this-command track-mouse
 	    (inhibit-trace t)
-	    (inhibit-debug-on-entry t)
 	    unread-command-events
 	    unread-post-input-method-events
 	    last-input-event last-command-event last-nonmenu-event
@@ -763,7 +762,8 @@ A call to this function is inserted by `debug-on-entry' to cause
 functions to break on entry."
   (if (or inhibit-debug-on-entry debugger-jumping-flag)
       nil
-    (funcall debugger 'debug)))
+    (let ((inhibit-debug-on-entry t))
+      (funcall debugger 'debug))))
 
 ;;;###autoload
 (defun debug-on-entry (function)
diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el
index 68bf4f62c34..f0410f87447 100644
--- a/lisp/emacs-lisp/macroexp.el
+++ b/lisp/emacs-lisp/macroexp.el
@@ -465,6 +465,8 @@ itself or not."
 (defvar macroexp--pending-eager-loads nil
   "Stack of files currently undergoing eager macro-expansion.")
 
+(defvar macroexp--debug-eager nil)
+
 (defun internal-macroexpand-for-load (form full-p)
   ;; Called from the eager-macroexpansion in readevalloop.
   (cond
@@ -480,8 +482,10 @@ itself or not."
            (tail (member elem (cdr (member elem bt)))))
       (if tail (setcdr tail (list '…)))
       (if (eq (car-safe (car bt)) 'macroexpand-all) (setq bt (cdr bt)))
-      (message "Warning: Eager macro-expansion skipped due to cycle:\n  %s"
-               (mapconcat #'prin1-to-string (nreverse bt) " => "))
+      (if macroexp--debug-eager
+          (debug 'eager-macroexp-cycle)
+        (message "Warning: Eager macro-expansion skipped due to cycle:\n  %s"
+                 (mapconcat #'prin1-to-string (nreverse bt) " => ")))
       (push 'skip macroexp--pending-eager-loads)
       form))
    (t