From d23d13c03ca02a56c7f7f95e5712e482b320629f Mon Sep 17 00:00:00 2001 From: BT Templeton Date: Thu, 8 Aug 2013 00:26:57 -0400 Subject: [PATCH] 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. --- src/alloc.c | 33 +++++----- src/emacs.c | 7 +++ src/lisp.h | 60 +++++------------- src/lread.c | 172 +++++++++++++++++++++------------------------------- 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 #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 . */ #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. */ -- 2.20.1