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, or type
name if record's type holds class.
(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_CIRCLE_CANDIDATE_P): Add RECORDP.
(print_object): Add syntax for records.

* test/lisp/emacs-lisp/cl-print-tests.el (cl-print-tests-2):
New test.

* test/src/alloc-tests.el (record-1, record-2, record-3):
New tests.

* doc/lispref/elisp.texi, doc/lispref/objects.texi,
doc/lispref/records.texi: Add documentation for records.

6 files changed, 177 insertions, 8 deletions

diff --git a/src/alloc.c b/src/alloc.c
index ae3e1519c04..fe631f2e4d8 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -3392,6 +3392,94 @@ allocate_buffer (void)
   return b;
 }
 
+
+/* Allocate a new record with COUNT slots.  Return NULL if COUNT is
+   too large.  */
+
+static struct Lisp_Vector *
+allocate_record (int count)
+{
+  if (count >= (1 << PSEUDOVECTOR_SIZE_BITS))
+    return NULL;
+
+  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.
+TYPE is its type as returned by `type-of'.  SLOTS is the number of
+slots, each initialized to INIT.  The number of slots, including the
+type slot, must fit in PSEUDOVECTOR_SIZE_BITS.  */)
+  (Lisp_Object type, Lisp_Object slots, Lisp_Object init)
+{
+  Lisp_Object record;
+  ptrdiff_t size, i;
+  struct Lisp_Vector *p;
+
+  CHECK_NATNUM (slots);
+
+  size = XFASTINT (slots) + 1;
+  p = allocate_record (size);
+  if (p == NULL)
+    error ("Attempt to allocate a record of %ld slots; max is %d",
+           size, (1 << PSEUDOVECTOR_SIZE_BITS) - 1);
+
+  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: /* Create a new record.
+TYPE is its type as returned by `type-of'.  SLOTS is used to
+initialize the record slots with shallow copies of the arguments.  The
+number of slots, including the type slot, must fit in
+PSEUDOVECTOR_SIZE_BITS.
+usage: (record TYPE &rest SLOTS) */)
+  (ptrdiff_t nargs, Lisp_Object *args)
+{
+  struct Lisp_Vector *p = allocate_record (nargs);
+  if (p == NULL)
+    error ("Attempt to allocate a record of %ld slots; max is %d",
+           nargs, (1 << PSEUDOVECTOR_SIZE_BITS) - 1);
+
+  Lisp_Object type = args[0];
+  Lisp_Object record;
+
+  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: /* Return a new record that is a shallow copy of the argument 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);
+  if (new == NULL)
+    error ("Attempt to allocate a record of %ld slots; max is %d",
+           size, (1 << PSEUDOVECTOR_SIZE_BITS) - 1);
+
+  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 +5620,7 @@ purecopy (Lisp_Object obj)
       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 +7549,13 @@ The time is in seconds as a floating point value.  */);
   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 ae8dd9721c2..5fdbec2000e 100644
--- a/src/data.c
+++ b/src/data.c
@@ -267,6 +267,15 @@ for example, (type-of 1) returns `integer'.  */)
         case PVEC_MUTEX: return Qmutex;
         case PVEC_CONDVAR: return Qcondition_variable;
         case PVEC_TERMINAL: return Qterminal;
+        case PVEC_RECORD:
+          {
+            Lisp_Object t = AREF (object, 0);
+            if (RECORDP (t) && 1 < (ASIZE (t) & PSEUDOVECTOR_SIZE_MASK))
+              /* Return the type name field of the class!  */
+              return AREF (t, 1);
+            else
+              return t;
+          }
         /* "Impossible" cases.  */
         case PVEC_XWIDGET:
         case PVEC_OTHER:
@@ -359,6 +368,15 @@ DEFUN ("vectorp", Fvectorp, Svectorp, 1, 1, 0,
   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 +2305,7 @@ or a byte-code object.  IDX starts at 0.  */)
       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 +2326,8 @@ bool-vector.  IDX starts at 0.  */)
 
   CHECK_NUMBER (idx);
   idxval = XINT (idx);
-  CHECK_ARRAY (array, Qarrayp);
+  if (! RECORDP (array))
+    CHECK_ARRAY (array, Qarrayp);
 
   if (VECTORP (array))
     {
@@ -2328,7 +2347,14 @@ bool-vector.  IDX starts at 0.  */)
       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;
 
@@ -3604,6 +3630,7 @@ syms_of_data (void)
   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 +3741,7 @@ syms_of_data (void)
   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 +3778,7 @@ syms_of_data (void)
   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 de7fc1b47fc..47da5f8b4bc 100644
--- a/src/fns.c
+++ b/src/fns.c
@@ -106,7 +106,7 @@ To get the number of bytes, use `string-bytes'.  */)
     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 3125bd2a5dd..5e7d41bc5d5 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -889,6 +889,7 @@ enum pvec_type
   PVEC_COMPILED,
   PVEC_CHAR_TABLE,
   PVEC_SUB_CHAR_TABLE,
+  PVEC_RECORD,
   PVEC_FONT /* Should be last because it's used for range checking.  */
 };
 
@@ -1412,6 +1413,7 @@ CHECK_VECTOR (Lisp_Object x)
   CHECK_TYPE (VECTORP (x), Qvectorp, x);
 }
 
+
 /* A pseudovector is like a vector, but has other non-Lisp components.  */
 
 INLINE enum pvec_type
@@ -2732,6 +2734,18 @@ FRAMEP (Lisp_Object a)
   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);
+}
+
 /* Test for image (image . spec)  */
 INLINE bool
 IMAGEP (Lisp_Object x)
diff --git a/src/lread.c b/src/lread.c
index 5c6a7f97f52..6de9fe6e08e 100644
--- a/src/lread.c
+++ b/src/lread.c
@@ -2603,8 +2603,18 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
               int param_count = 0;
 
               if (!EQ (head, Qhash_table))
-                error ("Invalid extended read marker at head of #s list "
-                       "(only hash-table allowed)");
+                {
+                  ptrdiff_t size = XINT (Flength (tmp));
+                  Lisp_Object record = Fmake_record (CAR_SAFE (tmp),
+                                                     make_number (size - 1),
+                                                     Qnil);
+                  for (int i = 1; i < size; i++)
+                    {
+                      tmp = Fcdr (tmp);
+                      ASET (record, i, Fcar (tmp));
+                    }
+                  return record;
+                }
 
               tmp = CDR_SAFE (tmp);
 
diff --git a/src/print.c b/src/print.c
index e857761bd46..76f263994e6 100644
--- a/src/print.c
+++ b/src/print.c
@@ -1135,7 +1135,8 @@ print (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
    || (VECTORLIKEP (obj)                                   \
        && (VECTORP (obj) || COMPILEDP (obj)                \
            || CHAR_TABLE_P (obj) || SUB_CHAR_TABLE_P (obj) \
-           || HASH_TABLE_P (obj) || FONTP (obj)))          \
+           || HASH_TABLE_P (obj) || FONTP (obj)            \
+           || RECORDP (obj)))                              \
    || (! NILP (Vprint_gensym)                              \
        && SYMBOLP (obj)                                    \
        && !SYMBOL_INTERNED_P (obj)))
@@ -1963,6 +1964,30 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
         }
         break;
 
+      case PVEC_RECORD:
+        {
+          ptrdiff_t n, size = ASIZE (obj) & PSEUDOVECTOR_SIZE_MASK;
+          int i;
+
+          /* Don't print more elements than the specified maximum.  */
+          if (NATNUMP (Vprint_length)
+              && XFASTINT (Vprint_length) < size)
+            n = XFASTINT (Vprint_length);
+          else
+            n = size;
+
+          print_c_string ("#s(", printcharfun);
+          for (i = 0; i < n; i ++)
+            {
+              if (i) printchar (' ', printcharfun);
+              print_object (AREF (obj, i), printcharfun, escapeflag);
+            }
+          if (n < size)
+            print_c_string (" ...", printcharfun);
+          printchar (')', printcharfun);
+        }
+        break;
+
       case PVEC_SUB_CHAR_TABLE:
       case PVEC_COMPILED:
       case PVEC_CHAR_TABLE: