Re: RFC: User-defined pseudovectors

[Lars Brinkhoff]

I wrote:
> With the current FFI discussion, this may be a good time to ask for
> input on a Lisp extension I have lying around.

Here is the patch in its current (unfinished) state.  Suggestions are
welcome.  Would something like this be useful for inclusion in Emacs?


diff a/src/alloc.c b/src/alloc.c
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -3048,6 +3048,12 @@ allocate_hash_table (void)
   return ALLOCATE_PSEUDOVECTOR (struct Lisp_Hash_Table, count, 
PVEC_HASH_TABLE);
 }
 
+struct Lisp_Vector *
+allocate_typed_pseudovector (int count)
+{
+  return allocate_pseudovector (count, count, PVEC_TYPED_PSEUDOVECTOR);
+}
+
 struct window *
 allocate_window (void)
 {
@@ -3096,6 +3102,30 @@ allocate_process (void)
   return p;
 }
 
+DEFUN ("make-typed-pseudovector", Fmake_typed_pseudovector, 
Smake_typed_pseudovector, 3, 3, 0,
+       doc: /* Create a new vector-like object of type TYPE with SLOTS 
elements, each initialized to INIT.  */)
+  (register Lisp_Object slots, Lisp_Object type, Lisp_Object init)
+{
+  Lisp_Object vector;
+  register ptrdiff_t size;
+  register ptrdiff_t i;
+  register struct Lisp_Vector *p;
+
+  CHECK_NATNUM (slots);
+  if (!SYMBOLP(type))
+    signal_error ("Invalid type; must be symbol", type);
+
+  size = XFASTINT (slots) + 1;
+  p = allocate_typed_pseudovector (size);
+  p->u.contents[0] = type;
+  for (i = 1; i < size; i++)
+    p->u.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'.  */)
@@ -6755,6 +6785,7 @@ The time is in seconds as a floating point value.  */);
   defsubr (&Smake_byte_code);
   defsubr (&Smake_list);
   defsubr (&Smake_vector);
+  defsubr (&Smake_typed_pseudovector);
   defsubr (&Smake_string);
   defsubr (&Smake_bool_vector);
   defsubr (&Smake_symbol);
diff a/src/data.c b/src/data.c
--- a/src/data.c
+++ b/src/data.c
@@ -290,6 +290,9 @@ for example, (type-of 1) returns `integer'.  */)
        return Qfont_entity;
       if (FONT_OBJECT_P (object))
        return Qfont_object;
+      if (TYPED_PSEUDOVECTOR_P (object))
+       return AREF (object, 0);
+
       return Qvector;
 
     case Lisp_Float:
@@ -370,6 +373,15 @@ DEFUN ("vectorp", Fvectorp, Svectorp, 1, 1, 0,
   return Qnil;
 }
 
+DEFUN ("typed-pseudovector-p", Ftyped_pseudovector_p, Styped_pseudovector_p, 
1, 1, 0,
+       doc: /* Return t if OBJECT is a typed pseudovector.  */)
+  (Lisp_Object object)
+{
+  if (TYPED_PSEUDOVECTOR_P (object))
+    return Qt;
+  return Qnil;
+}
+
 DEFUN ("stringp", Fstringp, Sstringp, 1, 1, 0,
        doc: /* Return t if OBJECT is a string.  */)
   (Lisp_Object object)
@@ -2146,7 +2158,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) || TYPED_PSEUDOVECTOR_P (array))
        size = ASIZE (array) & PSEUDOVECTOR_SIZE_MASK;
       else
        wrong_type_argument (Qarrayp, array);
@@ -2167,7 +2179,8 @@ bool-vector.  IDX starts at 0.  */)
 
   CHECK_NUMBER (idx);
   idxval = XINT (idx);
-  CHECK_ARRAY (array, Qarrayp);
+  if (! TYPED_PSEUDOVECTOR_P (array))
+    CHECK_ARRAY (array, Qarrayp);
   CHECK_IMPURE (array);
 
   if (VECTORP (array))
@@ -2196,7 +2209,14 @@ bool-vector.  IDX starts at 0.  */)
       CHECK_CHARACTER (idx);
       CHAR_TABLE_SET (array, idxval, newelt);
     }
-  else
+  else if (TYPED_PSEUDOVECTOR_P (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;
 
@@ -3506,6 +3526,7 @@ syms_of_data (void)
   defsubr (&Sstringp);
   defsubr (&Smultibyte_string_p);
   defsubr (&Svectorp);
+  defsubr (&Styped_pseudovector_p);
   defsubr (&Schar_table_p);
   defsubr (&Svector_or_char_table_p);
   defsubr (&Sbool_vector_p);
diff a/src/fns.c b/src/fns.c
--- a/src/fns.c
+++ b/src/fns.c
@@ -115,7 +115,7 @@ To get the number of bytes, use `string-bytes'.  */)
     XSETFASTINT (val, MAX_CHAR);
   else if (BOOL_VECTOR_P (sequence))
     XSETFASTINT (val, XBOOL_VECTOR (sequence)->size);
-  else if (COMPILEDP (sequence))
+  else if (COMPILEDP (sequence) || TYPED_PSEUDOVECTOR_P (sequence))
     XSETFASTINT (val, ASIZE (sequence) & PSEUDOVECTOR_SIZE_MASK);
   else if (CONSP (sequence))
     {
diff a/src/lisp.h b/src/lisp.h
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -538,6 +538,7 @@ enum pvec_type
   PVEC_TERMINAL,
   PVEC_WINDOW_CONFIGURATION,
   PVEC_SUBR,
+  PVEC_TYPED_PSEUDOVECTOR,
   PVEC_OTHER,
   /* These should be last, check internal_equal to see why.  */
   PVEC_COMPILED,
@@ -2328,6 +2329,12 @@ FRAMEP (Lisp_Object a)
   return PSEUDOVECTORP (a, PVEC_FRAME);
 }
 
+INLINE bool
+TYPED_PSEUDOVECTOR_P (Lisp_Object a)
+{
+  return PSEUDOVECTORP (a, PVEC_TYPED_PSEUDOVECTOR);
+}
+
 /* Test for image (image . spec)  */
 INLINE bool
 IMAGEP (Lisp_Object x)
diff a/src/lread.c b/src/lread.c
--- a/src/lread.c
+++ b/src/lread.c
@@ -2603,6 +2603,19 @@ read1 (Lisp_Object readcharfun, int *pch, bool 
first_in_list)
          make_byte_code (vec);
          return tmp;
        }
+      if (c == '%')
+       {
+         c = READCHAR;
+         if (c == '[')
+           {
+             Lisp_Object tmp;
+             tmp = read_vector (readcharfun, 1);
+             XSETPVECTYPE (XVECTOR(tmp), PVEC_TYPED_PSEUDOVECTOR);
+             return tmp;
+           }
+         UNREAD (c);
+         invalid_syntax ("#");
+       }
       if (c == '(')
        {
          Lisp_Object tmp;
diff a/src/print.c b/src/print.c
--- a/src/print.c
+++ b/src/print.c
@@ -1945,6 +1945,12 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, 
bool escapeflag)
              PRINTCHAR ('#');
              size &= PSEUDOVECTOR_SIZE_MASK;
            }
+         if (TYPED_PSEUDOVECTOR_P (obj))
+           {
+             PRINTCHAR ('#');
+             PRINTCHAR ('%');
+             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,