From 2c68192c6b029bb839193c81cf2a16dad26305c6 Mon Sep 17 00:00:00 2001 From: Stefan Monnier 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'. --- 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 | 6 ++++++ test/lisp/emacs-lisp/cl-lib-tests.el | 23 +++++++++++++++++++++++ 6 files changed, 84 insertions(+), 3 deletions(-) diff --git a/doc/lispref/elisp.texi b/doc/lispref/elisp.texi index 0f7efb6f187..3a348aae98e 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 822fd2bf36e..9a5d900cfc9 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 + +@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 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) diff --git a/test/lisp/emacs-lisp/cl-lib-tests.el b/test/lisp/emacs-lisp/cl-lib-tests.el index 6b930a8d17a..564ddab67db 100644 --- a/test/lisp/emacs-lisp/cl-lib-tests.el +++ b/test/lisp/emacs-lisp/cl-lib-tests.el @@ -526,4 +526,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) + (let ((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 -- cgit v1.2.1