Re: User-defined record types, v2

[Lars Brinkhoff]

Add record objects with user-defined types.

* src/alloc.c (allocate_record): New function.
(Fmake_record, Frecord, Fcopy_record): New functions.
(syms_of_alloc): defsubr them.
(purecopy): Work with records.

* src/data.c (Ftype_of): Return slot 0 for record objects.
(Frecordp): New function.
(syms_of_data): defsubr it.  Define `Qrecordp'.
(Faref, Faset): Work with records.

* src/fns.c (Flength): Work with records.

* src/lisp.h (prec_type): Add PVEC_RECORD.
(RECORDP, CHECK_RECORD, CHECK_RECORD_TYPE): New functions.

* src/lread.c (read1): Add syntax for records.

* src/print.c (print_object): Add syntax for records.

diff --git a/src/alloc.c b/src/alloc.c
index ae3e151..14a179f 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -3392,6 +3392,75 @@ struct buffer *
   return b;
 }
 
+
+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 record;
+  ptrdiff_t size, i;
+  struct Lisp_Vector *p;
+
+  CHECK_RECORD_TYPE (type);
+  CHECK_NATNUM (slots);
+
+  size = XFASTINT (slots) + 1;
+  p = allocate_record (size);
+  p->contents[0] = type;
+  for (i = 1; i < size; i++)
+    p->contents[i] = init;
+
+  XSETVECTOR (record, p);
+  return record;
+}
+
+
+DEFUN ("record", Frecord, Srecord, 1, MANY, 0,
+       doc: /* Return a newly created record of type TYPE the rest of the 
arguments as slots.
+Any number of slots, even zero slots, are allowed.
+usage: (record TYPE &rest SLOTS)  */)
+  (ptrdiff_t nargs, Lisp_Object *args)
+{
+  struct Lisp_Vector *p = allocate_record (nargs);
+  Lisp_Object type = args[0];
+  Lisp_Object record;
+
+  CHECK_RECORD_TYPE (type);
+  p->contents[0] = type;
+  memcpy (p->contents + 1, args + 1, (nargs - 1) * sizeof *args);
+
+  XSETVECTOR (record, p);
+  return record;
+}
+
+
+DEFUN ("copy-record", Fcopy_record, Scopy_record, 1, 1, 0,
+       doc: /* Shallow copy of a record.  */)
+  (Lisp_Object record)
+{
+  CHECK_RECORD (record);
+  struct Lisp_Vector *src = XVECTOR (record);
+  ptrdiff_t size = ASIZE (record) & PSEUDOVECTOR_SIZE_MASK;
+  struct Lisp_Vector *new = allocate_record (size);
+  memcpy (&(new->contents[0]), &(src->contents[0]),
+          size * sizeof (Lisp_Object));
+  XSETVECTOR (record, new);
+  return record;
+}
+
+
 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'.  */)
@@ -5532,7 +5601,7 @@ struct marker_block
       struct Lisp_Hash_Table *h = purecopy_hash_table (table);
       XSET_HASH_TABLE (obj, h);
     }
-  else if (COMPILEDP (obj) || VECTORP (obj))
+  else if (COMPILEDP (obj) || VECTORP (obj) || RECORDP (obj))
     {
       struct Lisp_Vector *objp = XVECTOR (obj);
       ptrdiff_t nbytes = vector_nbytes (objp);
@@ -7461,10 +7530,13 @@ This means that certain objects should be allocated in 
shared (pure) space.
   defsubr (&Scons);
   defsubr (&Slist);
   defsubr (&Svector);
+  defsubr (&Srecord);
+  defsubr (&Scopy_record);
   defsubr (&Sbool_vector);
   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..8e0bccc 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,16 @@ 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);
+      if (idxval == 0)
+       CHECK_RECORD_TYPE (newelt);
+      ASET (array, idxval, newelt);
+    }
+  else /* STRINGP */
     {
       int c;
 
@@ -3604,6 +3624,7 @@ enum bool_vector_op { bool_vector_exclusive_or,
   DEFSYM (Qsequencep, "sequencep");
   DEFSYM (Qbufferp, "bufferp");
   DEFSYM (Qvectorp, "vectorp");
+  DEFSYM (Qrecordp, "recordp");
   DEFSYM (Qbool_vector_p, "bool-vector-p");
   DEFSYM (Qchar_or_string_p, "char-or-string-p");
   DEFSYM (Qmarkerp, "markerp");
@@ -3714,6 +3735,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 +3772,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..d3793ac 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,
@@ -1408,6 +1409,7 @@ struct Lisp_Vector
   CHECK_TYPE (VECTORP (x), Qvectorp, x);
 }
 
+
 /* A pseudovector is like a vector, but has other non-Lisp components.  */
 
 INLINE enum pvec_type
@@ -2728,6 +2730,24 @@ enum char_bits
   return PSEUDOVECTORP (a, PVEC_FRAME);
 }
 
+INLINE bool
+RECORDP (Lisp_Object a)
+{
+  return PSEUDOVECTORP (a, PVEC_RECORD);
+}
+
+INLINE void
+CHECK_RECORD (Lisp_Object x)
+{
+  CHECK_TYPE (RECORDP (x), Qrecordp, x);
+}
+
+INLINE void
+CHECK_RECORD_TYPE (Lisp_Object x)
+{
+  /* CHECK_SYMBOL (x); */
+}
+
 /* 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,