Commit 390612eb authored by Stefan Monnier's avatar Stefan Monnier Committed by Lars Brinkhoff

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'.
parent 43cb754a
......@@ -423,6 +423,7 @@ Sequences, Arrays, and Vectors
Records
* Record Functions:: Functions for records.
* Backward Compatibility:: Compatibility for cl-defstruct.
Hash Tables
......
......@@ -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
@node Backward Compatibility
@section 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.
@defun cl-old-struct-compat-mode arg
If @var{arg} is positive, enable backward compatibility with old-style
structs.
@end defun
......@@ -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:
......
......@@ -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
......
......@@ -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)
......
......@@ -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
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment