[Emacs-diffs] scratch/record 8ed4d58 5/6: Backward compatibility with pre-existing struct instances.

[Lars Brinkhoff]

branch: scratch/record
commit 8ed4d5898cf2052d47be161cd2a075444bca4682
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): Likewise.
    (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.
---
 lisp/emacs-lisp/cl-macs.el      |  4 ++--
 lisp/emacs-lisp/cl-preloaded.el |  9 +++++++++
 src/data.c                      | 31 ++++++++++++++++++++++++++++++-
 3 files changed, 41 insertions(+), 3 deletions(-)

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..b3be9c7 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 (SDATA (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");