[Emacs-diffs] scratch/record 3cda36e 05/10: Backward compatibility with pre-existing struct instances.

[Lars Brinkhoff]

branch: scratch/record
commit 3cda36e2546b8ecad16c05950e203f4fe5e90620
Author: Lars Brinkhoff <address@hidden>
Commit: Lars Brinkhoff <address@hidden>

    Backward compatibility with pre-existing struct instances.
    
    If old-struct-compat is set to `t', `type-of' will make an educated
    guess whether a vector is a legacy struct instance.  If so, the
    returned type will be the contents of slot 0.
    
    * lisp/emacs-lisp/cl-macs.el (cl-defstruct): Pass `blue-sky' 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.
    
    * src/data.c (old_struct_prefix): New variable.
    (vector_struct_p, type_of_vector): New functions.
    (Ftype_of): Call type_of_vector.
    (Vold_struct_compat): New variable.
    
    * test/lisp/emacs-lisp/cl-lib-tests.el (cl-lib-old-struct): New test.
    
    * test/src/data-tests.el (old-struct): New test.
    
    * doc/lispref/elisp.texi, doc/lispref/records.texi: Document
    `old-struct-compat'.
---
 doc/lispref/elisp.texi               |  1 +
 doc/lispref/records.texi             | 18 +++++++++++++++++-
 lisp/emacs-lisp/cl-macs.el           |  4 ++--
 lisp/emacs-lisp/cl-preloaded.el      |  9 +++++++++
 src/data.c                           | 31 ++++++++++++++++++++++++++++++-
 test/lisp/emacs-lisp/cl-lib-tests.el |  6 ++++++
 test/src/data-tests.el               |  8 ++++++++
 7 files changed, 73 insertions(+), 4 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 185c41c..3c4e015 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,18 @@ 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
+objets as if they were records.
+
address@hidden old-struct-compat
+If old-struct-compat is set to @code{t}, @code{type-of} will make an
+educated guess whether a vector is a legacy struct instance.  If so,
+the returned type will be the contents of the first element.
address@hidden defvar
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index c282938..a5a0769 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 'blue-sky) ,(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..a2ce1c3 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 'blue-sky (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,13 @@
 ;;;###autoload
 (defun cl-struct-define (name docstring parent type named slots children-sym
                               tag print)
+  (if (null type)
+      ;; Legacy defstruct, using tagged vectors.  Enable backward
+      ;; compatibility.
+      (setq old-struct-compat t))
+  (if (eq type 'blue-sky)
+      ;; 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/src/data.c b/src/data.c
index 8e0bccc..df73066 100644
--- a/src/data.c
+++ b/src/data.c
@@ -201,6 +201,29 @@ DEFUN ("null", Fnull, Snull, 1, 1, 0,
   return Qnil;
 }
 
+static const char old_struct_prefix[] = "cl-struct-";
+
+static int
+vector_struct_p (Lisp_Object object)
+{
+  if (! old_struct_compat || ASIZE (object) < 1)
+    return false;
+
+  Lisp_Object type = AREF (object, 0);
+  return SYMBOLP (type)
+    && strncmp (SSDATA (SYMBOL_NAME (type)),
+               old_struct_prefix,
+               sizeof old_struct_prefix - 1) == 0;
+}
+
+static Lisp_Object
+type_of_vector (Lisp_Object object)
+{
+  if (vector_struct_p (object))
+    return AREF (object, 0);
+  return Qvector;
+}
+
 DEFUN ("type-of", Ftype_of, Stype_of, 1, 1, 0,
        doc: /* Return a symbol representing the type of OBJECT.
 The symbol returned names the object's basic type;
@@ -243,7 +266,7 @@ for example, (type-of 1) returns `integer'.  */)
     case Lisp_Vectorlike:
       switch (PSEUDOVECTOR_TYPE (XVECTOR (object)))
         {
-        case PVEC_NORMAL_VECTOR: return Qvector;
+        case PVEC_NORMAL_VECTOR: return type_of_vector (object);
         case PVEC_WINDOW_CONFIGURATION: return Qwindow_configuration;
         case PVEC_PROCESS: return Qprocess;
         case PVEC_WINDOW: return Qwindow;
@@ -3873,6 +3896,12 @@ syms_of_data (void)
   Vmost_negative_fixnum = make_number (MOST_NEGATIVE_FIXNUM);
   make_symbol_constant (intern_c_string ("most-negative-fixnum"));
 
+  DEFVAR_BOOL ("old-struct-compat", old_struct_compat,
+              doc: /* Non-nil means try to be compatible with old structs.
+If a vector has a symbol in its first slot, and that symbol has a prefix
+`cl-struct-', `type-of' will return that symbol as the type of the vector.  
*/);
+  old_struct_compat = false;
+
   DEFSYM (Qwatchers, "watchers");
   DEFSYM (Qmakunbound, "makunbound");
   DEFSYM (Qunlet, "unlet");
diff --git a/test/lisp/emacs-lisp/cl-lib-tests.el 
b/test/lisp/emacs-lisp/cl-lib-tests.el
index 26b19e9..b66e7ac 100644
--- a/test/lisp/emacs-lisp/cl-lib-tests.el
+++ b/test/lisp/emacs-lisp/cl-lib-tests.el
@@ -500,4 +500,10 @@
     (should (eq (type-of x) 'foo))
     (should (eql (foo-x x) 42))))
 
+(ert-deftest cl-lib-old-struct ()
+  (let ((old-struct-compat nil))
+    (cl-struct-define 'foo "" 'cl-structure-object nil nil nil
+                      'cl-struct-foo-tags 'cl-struct-foo t)
+    (should old-struct-compat)))
+
 ;;; cl-lib.el ends here
diff --git a/test/src/data-tests.el b/test/src/data-tests.el
index 67d00a7..f4729dd 100644
--- a/test/src/data-tests.el
+++ b/test/src/data-tests.el
@@ -480,3 +480,11 @@ comparing the subr with a much slower lisp implementation."
       (remove-variable-watcher 'data-tests-lvar collect-watch-data)
       (setq data-tests-lvar 6)
       (should (null watch-data)))))
+
+(ert-deftest old-struct ()
+  (let ((x [cl-struct-foo]))
+    (let ((old-struct-compat nil))
+      (should (eq (type-of x) 'vector)))
+    (let ((old-struct-compat t))
+      (should (eq (type-of x) 'cl-struct-foo))
+      (should (eq (type-of [foo]) 'vector)))))