Re: User-defined record types, v2

[Lars Brinkhoff <lars@nocrew.org>]

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, type_of_vector): New functions.
(Ftype_of): Call type_of_vector.
(old-struct-compat): New variable.

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 @@ static void swap_in_symval_forwarding (struct Lisp_Symbol *,
   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 @@ static void swap_in_symval_forwarding (struct Lisp_Symbol *,
     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 @@ enum bool_vector_op { bool_vector_exclusive_or,
   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");