summaryrefslogtreecommitdiff
path: root/lisp/emacs-lisp
diff options
context:
space:
mode:
Diffstat (limited to 'lisp/emacs-lisp')
-rw-r--r--lisp/emacs-lisp/cl-lib.el36
-rw-r--r--lisp/emacs-lisp/cl-macs.el4
-rw-r--r--lisp/emacs-lisp/cl-preloaded.el6
3 files changed, 44 insertions, 2 deletions
diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el
index 8c4455a3dad..1f8615fad3e 100644
--- a/lisp/emacs-lisp/cl-lib.el
+++ b/lisp/emacs-lisp/cl-lib.el
@@ -639,6 +639,42 @@ 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)))
+ (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
+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/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index c282938a9bf..25c9f999920 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -2847,8 +2847,8 @@ non-nil value, that slot cannot be set via `setf'.
;; struct as a parent.
(eval-and-compile
(cl-struct-define ',name ,docstring ',include-name
- ',type ,(eq named t) ',descs ',tag-symbol ',tag
- ',print-auto))
+ ',(or type 'record) ,(eq named t) ',descs
+ ',tag-symbol ',tag ',print-auto))
',name)))
;;; Add cl-struct support to pcase
diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el
index 7432dd4978d..ab6354de7cd 100644
--- a/lisp/emacs-lisp/cl-preloaded.el
+++ b/lisp/emacs-lisp/cl-preloaded.el
@@ -110,6 +110,12 @@
;;;###autoload
(defun cl-struct-define (name docstring parent type named slots children-sym
tag print)
+ (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))
(cl-assert (or type (not named)))
(if (boundp children-sym)
(add-to-list children-sym tag)