emacs-diffs
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Emacs-diffs] scratch/record 718fd8d: Make type-of return the type, even


From: Stefan Monnier
Subject: [Emacs-diffs] scratch/record 718fd8d: Make type-of return the type, even for old-style structs
Date: Fri, 24 Mar 2017 09:21:57 -0400 (EDT)

branch: scratch/record
commit 718fd8d8580d6d69d9f4d251d981989202750475
Author: Stefan Monnier <address@hidden>
Commit: Stefan Monnier <address@hidden>

    Make type-of return the type, even for old-style structs
    
    * lisp/emacs-lisp/cl-lib.el (cl--old-struct-type-of): New function.
    (cl-old-struct-compat-mode): New minor mode.
    
    * lisp/emacs-lisp/eieio-core.el (eieio--generic-generalizer)
    (eieio-object-p): Adapt to new `type-of' behavior.
    
    * src/data.c (Ftype_of): Fix last change.
---
 lisp/emacs-lisp/cl-lib.el     | 26 ++++++++++++++++++++++++++
 lisp/emacs-lisp/eieio-core.el | 12 +++++++-----
 src/data.c                    | 15 ++++++++-------
 3 files changed, 41 insertions(+), 12 deletions(-)

diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el
index 8c4455a..0fa2771 100644
--- a/lisp/emacs-lisp/cl-lib.el
+++ b/lisp/emacs-lisp/cl-lib.el
@@ -639,6 +639,32 @@ If ALIST is non-nil, the new pairs are prepended to it."
   (require 'cl-macs)
   (require 'cl-seq))
 
+(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)))))
+      (funcall orig-fun object)))
+
+(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
+macro-expansion of `cl-defstruct' that used vectors objects instead
+of record objects."
+  :global t
+  (cond
+   (cl-old-struct-compat-mode
+    (advice-add 'type-of :around #'cl--old-struct-type-of))
+   (t
+    (advice-remove 'type-of #'cl--old-struct-type-of))))
+
 ;; Local variables:
 ;; byte-compile-dynamic: t
 ;; End:
diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el
index 882e7fb..2bc8c03 100644
--- a/lisp/emacs-lisp/eieio-core.el
+++ b/lisp/emacs-lisp/eieio-core.el
@@ -109,7 +109,7 @@ Currently under control of this var:
 
 
 (cl-defstruct (eieio--object
-               (:type vector)           ;We manage our own tagging system.
+               (:type vector) ;; FIXME!  ;We manage our own tagging system.
                (:constructor nil)
                (:copier nil))
   ;; `class-tag' holds a symbol, which is not the class name, but is instead
@@ -166,7 +166,8 @@ Return nil if that option doesn't exist."
 
 (defun eieio-object-p (obj)
   "Return non-nil if OBJ is an EIEIO object."
-  (eieio--class-p (type-of obj)))
+  (and (recordp obj)
+       (eieio--class-p (eieio--object-class-tag obj))))
 
 (define-obsolete-function-alias 'object-p 'eieio-object-p "25.1")
 
@@ -1046,9 +1047,10 @@ method invocation orders of the involved classes."
   ;; part of the dispatch code.
   50 #'cl--generic-struct-tag
   (lambda (tag &rest _)
-    (and (eieio--class-p tag)
-         (mapcar #'eieio--class-name
-                 (eieio--class-precedence-list tag)))))
+    (let ((class (cl--find-class tag)))
+      (and (eieio--class-p class)
+           (mapcar #'eieio--class-name
+                   (eieio--class-precedence-list class))))))
 
 (cl-defmethod cl-generic-generalizers :extra "class" (specializer)
   "Support for dispatch on types defined by EIEIO's `defclass'."
diff --git a/src/data.c b/src/data.c
index 39eebdb..0433bb7 100644
--- a/src/data.c
+++ b/src/data.c
@@ -291,13 +291,14 @@ for example, (type-of 1) returns `integer'.  */)
         case PVEC_CONDVAR: return Qcondition_variable;
         case PVEC_TERMINAL: return Qterminal;
         case PVEC_RECORD:
-          Lisp_Object t = AREF (object, 0);
-          if (RECORDP (t) && 1 < ASIZE (t) & PSEUDOVECTOR_SIZE_MASK)
-            /* Return the type name field of the class!  */
-            return AREF (t, 1);
-          else
-            return t;
-
+          {
+            Lisp_Object t = AREF (object, 0);
+            if (RECORDP (t) && 1 < ASIZE (t) & PSEUDOVECTOR_SIZE_MASK)
+              /* Return the type name field of the class!  */
+              return AREF (t, 1);
+            else
+              return t;
+          }
         /* "Impossible" cases.  */
         case PVEC_XWIDGET:
         case PVEC_OTHER:



reply via email to

[Prev in Thread] Current Thread [Next in Thread]