new `obarray` type

[Stefan Monnier]

The patch below introduces a new type for obarrays, distinct
from vectors.  Among other things, this makes it possible to print them
in a more useful way (it doesn't print the contents, only the size, so
the printed form is not computer-readable, but it's more
palatable to the user).

Printing obarrays in a `read`able way seems like something that should
be under the control of variable, since it's unclear in general what it
would mean (for abbrev-tables, it would probably mean to print the name
of every symbol, along with it value, function, and plist slots, but
doing that for the `obarray` variable doesn't seem right (and it's not
even clear what the `value` of each symbol in it should be, for
buffer-local symbols)).


        Stefan


diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index 0ccf6a17ff..1739fbcc9f 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -1207,7 +1207,7 @@ cl--generic-typeof-types
     (process atom) (window atom) (subr atom) (compiled-function function atom)
     (buffer atom) (char-table array sequence atom)
     (bool-vector array sequence atom)
-    (frame atom) (hash-table atom) (terminal atom)
+    (frame atom) (hash-table atom) (terminal atom) (obarray atom)
     (thread atom) (mutex atom) (condvar atom)
     (font-spec atom) (font-entity atom) (font-object atom)
     (vector array sequence atom)
diff --git a/lisp/obarray.el b/lisp/obarray.el
index aaffe00a07..db13a17572 100644
--- a/lisp/obarray.el
+++ b/lisp/obarray.el
@@ -32,15 +32,7 @@ obarray-default-size
 
 (defun obarray-make (&optional size)
   "Return a new obarray of size SIZE or `obarray-default-size'."
-  (let ((size (or size obarray-default-size)))
-    (if (< 0 size)
-        (make-vector size 0)
-      (signal 'wrong-type-argument '(size 0)))))
-
-(defun obarrayp (object)
-  "Return t if OBJECT is an obarray."
-  (and (vectorp object)
-       (< 0 (length object))))
+  (make-obarray (or size obarray-default-size)))
 
 ;; Don’t use obarray as a variable name to avoid shadowing.
 (defun obarray-get (ob name)
diff --git a/src/alloc.c b/src/alloc.c
index 03774e60b6..5ace037351 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -3412,6 +3412,23 @@ See also the function `vector'.  */)
   return make_lisp_ptr (p, Lisp_Vectorlike);
 }
 
+DEFUN ("make-obarray", Fmake_obarray, Smake_obarray, 1, 1, 0,
+       doc: /* Return a newly created obarray of size LENGTH.  */)
+  (Lisp_Object length)
+{
+  CHECK_NATNUM (length);
+  EMACS_INT l = XFASTINT (length);
+  if (l >= (1 << PSEUDOVECTOR_SIZE_BITS))
+    error ("Obarray too large");
+  else if (l <= 0)
+    error ("Obarray too small");
+  struct Lisp_Vector *p = allocate_vector (l);
+  for (ptrdiff_t i = 0; i < l; i++)
+    p->contents[i] = make_number (0);
+  XSETPVECTYPE (p, PVEC_OBARRAY);
+  return make_lisp_ptr (p, Lisp_Vectorlike);
+}
+
 DEFUN ("vector", Fvector, Svector, 0, MANY, 0,
        doc: /* Return a newly created vector with specified arguments as 
elements.
 Any number of arguments, even zero arguments, are allowed.
@@ -7593,6 +7610,7 @@ The time is in seconds as a floating point value.  */);
   defsubr (&Smake_byte_code);
   defsubr (&Smake_list);
   defsubr (&Smake_vector);
+  defsubr (&Smake_obarray);
   defsubr (&Smake_string);
   defsubr (&Smake_bool_vector);
   defsubr (&Smake_symbol);
diff --git a/src/data.c b/src/data.c
index df0c3a92a9..183adeb1ea 100644
--- a/src/data.c
+++ b/src/data.c
@@ -250,6 +250,7 @@ for example, (type-of 1) returns `integer'.  */)
         case PVEC_WINDOW: return Qwindow;
         case PVEC_SUBR: return Qsubr;
         case PVEC_COMPILED: return Qcompiled_function;
+        case PVEC_OBARRAY: return Qobarray;
         case PVEC_BUFFER: return Qbuffer;
         case PVEC_CHAR_TABLE: return Qchar_table;
         case PVEC_BOOL_VECTOR: return Qbool_vector;
@@ -360,6 +361,17 @@ DEFUN ("vectorp", Fvectorp, Svectorp, 1, 1, 0,
   return Qnil;
 }
 
+DEFUN ("obarrayp", Fobarrayp, Sobarrayp, 1, 1, 0,
+       doc: /* Return t if OBJECT is an obarray.  */)
+  (Lisp_Object object)
+{
+  if (OBARRAYP (object))
+    return Qt;
+  if (VECTORP (object) && ASIZE (object) > 0) /* Backward compatibility.  */
+    return Qt;
+  return Qnil;
+}
+
 DEFUN ("stringp", Fstringp, Sstringp, 1, 1, 0,
        doc: /* Return t if OBJECT is a string.  */
        attributes: const)
@@ -3580,6 +3592,7 @@ syms_of_data (void)
   DEFSYM (Qsequencep, "sequencep");
   DEFSYM (Qbufferp, "bufferp");
   DEFSYM (Qvectorp, "vectorp");
+  DEFSYM (Qobarrayp, "obarrayp");
   DEFSYM (Qbool_vector_p, "bool-vector-p");
   DEFSYM (Qchar_or_string_p, "char-or-string-p");
   DEFSYM (Qmarkerp, "markerp");
@@ -3699,6 +3712,7 @@ syms_of_data (void)
 
   DEFSYM (Qdefun, "defun");
 
+  DEFSYM (Qobarray, "obarray");
   DEFSYM (Qfont_spec, "font-spec");
   DEFSYM (Qfont_entity, "font-entity");
   DEFSYM (Qfont_object, "font-object");
@@ -3727,6 +3741,7 @@ syms_of_data (void)
   defsubr (&Smultibyte_string_p);
   defsubr (&Sunibyte_string_p);
   defsubr (&Svectorp);
+  defsubr (&Sobarrayp);
   defsubr (&Schar_table_p);
   defsubr (&Svector_or_char_table_p);
   defsubr (&Sbool_vector_p);
diff --git a/src/lisp.h b/src/lisp.h
index 2f97fb8afa..b9a99523d2 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -883,6 +883,7 @@ enum pvec_type
   PVEC_THREAD,
   PVEC_MUTEX,
   PVEC_CONDVAR,
+  PVEC_OBARRAY,
 
   /* These should be last, check internal_equal to see why.  */
   PVEC_COMPILED,
@@ -2814,6 +2815,26 @@ COMPILEDP (Lisp_Object a)
 }
 
 INLINE bool
+OBARRAYP (Lisp_Object a)
+{
+  return PSEUDOVECTORP (a, PVEC_OBARRAY);
+}
+
+INLINE ptrdiff_t
+OBARRAY_SIZE (Lisp_Object obarray)
+{
+  return (OBARRAYP (obarray)
+          ? ASIZE (obarray) & PSEUDOVECTOR_SIZE_MASK
+          : gc_asize (obarray));
+}
+
+INLINE void
+CHECK_OBARRAY (Lisp_Object x)
+{
+  CHECK_TYPE (OBARRAYP (x), Qobarrayp, x);
+}
+
+INLINE bool
 FRAMEP (Lisp_Object a)
 {
   return PSEUDOVECTORP (a, PVEC_FRAME);
diff --git a/src/lread.c b/src/lread.c
index c8632399f7..1c788e5ce5 100644
--- a/src/lread.c
+++ b/src/lread.c
@@ -3772,12 +3767,13 @@ check_obarray (Lisp_Object obarray)
   /* We don't want to signal a wrong-type-argument error when we are
      shutting down due to a fatal error, and we don't want to hit
      assertions in VECTORP and ASIZE if the fatal error was during GC.  */
-  if (!fatal_error_in_progress
-      && (!VECTORP (obarray) || ASIZE (obarray) == 0))
+  if (!(fatal_error_in_progress
+        || OBARRAYP (obarray)
+        || (VECTORP (obarray) && ASIZE (obarray) > 0)))
     {
       /* If Vobarray is now invalid, force it to be valid.  */
       if (EQ (Vobarray, obarray)) Vobarray = initial_obarray;
-      wrong_type_argument (Qvectorp, obarray);
+      wrong_type_argument (Qobarrayp, obarray);
     }
   return obarray;
 }
@@ -3877,6 +3873,9 @@ it defaults to the value of `obarray'.  */)
 
   obarray = check_obarray (NILP (obarray) ? Vobarray : obarray);
   CHECK_STRING (string);
+  if (VECTORP (obarray)
+      && ASIZE (obarray) < (1 << PSEUDOVECTOR_SIZE_BITS))
+    XSETPVECTYPE (XVECTOR (obarray), PVEC_OBARRAY);
 
   tem = oblookup (obarray, SSDATA (string), SCHARS (string), SBYTES (string));
   if (!SYMBOLP (tem))
@@ -4004,7 +4003,7 @@ oblookup (Lisp_Object obarray, register const char *ptr, 
ptrdiff_t size, ptrdiff
 
   obarray = check_obarray (obarray);
   /* This is sometimes needed in the middle of GC.  */
-  obsize = gc_asize (obarray);
+  obsize = OBARRAY_SIZE (obarray);
   hash = hash_string (ptr, size_byte) % obsize;
   bucket = AREF (obarray, hash);
   oblookup_last_bucket_number = hash;
@@ -4031,8 +4030,8 @@ map_obarray (Lisp_Object obarray, void (*fn) 
(Lisp_Object, Lisp_Object), Lisp_Ob
 {
   ptrdiff_t i;
   register Lisp_Object tail;
-  CHECK_VECTOR (obarray);
-  for (i = ASIZE (obarray) - 1; i >= 0; i--)
+  CHECK_OBARRAY (obarray);
+  for (i = OBARRAY_SIZE (obarray) - 1; i >= 0; i--)
     {
       tail = AREF (obarray, i);
       if (SYMBOLP (tail))
@@ -4064,12 +4063,33 @@ OBARRAY defaults to the value of `obarray'.  */)
   return Qnil;
 }
 
-#define OBARRAY_SIZE 15121
+static void
+obarray_count_1 (Lisp_Object sym, Lisp_Object counter)
+{
+  Fsetcar (counter, make_number (1 + XFASTINT (XCAR (counter))));
+}
+
+DEFUN ("obarray-count", Fobarray_count, Sobarray_count, 1, 1, 0,
+       doc: /* Count number of element in OBARRAY.  */)
+  (Lisp_Object obarray)
+{
+  obarray = check_obarray (obarray);
+  Lisp_Object counter = Fcons (make_number (0), Qnil);
+  map_obarray (obarray, obarray_count_1, counter);
+  return XCAR (counter);
+}
+
+/* This was recently bumped to 15121, but now that we use PVEC_OBARRAY
+ * it needs to be smaller than 4096 (aka 1 << PSEUDOVECTOR_SIZE_BITS).
+ * FIXME: We could use a higher value by putting half the size bits
+ * in PSEUDOVECTOR_SIZE and the other alf in PSEUDOVECTOR_REST, or by
+ * moving the PVEC_OBARRAY to PSEUDOVECTOR_FLAG.  */
+#define OBARRAY_SIZE 4093
 
 void
 init_obarray (void)
 {
-  Vobarray = Fmake_vector (make_number (OBARRAY_SIZE), make_number (0));
+  Vobarray = Fmake_obarray (make_number (OBARRAY_SIZE));
   initial_obarray = Vobarray;
   staticpro (&initial_obarray);
 
@@ -4502,6 +4522,7 @@ syms_of_lread (void)
   defsubr (&Sread_event);
   defsubr (&Sget_file_char);
   defsubr (&Smapatoms);
+  defsubr (&Sobarray_count);
   defsubr (&Slocate_file_internal);
 
   DEFVAR_LISP ("obarray", Vobarray,
diff --git a/src/minibuf.c b/src/minibuf.c
index cc8252b068..01ab69cb6d 100644
--- a/src/minibuf.c
+++ b/src/minibuf.c
@@ -1216,7 +1216,7 @@ is used to further constrain the set of candidates.  */)
   ptrdiff_t compare, matchsize;
   enum { function_table, list_table, obarray_table, hash_table}
     type = (HASH_TABLE_P (collection) ? hash_table
-           : VECTORP (collection) ? obarray_table
+           : (OBARRAYP (collection) || VECTORP (collection)) ? obarray_table
            : ((NILP (collection)
                || (CONSP (collection) && !FUNCTIONP (collection)))
               ? list_table : function_table));
@@ -1237,7 +1237,7 @@ is used to further constrain the set of candidates.  */)
   if (type == obarray_table)
     {
       collection = check_obarray (collection);
-      obsize = ASIZE (collection);
+      obsize = OBARRAY_SIZE (collection);
       bucket = AREF (collection, idx);
     }
 
@@ -1473,7 +1473,7 @@ with a space are ignored unless STRING itself starts with 
a space.  */)
   Lisp_Object tail, elt, eltstring;
   Lisp_Object allmatches;
   int type = HASH_TABLE_P (collection) ? 3
-    : VECTORP (collection) ? 2
+    : (OBARRAYP (collection) || VECTORP (collection)) ? 2
     : NILP (collection) || (CONSP (collection) && !FUNCTIONP (collection));
   ptrdiff_t idx = 0, obsize = 0;
   ptrdiff_t bindcount = -1;
@@ -1490,7 +1490,7 @@ with a space are ignored unless STRING itself starts with 
a space.  */)
   if (type == 2)
     {
       collection = check_obarray (collection);
-      obsize = ASIZE (collection);
+      obsize = OBARRAY_SIZE (collection);
       bucket = AREF (collection, idx);
     }
 
@@ -1513,8 +1513,7 @@ with a space are ignored unless STRING itself starts with 
a space.  */)
        {
          if (!EQ (bucket, zero))
            {
-             if (!SYMBOLP (bucket))
-               error ("Bad data in guts of obarray");
+             CHECK_SYMBOL (bucket);
              elt = bucket;
              eltstring = elt;
              if (XSYMBOL (bucket)->next)
@@ -1696,7 +1695,7 @@ the values STRING, PREDICATE and `lambda'.  */)
       if (NILP (tem))
        return Qnil;
     }
-  else if (VECTORP (collection))
+  else if (OBARRAYP (collection) || VECTORP (collection))
     {
       /* Bypass intern-soft as that loses for nil.  */
       tem = oblookup (collection,
diff --git a/src/print.c b/src/print.c
index 5d4076c896..586e094ced 100644
--- a/src/print.c
+++ b/src/print.c
@@ -1855,6 +1855,19 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, 
bool escapeflag)
        }
         break;
 
+      case PVEC_OBARRAY:
+       {
+          print_c_string ("#<obarray", printcharfun);
+         print_c_string (" :size ", printcharfun);
+         print_object (make_number (OBARRAY_SIZE (obj)),
+                       printcharfun, escapeflag);
+         print_c_string (" :count ", printcharfun);
+         print_object (Fobarray_count (obj),
+                       printcharfun, escapeflag);
+         print_c_string (">", printcharfun);
+        }
+        break;
+
       case PVEC_BUFFER:
        {
          if (!BUFFER_LIVE_P (XBUFFER (obj)))