[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:
[Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Emacs-diffs] scratch/record 718fd8d: Make type-of return the type, even for old-style structs,
Stefan Monnier <=