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

[Lars Brinkhoff]

branch: scratch/record
commit 6b643069b56015509e7af23e1bc75839988e2781
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.
    
    * src/data.c (old_struct_prefix, old_struct_prefix_length): New variables.
    (vector_struct_p): New function.
    (type_of_vector): New function.
    (Ftype_of): Call type_of_vector.
    (old-struct-compat): New variable.
    
    * src/lisp.h (RECORD_TYPE_P): New function.
---
 old-struct.el |  2 ++
 src/data.c    | 31 ++++++++++++++++++++++++++++++-
 2 files changed, 32 insertions(+), 1 deletion(-)

diff --git a/old-struct.el b/old-struct.el
index 830d211..6f538ec 100644
--- a/old-struct.el
+++ b/old-struct.el
@@ -11,3 +11,5 @@
 ;;(cl-typep (foo) 'cl-structure-object)
 ;;(cl-struct-p (foo))
 ;;(memq (aref (foo) 0) cl-struct-cl-structure-object-tags)
+;;(setq old-struct-compat t)
+;;(type-of [foo])
diff --git a/src/data.c b/src/data.c
index 8e0bccc..5a91d92 100644
--- a/src/data.c
+++ b/src/data.c
@@ -201,6 +201,30 @@ DEFUN ("null", Fnull, Snull, 1, 1, 0,
   return Qnil;
 }
 
+static const char *old_struct_prefix = "cl-struct-";
+static int old_struct_prefix_length;
+
+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,
+               old_struct_prefix_length) == 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 +267,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 +3897,11 @@ 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 hack for old structs is in effect.  */);
+  old_struct_compat = 0;
+  old_struct_prefix_length = strlen (old_struct_prefix);
+
   DEFSYM (Qwatchers, "watchers");
   DEFSYM (Qmakunbound, "makunbound");
   DEFSYM (Qunlet, "unlet");