use guile obarrays

* src/alloc.c (initialize_symbol): New function, extracted from
  `Fmake_symbol'.
  (Fmake_symbol): Use `scm_make_symbol'.
* src/emacs.c (main2): Define a symbol module.
* src/lisp.h (SYMBOLP, XSYMBOL): Update.
  (set_symbol_next): Remove. All callers changed.
* src/lread.c (obhash): New function.
  (Fintern, Fintern_soft, Funintern, oblookup, map_obarray): Use Guile
  obarrays.
  (init_obarray): Initialize a hash table of obarrays.
* src/lread.c (Ffind_symbol): New function.

4 files changed, 110 insertions, 162 deletions

diff --git a/src/alloc.c b/src/alloc.c
index 2a89bb85bb..5b9aba626f 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -1171,30 +1171,36 @@ set_symbol_name (Lisp_Object sym, Lisp_Object name)
   XSYMBOL (sym)->name = name;
 }
 
-DEFUN ("make-symbol", Fmake_symbol, Smake_symbol, 1, 1, 0,
-       doc: /* Return a newly allocated uninterned symbol whose name is NAME.
-Its value is void, and its function definition and property list are nil.  */)
-  (Lisp_Object name)
+void
+initialize_symbol (Lisp_Object val, Lisp_Object name)
 {
-  register Lisp_Object val;
-  register struct Lisp_Symbol *p;
-
-  CHECK_STRING (name);
+  struct Lisp_Symbol *p = xmalloc (sizeof *p);
 
-  p = xmalloc (sizeof *p);
-  SCM_NEWSMOB (p->self, lisp_symbol_tag, p);
-  XSETSYMBOL (val, p);
+  scm_module_define (symbol_module, val, scm_from_pointer (p, NULL));
   p = XSYMBOL (val);
+  p->self = val;
   set_symbol_name (val, name);
   set_symbol_plist (val, Qnil);
   p->redirect = SYMBOL_PLAINVAL;
   SET_SYMBOL_VAL (p, Qunbound);
   set_symbol_function (val, Qnil);
-  set_symbol_next (val, NULL);
   p->interned = SYMBOL_UNINTERNED;
   p->constant = 0;
   p->declared_special = false;
-  p->pinned = false;
+}
+
+DEFUN ("make-symbol", Fmake_symbol, Smake_symbol, 1, 1, 0,
+       doc: /* Return a newly allocated uninterned symbol whose name is NAME.
+Its value is void, and its function definition and property list are nil.  */)
+  (Lisp_Object name)
+{
+  register Lisp_Object val;
+
+  CHECK_STRING (name);
+
+  val = scm_make_symbol (scm_from_utf8_stringn (SSDATA (name),
+                                                SBYTES (name)));
+  initialize_symbol (val, name);
   return val;
 }
 
@@ -1639,7 +1645,6 @@ die (const char *msg, const char *file, int line)
 void
 init_alloc_once (void)
 {
-  lisp_symbol_tag = scm_make_smob_type ("elisp-symbol", 0);
   lisp_misc_tag = scm_make_smob_type ("elisp-misc", 0);
   lisp_string_tag = scm_make_smob_type ("elisp-string", 0);
   lisp_vectorlike_tag = scm_make_smob_type ("elisp-vectorlike", 0);
diff --git a/src/emacs.c b/src/emacs.c
index b7df7a6f57..922f9a138b 100644
--- a/src/emacs.c
+++ b/src/emacs.c
@@ -107,6 +107,8 @@ extern void moncontrol (int mode);
 #include <sys/personality.h>
 #endif
 
+Lisp_Object symbol_module;
+
 static const char emacs_version[] = PACKAGE_VERSION;
 static const char emacs_copyright[] = COPYRIGHT;
 static const char emacs_bugreport[] = PACKAGE_BUGREPORT;
@@ -1164,6 +1166,11 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem
 
   if (!initialized)
     {
+      symbol_module = scm_call (scm_c_public_ref ("guile", "define-module*"),
+                                scm_list_1 (scm_from_utf8_symbol ("elisp-symbols")),
+                                scm_from_locale_keyword ("pure"),
+                                SCM_BOOL_T,
+                                SCM_UNDEFINED);
       init_alloc_once ();
       init_guile ();
       init_fns_once ();
diff --git a/src/lisp.h b/src/lisp.h
index 14d378f04a..2a93f71ce4 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -303,45 +303,11 @@ DEFINE_GDB_SYMBOL_END (USE_LSB_TAG)
 #define lisp_h_SYMBOL_CONSTANT_P(sym) (XSYMBOL (sym)->constant)
 #define lisp_h_SYMBOL_VAL(sym) \
    (eassert ((sym)->redirect == SYMBOL_PLAINVAL), (sym)->val.value)
-#define lisp_h_SYMBOLP(x) (SMOB_TYPEP (x, lisp_symbol_tag))
+#define lisp_h_SYMBOLP(x) (x && scm_is_symbol (x))
 #define lisp_h_VECTORLIKEP(x) (SMOB_TYPEP (x, lisp_vectorlike_tag))
 #define lisp_h_XCAR(c) (scm_car (c))
 #define lisp_h_XCDR(c) (scm_cdr (c))
 #define lisp_h_XHASH(a) (SCM_UNPACK (a))
-#define lisp_h_XSYMBOL(a) \
-   (eassert (SYMBOLP (a)), (struct Lisp_Symbol *) SMOB_PTR (a))
-
-/* When compiling via gcc -O0, define the key operations as macros, as
-   Emacs is too slow otherwise.  To disable this optimization, compile
-   with -DINLINING=false.  */
-#if 0
-#if (defined __NO_INLINE__ \
-     && ! defined __OPTIMIZE__ && ! defined __OPTIMIZE_SIZE__ \
-     && ! (defined INLINING && ! INLINING))
-# define XLI(o) lisp_h_XLI (o)
-# define XIL(i) lisp_h_XIL (i)
-# define CHECK_LIST_CONS(x, y) lisp_h_CHECK_LIST_CONS (x, y)
-# define CHECK_NUMBER(x) lisp_h_CHECK_NUMBER (x)
-# define CHECK_SYMBOL(x) lisp_h_CHECK_SYMBOL (x)
-# define CHECK_TYPE(ok, predicate, x) lisp_h_CHECK_TYPE (ok, predicate, x)
-# define CONSP(x) lisp_h_CONSP (x)
-# define EQ(x, y) lisp_h_EQ (x, y)
-# define FLOATP(x) lisp_h_FLOATP (x)
-# define INTEGERP(x) lisp_h_INTEGERP (x)
-# define MARKERP(x) lisp_h_MARKERP (x)
-# define MISCP(x) lisp_h_MISCP (x)
-# define NILP(x) lisp_h_NILP (x)
-# define SET_SYMBOL_VAL(sym, v) lisp_h_SET_SYMBOL_VAL (sym, v)
-# define SYMBOL_CONSTANT_P(sym) lisp_h_SYMBOL_CONSTANT_P (sym)
-# define SYMBOL_VAL(sym) lisp_h_SYMBOL_VAL (sym)
-# define SYMBOLP(x) lisp_h_SYMBOLP (x)
-# define VECTORLIKEP(x) lisp_h_VECTORLIKEP (x)
-# define XCAR(c) lisp_h_XCAR (c)
-# define XCDR(c) lisp_h_XCDR (c)
-# define XHASH(a) lisp_h_XHASH (a)
-# define XSYMBOL(a) lisp_h_XSYMBOL (a)
-#endif
-#endif
 
 /* Define NAME as a lisp.h inline function that returns TYPE and has
    arguments declared as ARGDECLS and passed as ARGS.  ARGDECLS and
@@ -374,7 +340,6 @@ DEFINE_GDB_SYMBOL_END (USE_LSB_TAG)
 #define ENUM_BF(TYPE) enum TYPE
 #endif
 
-scm_t_bits lisp_symbol_tag;
 scm_t_bits lisp_misc_tag;
 scm_t_bits lisp_string_tag;
 scm_t_bits lisp_vectorlike_tag;
@@ -679,7 +644,18 @@ XSTRING (Lisp_Object a)
   return SMOB_PTR (a);
 }
 
-LISP_MACRO_DEFUN (XSYMBOL, struct Lisp_Symbol *, (Lisp_Object a), (a))
+extern void initialize_symbol (Lisp_Object, Lisp_Object);
+INLINE Lisp_Object build_string (const char *);
+extern Lisp_Object symbol_module;
+
+INLINE struct Lisp_Symbol *
+XSYMBOL (Lisp_Object a)
+{
+  Lisp_Object tem;
+  eassert (SYMBOLP (a));
+  tem = scm_variable_ref (scm_module_lookup (symbol_module, a));
+  return scm_to_pointer (tem);
+}
 
 /* Pseudovector types.  */
 
@@ -1367,9 +1343,6 @@ struct Lisp_Symbol
 
   /* The symbol's property list.  */
   Lisp_Object plist;
-
-  /* Next symbol in obarray bucket, if the symbol is interned.  */
-  struct Lisp_Symbol *next;
 };
 
 /* Value is name of symbol.  */
@@ -2792,12 +2765,6 @@ set_symbol_plist (Lisp_Object sym, Lisp_Object plist)
   XSYMBOL (sym)->plist = plist;
 }
 
-INLINE void
-set_symbol_next (Lisp_Object sym, struct Lisp_Symbol *next)
-{
-  XSYMBOL (sym)->next = next;
-}
-
 /* Buffer-local (also frame-local) variable access functions.  */
 
 INLINE int
@@ -3331,6 +3298,7 @@ extern Lisp_Object Qlexical_binding;
 extern Lisp_Object check_obarray (Lisp_Object);
 extern Lisp_Object intern_1 (const char *, ptrdiff_t);
 extern Lisp_Object intern_c_string_1 (const char *, ptrdiff_t);
+extern Lisp_Object obhash (Lisp_Object);
 extern Lisp_Object oblookup (Lisp_Object, const char *, ptrdiff_t, ptrdiff_t);
 INLINE void
 LOADHIST_ATTACH (Lisp_Object x)
diff --git a/src/lread.c b/src/lread.c
index 974d605ad7..71ba6790a1 100644
--- a/src/lread.c
+++ b/src/lread.c
@@ -64,6 +64,8 @@ along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.  */
 #define file_tell ftell
 #endif
 
+static SCM obarrays;
+
 /* Hash table read constants.  */
 static Lisp_Object Qhash_table, Qdata;
 static Lisp_Object Qtest, Qsize;
@@ -3753,9 +3755,15 @@ read_list (bool flag, Lisp_Object readcharfun)
 
 static Lisp_Object initial_obarray;
 
-/* `oblookup' stores the bucket number here, for the sake of Funintern.  */
-
-static size_t oblookup_last_bucket_number;
+Lisp_Object
+obhash (Lisp_Object obarray)
+{
+  Lisp_Object tem = scm_hashq_get_handle (obarrays, obarray);
+  if (SCM_UNLIKELY (scm_is_false (tem)))
+    tem = scm_hashq_create_handle_x (obarrays, obarray,
+                                     scm_make_obarray ());
+  return scm_cdr (tem);
+}
 
 /* Get an error if OBARRAY is not an obarray.
    If it is one, return it.  */
@@ -3819,12 +3827,16 @@ it defaults to the value of `obarray'.  */)
   tem = oblookup (obarray, SSDATA (string),
 		  SCHARS (string),
 		  SBYTES (string));
-  if (!INTEGERP (tem))
+  if (SYMBOLP (tem))
     return tem;
 
   if (!NILP (Vpurify_flag))
     string = Fpurecopy (string);
-  sym = Fmake_symbol (string);
+
+  sym = scm_intern (scm_from_utf8_stringn (SSDATA (string),
+                                           SBYTES (string)),
+                    obhash (obarray));
+  initialize_symbol (sym, string);
 
   if (EQ (obarray, initial_obarray))
     XSYMBOL (sym)->interned = SYMBOL_INTERNED_IN_INITIAL_OBARRAY;
@@ -3839,13 +3851,9 @@ it defaults to the value of `obarray'.  */)
       SET_SYMBOL_VAL (XSYMBOL (sym), sym);
     }
 
-  ptr = aref_addr (obarray, XINT (tem));
-  if (SYMBOLP (*ptr))
-    set_symbol_next (sym, XSYMBOL (*ptr));
-  else
-    set_symbol_next (sym, NULL);
-  *ptr = sym;
-  return sym;
+  return scm_intern (scm_from_utf8_stringn (SSDATA (string),
+                                          SBYTES (string)),
+                     obhash (obarray));
 }
 
 DEFUN ("intern-soft", Fintern_soft, Sintern_soft, 1, 2, 0,
@@ -3875,6 +3883,22 @@ it defaults to the value of `obarray'.  */)
   else
     return tem;
 }
+
+DEFUN ("find-symbol", Ffind_symbol, Sfind_symbol, 1, 2, 0,
+       doc: /* find-symbol */)
+     (Lisp_Object string, Lisp_Object obarray)
+{
+  Lisp_Object tem;
+
+  obarray = check_obarray (NILP (obarray) ? Vobarray : obarray);
+  CHECK_STRING (string);
+
+  tem = oblookup (obarray, SSDATA (string), SCHARS (string), SBYTES (string));
+  if (INTEGERP (tem))
+    return scm_values (scm_list_2 (Qnil, Qnil));
+  else
+    return scm_values (scm_list_2 (tem, Qt));
+}
 
 DEFUN ("unintern", Funintern, Sunintern, 1, 2, 0,
        doc: /* Delete the symbol named NAME, if any, from OBARRAY.
@@ -3885,69 +3909,30 @@ OBARRAY, if nil, defaults to the value of the variable `obarray'.
 usage: (unintern NAME OBARRAY)  */)
   (Lisp_Object name, Lisp_Object obarray)
 {
-  register Lisp_Object string, tem;
-  size_t hash;
+  Lisp_Object string;
+  Lisp_Object tem;
 
-  if (NILP (obarray)) obarray = Vobarray;
+  if (NILP (obarray))
+    obarray = Vobarray;
   obarray = check_obarray (obarray);
 
   if (SYMBOLP (name))
-    string = SYMBOL_NAME (name);
-  else
-    {
-      CHECK_STRING (name);
-      string = name;
-    }
-
-  tem = oblookup (obarray, SSDATA (string),
-		  SCHARS (string),
-		  SBYTES (string));
-  if (INTEGERP (tem))
-    return Qnil;
-  /* If arg was a symbol, don't delete anything but that symbol itself.  */
-  if (SYMBOLP (name) && !EQ (name, tem))
-    return Qnil;
-
-  /* There are plenty of other symbols which will screw up the Emacs
-     session if we unintern them, as well as even more ways to use
-     `setq' or `fset' or whatnot to make the Emacs session
-     unusable.  Let's not go down this silly road.  --Stef  */
-  /* if (EQ (tem, Qnil) || EQ (tem, Qt))
-       error ("Attempt to unintern t or nil"); */
-
-  XSYMBOL (tem)->interned = SYMBOL_UNINTERNED;
-
-  hash = oblookup_last_bucket_number;
-
-  if (EQ (AREF (obarray, hash), tem))
     {
-      if (XSYMBOL (tem)->next)
-	{
-	  Lisp_Object sym;
-	  XSETSYMBOL (sym, XSYMBOL (tem)->next);
-	  ASET (obarray, hash, sym);
-	}
-      else
-	ASET (obarray, hash, make_number (0));
+      if (! EQ (name,
+                scm_find_symbol (scm_symbol_to_string (name),
+                                 obhash (obarray))))
+        return Qnil;
+      string = SYMBOL_NAME (name);
     }
   else
     {
-      Lisp_Object tail, following;
-
-      for (tail = AREF (obarray, hash);
-	   XSYMBOL (tail)->next;
-	   tail = following)
-	{
-	  XSETSYMBOL (following, XSYMBOL (tail)->next);
-	  if (EQ (following, tem))
-	    {
-	      set_symbol_next (tail, XSYMBOL (following)->next);
-	      break;
-	    }
-	}
+      CHECK_STRING (name);
+      string = name;
+      
     }
 
-  return Qt;
+  //XSYMBOL (tem)->interned = SYMBOL_UNINTERNED;
+  return (scm_is_true (scm_unintern (name, obhash (obarray))) ? Qt : Qnil);
 }
 
 /* Return the symbol in OBARRAY whose names matches the string
@@ -3960,52 +3945,32 @@ usage: (unintern NAME OBARRAY)  */)
 Lisp_Object
 oblookup (Lisp_Object obarray, register const char *ptr, ptrdiff_t size, ptrdiff_t size_byte)
 {
-  size_t hash;
-  size_t obsize;
-  register Lisp_Object tail;
-  Lisp_Object bucket, tem;
+  Lisp_Object sym;
+  Lisp_Object string2 = scm_from_utf8_stringn (ptr, size_byte);
 
   obarray = check_obarray (obarray);
-  obsize = ASIZE (obarray);
-  hash = hash_string (ptr, size_byte) % obsize;
-  bucket = AREF (obarray, hash);
-  oblookup_last_bucket_number = hash;
-  if (EQ (bucket, make_number (0)))
-    ;
-  else if (!SYMBOLP (bucket))
-    error ("Bad data in guts of obarray"); /* Like CADR error message.  */
+  sym = scm_find_symbol (string2, obhash (obarray));
+  if (scm_is_true (sym)
+      && scm_is_true (scm_module_variable (symbol_module, sym)))
+    return sym;
   else
-    for (tail = bucket; ; XSETSYMBOL (tail, XSYMBOL (tail)->next))
-      {
-	if (SBYTES (SYMBOL_NAME (tail)) == size_byte
-	    && SCHARS (SYMBOL_NAME (tail)) == size
-	    && !memcmp (SDATA (SYMBOL_NAME (tail)), ptr, size_byte))
-	  return tail;
-	else if (XSYMBOL (tail)->next == 0)
-	  break;
-      }
-  XSETINT (tem, hash);
-  return tem;
+    return make_number (0);
 }
 
 void
 map_obarray (Lisp_Object obarray, void (*fn) (Lisp_Object, Lisp_Object), Lisp_Object arg)
 {
-  ptrdiff_t i;
-  register Lisp_Object tail;
+  Lisp_Object proc (Lisp_Object sym)
+  {
+    Lisp_Object tem = Ffind_symbol (SYMBOL_NAME (sym), obarray);
+    if (scm_is_true (scm_c_value_ref (tem, 1))
+        && EQ (sym, scm_c_value_ref (tem, 0)))
+      fn (sym, arg);
+    return SCM_UNSPECIFIED;
+  }
   CHECK_VECTOR (obarray);
-  for (i = ASIZE (obarray) - 1; i >= 0; i--)
-    {
-      tail = AREF (obarray, i);
-      if (SYMBOLP (tail))
-	while (1)
-	  {
-	    (*fn) (tail, arg);
-	    if (XSYMBOL (tail)->next == 0)
-	      break;
-	    XSETSYMBOL (tail, XSYMBOL (tail)->next);
-	  }
-    }
+  scm_obarray_for_each (scm_c_make_gsubr ("proc", 1, 0, 0, proc),
+                        obhash (obarray));
 }
 
 static void
@@ -4040,6 +4005,9 @@ init_obarray (void)
   initial_obarray = Vobarray;
   staticpro (&initial_obarray);
 
+  obarrays = scm_make_hash_table (SCM_UNDEFINED);
+  scm_hashq_set_x (obarrays, Vobarray, SCM_UNDEFINED);
+
   Qunbound = Fmake_symbol (build_pure_c_string ("unbound"));
   /* Set temporary dummy values to Qnil and Vpurify_flag to satisfy the
      NILP (Vpurify_flag) check in intern_c_string.  */