[Emacs-diffs] scratch/record 57509af: Fix test failures with :static eieio methods

[Stefan Monnier]

branch: scratch/record
commit 57509af19bf618dbe00a4e022996dc159666fbcb
Author: Stefan Monnier <address@hidden>
Commit: Stefan Monnier <address@hidden>

    Fix test failures with :static eieio methods
    
    * lisp/emacs-lisp/cl-extra.el (cl--describe-class)
    (cl--describe-class-slots): Use the new `type-of'.
    
    * lisp/emacs-lisp/cl-lib.el (cl--old-struct-type-of): Handle yet another
    compatibility case.
    (cl-old-struct-compat-mode): Mark as autoloaded.
    
    * lisp/emacs-lisp/cl-preloaded.el (cl-struct-define): Auto-enable
    cl-old-struct-compat-mode when we can.
    
    * lisp/emacs-lisp/eieio-compat.el
    (eieio--generic-static-object-generalizer): Adjust to new tags.
---
 lisp/emacs-lisp/cl-extra.el     |  6 ++----
 lisp/emacs-lisp/cl-lib.el       | 28 +++++++++++++++++++---------
 lisp/emacs-lisp/cl-preloaded.el |  7 +++----
 lisp/emacs-lisp/eieio-compat.el |  2 +-
 4 files changed, 25 insertions(+), 18 deletions(-)

diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el
index 021ef23..3852ceb 100644
--- a/lisp/emacs-lisp/cl-extra.el
+++ b/lisp/emacs-lisp/cl-extra.el
@@ -775,8 +775,7 @@ including `cl-block' and `cl-eval-when'."
 (defun cl--describe-class (type &optional class)
   (unless class (setq class (cl--find-class type)))
   (let ((location (find-lisp-object-file-name type 'define-type))
-        ;; FIXME: Add a `cl-class-of' or `cl-typeof' or somesuch.
-        (metatype (cl--class-name (symbol-value (aref class 0)))))
+        (metatype (type-of class)))
     (insert (symbol-name type)
             (substitute-command-keys " is a type (of kind `"))
     (help-insert-xref-button (symbol-name metatype)
@@ -901,8 +900,7 @@ including `cl-block' and `cl-eval-when'."
   "Print help description for the slots in CLASS.
 Outputs to the current buffer."
   (let* ((slots (cl--class-slots class))
-         ;; FIXME: Add a `cl-class-of' or `cl-typeof' or somesuch.
-         (metatype (cl--class-name (symbol-value (aref class 0))))
+         (metatype (type-of class))
          ;; ¡For EIEIO!
          (cslots (condition-case nil
                      (cl-struct-slot-value metatype 'class-slots class)
diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el
index 0fa2771..1f8615f 100644
--- a/lisp/emacs-lisp/cl-lib.el
+++ b/lisp/emacs-lisp/cl-lib.el
@@ -642,17 +642,27 @@ If ALIST is non-nil, the new pairs are prepended to it."
 (defun cl--old-struct-type-of (orig-fun object)
   (or (and (vectorp object)
            (let ((tag (aref object 0)))
-             (and (symbolp tag)
-                  (string-prefix-p "cl-struct-" (symbol-name tag))
-                  (unless (eq (symbol-function tag) 
:quick-object-witness-check)
-                    ;; Old-style old-style struct:
-                    ;; Convert to new-style old-style struct!
-                    (let* ((type (intern (substring (symbol-name tag)
-                                                    (length "cl-struct-")))))
-                      (cl--struct-get-class type)))
-                  (cl--class-name (symbol-value tag)))))
+             (when (and (symbolp tag)
+                        (string-prefix-p "cl-struct-" (symbol-name tag)))
+               (unless (eq (symbol-function tag)
+                           :quick-object-witness-check)
+                 ;; Old-style old-style struct:
+                 ;; Convert to new-style old-style struct!
+                 (let* ((type (intern (substring (symbol-name tag)
+                                                 (length "cl-struct-"))))
+                        (class (cl--struct-get-class type)))
+                   ;; If the `cl-defstruct' was recompiled after the code
+                   ;; which constructed `object', `cl--struct-get-class' may
+                   ;; not have called `cl-struct-define' and setup the tag
+                   ;; symbol for us.
+                   (unless (eq (symbol-function tag)
+                               :quick-object-witness-check)
+                     (set tag class)
+                     (fset tag :quick-object-witness-check))))
+               (cl--class-name (symbol-value tag)))))
       (funcall orig-fun object)))
 
+;;;###autoload
 (define-minor-mode cl-old-struct-compat-mode
   "Enable backward compatibility with old-style structs.
 This can be needed when using code byte-compiled using the old
diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el
index 9742124..f0a5a69 100644
--- a/lisp/emacs-lisp/cl-preloaded.el
+++ b/lisp/emacs-lisp/cl-preloaded.el
@@ -112,10 +112,9 @@
 ;;;###autoload
 (defun cl-struct-define (name docstring parent type named slots children-sym
                               tag print)
-  (if (null type)
-      ;; Legacy defstruct, using tagged vectors.  Enable backward
-      ;; compatibility.
-      (setq old-struct-compat t))
+  (unless type
+    ;; Legacy defstruct, using tagged vectors.  Enable backward compatibility.
+    (cl-old-struct-compat-mode 1))
   (if (eq type 'record)
       ;; Defstruct using record objects.
       (setq type nil))
diff --git a/lisp/emacs-lisp/eieio-compat.el b/lisp/emacs-lisp/eieio-compat.el
index 888d85f..d6eb0b4 100644
--- a/lisp/emacs-lisp/eieio-compat.el
+++ b/lisp/emacs-lisp/eieio-compat.el
@@ -145,7 +145,7 @@ Summary:
   ;; interleaved list comes before the class's non-interleaved list.
   51 #'cl--generic-struct-tag
   (lambda (tag &rest _)
-    (and (symbolp tag) (boundp tag) (setq tag (symbol-value tag))
+    (and (symbolp tag) (setq tag (cl--find-class tag))
          (eieio--class-p tag)
          (let ((superclasses (eieio--class-precedence-list tag))
                (specializers ()))