[Emacs-diffs] scratch/record 25aa500 5/5: Backward compatibility with pre-existing struct instances.

[Lars Brinkhoff]

branch: scratch/record
commit 25aa500a4574fa006e7e8e4093b8afc0ccff5b00
Author: Stefan Monnier <address@hidden>
Commit: Lars Brinkhoff <address@hidden>

    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'.
---
 doc/lispref/elisp.texi               |  1 +
 doc/lispref/records.texi             | 17 ++++++++++++++++-
 lisp/emacs-lisp/cl-lib.el            | 36 ++++++++++++++++++++++++++++++++++++
 lisp/emacs-lisp/cl-macs.el           |  4 ++--
 lisp/emacs-lisp/cl-preloaded.el      |  8 ++++++++
 test/lisp/emacs-lisp/cl-lib-tests.el | 23 +++++++++++++++++++++++
 6 files changed, 86 insertions(+), 3 deletions(-)

diff --git a/doc/lispref/elisp.texi b/doc/lispref/elisp.texi
index 0f7efb6..3a348aa 100644
--- a/doc/lispref/elisp.texi
+++ b/doc/lispref/elisp.texi
@@ -423,6 +423,7 @@ Sequences, Arrays, and Vectors
 Records
 
 * Record Functions::        Functions for records.
+* Backward Compatibility::  Compatibility for cl-defstruct.
 
 Hash Tables
 
diff --git a/doc/lispref/records.texi b/doc/lispref/records.texi
index 6af7dab..14b7715 100644
--- a/doc/lispref/records.texi
+++ b/doc/lispref/records.texi
@@ -26,7 +26,8 @@ evaluating it is the same record.  This does not evaluate or 
even
 examine the slots.  @xref{Self-Evaluating Forms}.
 
 @menu
-* Record Functions::      Functions for records.
+* Record Functions::        Functions for records.
+* Backward Compatibility::  Compatibility for cl-defstruct.
 @end menu
 
 @node Record Functions
@@ -98,3 +99,17 @@ the copied record, are also visible in the original record.
 @end group
 @end example
 @end defun
+
address@hidden Backward Compatibility
address@hidden Backward Compatibility
+
+  Code compiled with older versions of @code{cl-defstruct} that
+doesn't use records may run into problems when used in a new Emacs.
+To alleviate this, Emacs detects when an old @code{cl-defstruct} is
+used, and enables a mode in which @code{type-of} handles old struct
+objects as if they were records.
+
address@hidden cl-old-struct-compat-mode arg
+If @var{arg} is positive, enable backward compatibility with old-style
+structs.
address@hidden defun
diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el
index 8c4455a..1f8615f 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 c282938..25c9f99 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 7432dd4..f0a5a69 100644
--- a/lisp/emacs-lisp/cl-preloaded.el
+++ b/lisp/emacs-lisp/cl-preloaded.el
@@ -79,6 +79,8 @@
         (let ((tag (intern (format "cl-struct-%s" name)))
               (type-and-named (get name 'cl-struct-type))
               (descs (get name 'cl-struct-slots)))
+          (if (null (car type-and-named))
+              (setq type-and-named (cons 'record (cdr type-and-named))))
           (cl-struct-define name nil (get name 'cl-struct-include)
                             (unless (and (eq (car type-and-named) 'vector)
                                          (null (cadr type-and-named))
@@ -110,6 +112,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)
diff --git a/test/lisp/emacs-lisp/cl-lib-tests.el 
b/test/lisp/emacs-lisp/cl-lib-tests.el
index 26b19e9..98c4bd9 100644
--- a/test/lisp/emacs-lisp/cl-lib-tests.el
+++ b/test/lisp/emacs-lisp/cl-lib-tests.el
@@ -500,4 +500,27 @@
     (should (eq (type-of x) 'foo))
     (should (eql (foo-x x) 42))))
 
+(ert-deftest old-struct ()
+  (cl-defstruct foo x)
+  (let ((x [cl-struct-foo])
+        (saved cl-old-struct-compat-mode))
+    (cl-old-struct-compat-mode -1)
+    (should (eq (type-of x) 'vector))
+
+    (cl-old-struct-compat-mode 1)
+    (setq cl-struct-foo (cl--struct-get-class 'foo))
+    (setf (symbol-function 'cl-struct-foo) :quick-object-witness-check)
+    (should (eq (type-of x) 'foo))
+    (should (eq (type-of [foo]) 'vector))
+
+    (cl-old-struct-compat-mode (if saved 1 -1))))
+
+(ert-deftest cl-lib-old-struct ()
+  (let ((saved cl-old-struct-compat-mode))
+    (cl-old-struct-compat-mode -1)
+    (cl-struct-define 'foo "" 'cl-structure-object nil nil nil
+                      'cl-struct-foo-tags 'cl-struct-foo t)
+    (should cl-old-struct-compat-mode)
+    (cl-old-struct-compat-mode (if saved 1 -1))))
+
 ;;; cl-lib.el ends here