From 390612eb7ab8ccf0792fda7c48b7056c5cda9b06 Mon Sep 17 00:00:00 2001
From: Stefan Monnier <monnier@iro.umontreal.ca>
Date: Fri, 24 Mar 2017 09:21:52 -0400
Subject: Backward compatibility with pre-existing struct instances.

* lisp/emacs-lisp/cl-lib.el (cl--old-struct-type-of): New function.
(cl-old-struct-compat-mode): New minor mode.

* lisp/emacs-lisp/cl-macs.el (cl-defstruct): Pass `record' to
cl-struct-define to signal use of record objects.

* lisp/emacs-lisp/cl-preloaded.el (cl--struct-get-class,
cl-struct-define): Enable legacy defstruct compatibility.

* test/lisp/emacs-lisp/cl-lib-tests.el (cl-lib-old-struct,
old-struct): New tests.

* doc/lispref/elisp.texi, doc/lispref/records.texi: Document
`old-struct-compat'.
---
 lisp/emacs-lisp/cl-lib.el       | 36 ++++++++++++++++++++++++++++++++++++
 lisp/emacs-lisp/cl-macs.el      |  4 ++--
 lisp/emacs-lisp/cl-preloaded.el |  6 ++++++
 3 files changed, 44 insertions(+), 2 deletions(-)

(limited to 'lisp')

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)
-- 
cgit v1.2.1