User-defined record types

[Lars Brinkhoff]

Stefan Monnier wrote:
>> Tom Tromey wrote:
>>> It's kind of hacky though.  I think it's probably better to just add
>>> funcallable instances directly, and real types of some kind at the
>>> same time.
>> I tried to submit a patch for user-defined record types some years
>> ago.  Instances were pseudovectors, with the first element being a
>> symbol naming its type.
> Yes, I think we're pretty much ready to accept such a patch

This is my old patch dusted off and rebased to current master.
It's just a raw material posted for review.

A test case would be:

  (let ((x (make-record 'foo 3 nil)))
    (aset x 1 1)
    (aset x 2 2)
    (aset x 3 3)
    (list (read-from-string (with-output-to-string (prin1 x)))
    (recordp x)
    (type-of x)
    (aref x 0)
    (aref x 3)
    (length x)))

This evalates to ((#%[foo 1 2 3] . 13) t foo foo 3 4).


diff --git a/src/alloc.c b/src/alloc.c
index ae3e151..de08276 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -3392,6 +3392,46 @@ struct buffer *
   return b;
 }
 
+static void
+check_record_type (Lisp_Object type)
+{
+  if (!SYMBOLP(type))
+    error ("Invalid type; must be symbol");
+}
+
+static struct Lisp_Vector *
+allocate_record (int count)
+{
+  if (count >= (1 << PSEUDOVECTOR_SIZE_BITS))
+    error ("Record too large");
+
+  struct Lisp_Vector *p = allocate_vector (count);
+  XSETPVECTYPE (p, PVEC_RECORD);
+  return p;
+}
+
+DEFUN ("make-record", Fmake_record, Smake_record, 3, 3, 0,
+       doc: /* Create a new record of type TYPE with SLOTS elements, each 
initialized to INIT.  */)
+  (Lisp_Object type, Lisp_Object slots, Lisp_Object init)
+{
+  Lisp_Object vector;
+  ptrdiff_t size, i;
+  struct Lisp_Vector *p;
+
+  CHECK_NATNUM (slots);
+  check_record_type (type);
+
+  size = XFASTINT (slots) + 1;
+  p = allocate_record (size);
+  p->contents[0] = type;
+  for (i = 1; i < size; i++)
+    p->contents[i] = init;
+
+  XSETVECTOR (vector, p);
+  return vector;
+}
+
+
 DEFUN ("make-vector", Fmake_vector, Smake_vector, 2, 2, 0,
        doc: /* Return a newly created vector of length LENGTH, with each 
element being INIT.
 See also the function `vector'.  */)
@@ -7465,6 +7505,7 @@ This means that certain objects should be allocated in 
shared (pure) space.
   defsubr (&Smake_byte_code);
   defsubr (&Smake_list);
   defsubr (&Smake_vector);
+  defsubr (&Smake_record);
   defsubr (&Smake_string);
   defsubr (&Smake_bool_vector);
   defsubr (&Smake_symbol);
diff --git a/src/data.c b/src/data.c
index ae8dd97..eceb752 100644
--- a/src/data.c
+++ b/src/data.c
@@ -267,6 +267,7 @@ static void swap_in_symval_forwarding (struct Lisp_Symbol *,
         case PVEC_MUTEX: return Qmutex;
         case PVEC_CONDVAR: return Qcondition_variable;
         case PVEC_TERMINAL: return Qterminal;
+        case PVEC_RECORD: return AREF (object, 0);
         /* "Impossible" cases.  */
         case PVEC_XWIDGET:
         case PVEC_OTHER:
@@ -359,6 +360,15 @@ static void swap_in_symval_forwarding (struct Lisp_Symbol 
*,
   return Qnil;
 }
 
+DEFUN ("recordp", Frecordp_p, Srecordp, 1, 1, 0,
+       doc: /* Return t if OBJECT is a record.  */)
+  (Lisp_Object object)
+{
+  if (RECORDP (object))
+    return Qt;
+  return Qnil;
+}
+
 DEFUN ("stringp", Fstringp, Sstringp, 1, 1, 0,
        doc: /* Return t if OBJECT is a string.  */
        attributes: const)
@@ -2287,7 +2297,7 @@ If the current binding is global (the default), the value 
is nil.  */)
       ptrdiff_t size = 0;
       if (VECTORP (array))
        size = ASIZE (array);
-      else if (COMPILEDP (array))
+      else if (COMPILEDP (array) || RECORDP (array))
        size = ASIZE (array) & PSEUDOVECTOR_SIZE_MASK;
       else
        wrong_type_argument (Qarrayp, array);
@@ -2308,7 +2318,8 @@ If the current binding is global (the default), the value 
is nil.  */)
 
   CHECK_NUMBER (idx);
   idxval = XINT (idx);
-  CHECK_ARRAY (array, Qarrayp);
+  if (! RECORDP (array))
+    CHECK_ARRAY (array, Qarrayp);
 
   if (VECTORP (array))
     {
@@ -2328,7 +2339,14 @@ If the current binding is global (the default), the 
value is nil.  */)
       CHECK_CHARACTER (idx);
       CHAR_TABLE_SET (array, idxval, newelt);
     }
-  else
+  else if (RECORDP (array))
+    {
+      ptrdiff_t size = ASIZE (array) & PSEUDOVECTOR_SIZE_MASK;
+      if (idxval < 0 || idxval >= size)
+       args_out_of_range (array, idx);
+      ASET (array, idxval, newelt);
+    }
+  else /* STRINGP */
     {
       int c;
 
@@ -3714,6 +3732,7 @@ enum bool_vector_op { bool_vector_exclusive_or,
   DEFSYM (Qbuffer, "buffer");
   DEFSYM (Qframe, "frame");
   DEFSYM (Qvector, "vector");
+  DEFSYM (Qrecord, "record");
   DEFSYM (Qchar_table, "char-table");
   DEFSYM (Qbool_vector, "bool-vector");
   DEFSYM (Qhash_table, "hash-table");
@@ -3750,6 +3769,7 @@ enum bool_vector_op { bool_vector_exclusive_or,
   defsubr (&Sstringp);
   defsubr (&Smultibyte_string_p);
   defsubr (&Svectorp);
+  defsubr (&Srecordp);
   defsubr (&Schar_table_p);
   defsubr (&Svector_or_char_table_p);
   defsubr (&Sbool_vector_p);
diff --git a/src/fns.c b/src/fns.c
index 1065355..36bde20 100644
--- a/src/fns.c
+++ b/src/fns.c
@@ -104,7 +104,7 @@ static void sort_vector_copy (Lisp_Object, ptrdiff_t,
     XSETFASTINT (val, MAX_CHAR);
   else if (BOOL_VECTOR_P (sequence))
     XSETFASTINT (val, bool_vector_size (sequence));
-  else if (COMPILEDP (sequence))
+  else if (COMPILEDP (sequence) || RECORDP (sequence))
     XSETFASTINT (val, ASIZE (sequence) & PSEUDOVECTOR_SIZE_MASK);
   else if (CONSP (sequence))
     {
diff --git a/src/lisp.h b/src/lisp.h
index ab4db4c..fb5fed1 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -874,6 +874,7 @@ enum pvec_type
   PVEC_TERMINAL,
   PVEC_WINDOW_CONFIGURATION,
   PVEC_SUBR,
+  PVEC_RECORD,
   PVEC_OTHER,            /* Should never be visible to Elisp code.  */
   PVEC_XWIDGET,
   PVEC_XWIDGET_VIEW,
@@ -2728,6 +2729,12 @@ enum char_bits
   return PSEUDOVECTORP (a, PVEC_FRAME);
 }
 
+INLINE bool
+RECORDP (Lisp_Object a)
+{
+  return PSEUDOVECTORP (a, PVEC_RECORD);
+}
+
 /* Test for image (image . spec)  */
 INLINE bool
 IMAGEP (Lisp_Object x)
diff --git a/src/lread.c b/src/lread.c
index 5c6a7f9..1fcbc37 100644
--- a/src/lread.c
+++ b/src/lread.c
@@ -2762,6 +2762,19 @@ BUFFER is the buffer to evaluate (nil means use current 
buffer),
          make_byte_code (vec);
          return tmp;
        }
+      if (c == '%')
+       {
+         c = READCHAR;
+         if (c == '[')
+           {
+             Lisp_Object tmp;
+             tmp = read_vector (readcharfun, 1);
+             XSETPVECTYPE (XVECTOR(tmp), PVEC_RECORD);
+             return tmp;
+           }
+         UNREAD (c);
+         invalid_syntax ("#");
+       }
       if (c == '(')
        {
          Lisp_Object tmp;
diff --git a/src/print.c b/src/print.c
index e857761..f7ecd3c 100644
--- a/src/print.c
+++ b/src/print.c
@@ -1966,6 +1966,7 @@
       case PVEC_SUB_CHAR_TABLE:
       case PVEC_COMPILED:
       case PVEC_CHAR_TABLE:
+      case PVEC_RECORD:
       case PVEC_NORMAL_VECTOR: ;
        {
          ptrdiff_t size = ASIZE (obj);
@@ -1974,6 +1975,12 @@
              printchar ('#', printcharfun);
              size &= PSEUDOVECTOR_SIZE_MASK;
            }
+         if (RECORDP (obj))
+           {
+             printchar ('#', printcharfun);
+             printchar ('%', printcharfun);
+             size &= PSEUDOVECTOR_SIZE_MASK;
+           }
          if (CHAR_TABLE_P (obj) || SUB_CHAR_TABLE_P (obj))
            {
              /* We print a char-table as if it were a vector,