From 73b617eaa9eea9139b73262d3ef923bc2ae451a6 Mon Sep 17 00:00:00 2001 From: =?utf8?q?Gerd=20M=C3=B6llmann?= Date: Thu, 20 Oct 2022 09:15:20 +0200 Subject: [PATCH] Change package symbol table layout The symbol table now stored symbol as key, and symbol status (:internal, :external) as values. Quite some changes due to that. --- src/lisp.h | 8 +- src/lread.c | 14 ++- src/pkg.c | 312 +++++++++++++++++++++++----------------------------- 3 files changed, 150 insertions(+), 184 deletions(-) diff --git a/src/lisp.h b/src/lisp.h index c35c600a539..ffea59017fa 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2271,15 +2271,12 @@ extern Lisp_Object pkg_qualified_symbol (Lisp_Object name, Lisp_Object package, extern void pkg_error (const char *fmt, ...); extern Lisp_Object pkg_unqualified_symbol (Lisp_Object name); extern bool pkg_keywordp (Lisp_Object obj); -extern Lisp_Object pkg_intern_keyword (Lisp_Object sym); -extern Lisp_Object pkg_define_keyword (Lisp_Object sym); -extern Lisp_Object pkg_define_non_keyword (Lisp_Object sym); -extern Lisp_Object pkg_intern_symbol (Lisp_Object sym, Lisp_Object package); +extern Lisp_Object pkg_define_symbol (Lisp_Object sym, Lisp_Object package); +extern Lisp_Object pkg_intern_symbol (Lisp_Object sym, Lisp_Object package, Lisp_Object *status); extern Lisp_Object pkg_emacs_intern (Lisp_Object name, Lisp_Object package); extern Lisp_Object pkg_emacs_intern_soft (Lisp_Object name, Lisp_Object package); extern Lisp_Object pkg_emacs_unintern (Lisp_Object name, Lisp_Object package); extern Lisp_Object pkg_emacs_mapatoms (Lisp_Object fn, Lisp_Object package); -extern Lisp_Object pkg_intern_non_keyword (Lisp_Object name); extern Lisp_Object pkg_intern_non_keyword_c_string (const char *p, ptrdiff_t len); extern Lisp_Object pkg_lookup_non_keyword_c_string (const char *ptr, ptrdiff_t nchars, ptrdiff_t nbytes); extern Lisp_Object pkg_intern_maybe_keyword (Lisp_Object name); @@ -4125,6 +4122,7 @@ ptrdiff_t hash_put (struct Lisp_Hash_Table *, Lisp_Object, Lisp_Object, Lisp_Object); bool hash_remove_from_table (struct Lisp_Hash_Table *, Lisp_Object); extern struct hash_table_test const hashtest_eq, hashtest_eql, hashtest_equal; +extern struct hash_table_test const hashtest_string_equal; extern void validate_subarray (Lisp_Object, Lisp_Object, Lisp_Object, ptrdiff_t, ptrdiff_t *, ptrdiff_t *); extern Lisp_Object substring_both (Lisp_Object, ptrdiff_t, ptrdiff_t, diff --git a/src/lread.c b/src/lread.c index f3d7b605df9..c14d48d363d 100644 --- a/src/lread.c +++ b/src/lread.c @@ -4354,6 +4354,12 @@ read0 (Lisp_Object readcharfun, bool locate_syms) result = Fmake_symbol (symbol_name); else if (NILP (package)) result = pkg_unqualified_symbol (symbol_name); + else if (NILP (Vpackage_prefixes)) + { + /* package should be nil unless we found a keyword. */ + eassert (EQ (package, Vkeyword_package)); + result = pkg_qualified_symbol (symbol_name, package, true); + } else result = pkg_qualified_symbol (symbol_name, package, ncolons == 1); @@ -4740,8 +4746,8 @@ intern_c_string_1 (const char *str, ptrdiff_t len, bool allow_pure_p) ? make_string (name_start, name_len) : make_pure_c_string (name_start, name_len)); if (keyword) - return pkg_intern_keyword (name); - return pkg_intern_non_keyword (name); + return pkg_intern_symbol (name, Vkeyword_package, NULL); + return pkg_intern_symbol (name, Vearmuffs_package, NULL); } Lisp_Object @@ -4765,9 +4771,9 @@ define_symbol (Lisp_Object sym, char const *str) if (!BASE_EQ (sym, Qunbound)) { if (keyword) - pkg_define_keyword (sym); + pkg_define_symbol (sym, Vkeyword_package); else - pkg_define_non_keyword (sym); + pkg_define_symbol (sym, Vemacs_package); } } diff --git a/src/pkg.c b/src/pkg.c index 80e9ed7cc3b..3d1a6dcf537 100644 --- a/src/pkg.c +++ b/src/pkg.c @@ -104,13 +104,6 @@ h_next (struct h_iter *it) Helpers ***********************************************************************/ -Lisp_Object -pkg_find_package (Lisp_Object name) -{ - CHECK_STRING (name); - return Fgethash (name, Vpackage_registry, Qnil); -} - /* Create and return a new Lisp package object for a package with name NAME, a string. NSYMBOLS is the sieo of the symbol-table to allocate. */ @@ -121,13 +114,33 @@ make_package (Lisp_Object name, Lisp_Object nsymbols) = ALLOCATE_ZEROED_PSEUDOVECTOR (struct Lisp_Package, symbols, PVEC_PACKAGE); pkg->name = name; - pkg->symbols = CALLN (Fmake_hash_table, QCtest, Qequal, + pkg->symbols = CALLN (Fmake_hash_table, QCtest, Qstring_equal, QCsize, nsymbols); Lisp_Object package; XSETPACKAGE (package, pkg); return package; } +Lisp_Object +pkg_find_package (Lisp_Object name) +{ + CHECK_STRING (name); + return Fgethash (name, Vpackage_registry, Qnil); +} + +/* Register package PACKAGE in the package registry, that is, make it + known under its name and all its nicknames. */ + +static void +register_package (Lisp_Object package) +{ + const struct Lisp_Package *pkg = XPACKAGE (package); + Fputhash (pkg->name, package, Vpackage_registry); + Lisp_Object tail = pkg->nicknames; + FOR_EACH_TAIL (tail) + Fputhash (XCAR (tail), package, Vpackage_registry); +} + /* Return a string for DESIGNATOR. If DESIGNATOR is a symbol, return the symbol's name. If DESIGNATOR is a string, return that string. If DESIGNATOR is a character, return a string that contains only @@ -186,42 +199,40 @@ package_or_default (Lisp_Object designator) return package_from_designator (designator); } -/* Register package PACKAGE in the package registry, that is, make it - known under its name and all its nicknames. */ - -static void -register_package (Lisp_Object package) -{ - const struct Lisp_Package *pkg = XPACKAGE (package); - Fputhash (pkg->name, package, Vpackage_registry); - Lisp_Object tail = pkg->nicknames; - FOR_EACH_TAIL (tail) - Fputhash (XCAR (tail), package, Vpackage_registry); -} - /*********************************************************************** Symbol table ***********************************************************************/ -/* This is a bit fiddly because nil is a "normal" symbol that has - a package and so on. */ - /* Find a symbol with name NAME in PACKAGE or one of the packages it inherits from. Value is Qunbound if no symbol is found. SEEN is a list of packages that have already been checked, to prevent infinte recursion. */ static Lisp_Object -lookup_symbol1 (Lisp_Object name, Lisp_Object package, Lisp_Object seen) +lookup_symbol1 (Lisp_Object name, Lisp_Object package, Lisp_Object seen, + Lisp_Object *status) { eassert (STRINGP (name)); eassert (PACKAGEP (package)); eassert (CONSP (seen) || NILP (seen)); + Lisp_Object symbol = Qunbound; + if (status) + *status = Qnil; + const struct Lisp_Package *pkg = XPACKAGE (package); - Lisp_Object symbol = Fgethash (name, pkg->symbols, Qunbound); - if (EQ (symbol, Qunbound)) + struct Lisp_Hash_Table *h = XHASH_TABLE (PACKAGE_SYMBOLS (package)); + ptrdiff_t i = hash_lookup (h, name, NULL); + if (i >= 0) { + symbol = HASH_KEY (h, i); + if (status) + *status = HASH_VALUE (h, i); + } + else + { + if (status) + *status = QCinherited; Lisp_Object tail = pkg->use_list; FOR_EACH_TAIL (tail) { @@ -229,7 +240,7 @@ lookup_symbol1 (Lisp_Object name, Lisp_Object package, Lisp_Object seen) if (NILP (Fmemq (used_package, seen))) { seen = Fcons (used_package, seen); - symbol = lookup_symbol1 (name, used_package, seen); + symbol = lookup_symbol1 (name, used_package, seen, NULL); if (!EQ (symbol, Qunbound)) return symbol; } @@ -240,53 +251,34 @@ lookup_symbol1 (Lisp_Object name, Lisp_Object package, Lisp_Object seen) } static Lisp_Object -lookup_symbol (Lisp_Object name, Lisp_Object package) +lookup_symbol (Lisp_Object name, Lisp_Object package, Lisp_Object *status) { - return lookup_symbol1(name, package, Qnil); + return lookup_symbol1 (name, package, Qnil, status); } +/* Add a SYMBOL to package PACKAGE. Value is SYMBOL. The symbol + is made external if PACKAGE is the keyword package. Otherwise it + is internal. */ + static Lisp_Object -add_to_package_symbols (Lisp_Object symbol, Lisp_Object package) +pkg_add_symbol (Lisp_Object symbol, Lisp_Object status, Lisp_Object package) { eassert (SYMBOLP (symbol)); + eassert (SYMBOLP (status)); eassert (PACKAGEP (package)); - Fputhash (SYMBOL_NAME (symbol), symbol, XPACKAGE (package)->symbols); + XSYMBOL (symbol)->u.s.external = EQ (package, Vkeyword_package); + Fputhash (symbol, status, PACKAGE_SYMBOLS (package)); return symbol; } -/* Remove NAME as a name for PACKAGE from the package registry. */ +/* Remove SYMBOL from PACKAGE. */ static void -remove_from_package_symbols (Lisp_Object symbol, Lisp_Object package) +pkg_remove_symbol (Lisp_Object symbol, Lisp_Object package) { eassert (SYMBOLP (symbol)); eassert (PACKAGEP (package)); - eassert (EQ (SYMBOL_PACKAGE (symbol), package)); - Fremhash (SYMBOL_NAME (symbol), XPACKAGE (package)->symbols); -} - -/* Add a new SYMBOL to package PACKAGE. Value is SYMBOL. The symbol - is made external if PACKAGE is the keyword package. Otherwise it - is internal. */ - -static Lisp_Object -pkg_add_symbol (Lisp_Object symbol, Lisp_Object package) -{ - eassert (SYMBOLP (symbol)); - eassert (PACKAGEP (package)); - eassert (NILP (SYMBOL_PACKAGE (symbol))); - - XSYMBOL (symbol)->u.s.package = package; - XSYMBOL (symbol)->u.s.external = EQ (package, Vkeyword_package); - - /* There should be no symbol with the name in the package. */ -#ifdef ENABLE_CHECKING - const Lisp_Object existing - = Fgethash (SYMBOL_NAME (symbol), XPACKAGE (package)->symbols, Qunbound); - eassert (EQ (existing, Qunbound)); -#endif - - return add_to_package_symbols (symbol, package); + Fremhash (symbol, PACKAGE_SYMBOLS (package)); } /* Remvoe SYMBOL from the shadowing list of PACKAGE. */ @@ -298,121 +290,75 @@ remove_shadowing_symbol (Lisp_Object symbol, Lisp_Object package) pkg->shadowing_symbols = Fdelq (symbol, pkg->shadowing_symbols); } -/* Return a list (SYMBOL STATUS) where STATUS is a symbol describing - the status of SYMBOL relative to PACKAGE (internal, external, - inherted). This is kind of a poor man's substitude for multiple - values. */ - -static Lisp_Object -symbol_and_status (Lisp_Object symbol, Lisp_Object package) -{ - if (EQ (symbol, Qunbound)) - return Qnil; - if (EQ (SYMBOL_PACKAGE (symbol), package)) - return list2 (symbol, SYMBOL_EXTERNAL_P (symbol) ? QCexternal : QCinternal); - return list2 (symbol, QCinherited); -} - /* Add a new symbol with name NAME to PACKAGE. If a symbol with name NAME is already accessible in PACKAGE, return that symbol. Otherwise, add a new symbol to PACKAGE. Value is the symbol found or newly inserted. */ -Lisp_Object -pkg_intern_symbol (const Lisp_Object symbol_or_name, Lisp_Object package) +static Lisp_Object +pkg_intern_symbol1 (const Lisp_Object name, Lisp_Object package, + Lisp_Object *status, Lisp_Object existing_symbol) { /* PKG-FIXME this symbol_or_name is shit. */ - eassert (PACKAGEP (package)); - - const Lisp_Object name - = SYMBOLP (symbol_or_name) ? SYMBOL_NAME (symbol_or_name) : symbol_or_name; CHECK_STRING (name); + eassert (PACKAGEP (package)); - /* If already present in package, return that. */ - Lisp_Object found = lookup_symbol (name, package); - if (!EQ (found, Qunbound)) - { - /* We should never find an uninterned symbol in a package. */ - eassert (!NILP (SYMBOL_PACKAGE (found))); - return found; - } - - /* Not found. If intended as a keyword, add it there. */ - if (EQ (package, Vkeyword_package)) - return pkg_intern_keyword (name); - - /* Not found, and we have already a symbol, use that symbol. */ - if (SYMBOLP (symbol_or_name)) - return pkg_add_symbol (symbol_or_name, package); + /* If already accessible in package, return that. */ + Lisp_Object symbol = lookup_symbol (name, package, status); + if (!EQ (symbol, Qunbound)) + return symbol; - /* Make a new symbol and add it. */ - return pkg_add_symbol (Fmake_symbol (name), package); -} + /* Not found. If we have an existing symbol (which should be a + built-in symbol), use that, otherwise make a new one. */ + if (!EQ (existing_symbol, Qunbound)) + symbol = existing_symbol; + else + symbol = Fmake_symbol (name); -/* Lookup or create a new keyword with name NAME. */ + /* PACKAGE becomes the home package of the symbol created. */ + XSYMBOL (symbol)->u.s.package = package; -Lisp_Object -pkg_intern_keyword (Lisp_Object name) -{ - eassert (STRINGP (name)); - eassert (SREF (name, 0) != ':'); - Lisp_Object keyword = lookup_symbol (name, Vkeyword_package); - if (EQ (keyword, Qunbound)) + if (EQ (package, Vkeyword_package)) { - keyword = Fmake_symbol (name); + if (status) + *status = QCexternal; /* Symbol-value of a keyword is itself, and cannot be set. */ - XSYMBOL (keyword)->u.s.redirect = SYMBOL_PLAINVAL; - XSYMBOL (keyword)->u.s.val.value = keyword; - make_symbol_constant (keyword); + XSYMBOL (symbol)->u.s.redirect = SYMBOL_PLAINVAL; + XSYMBOL (symbol)->u.s.val.value = symbol; + make_symbol_constant (symbol); /* Mark keywords as special. This makes (let ((:key 'foo)) ...) in lexically bound elisp signal an error, as documented. */ - XSYMBOL (keyword)->u.s.declared_special = true; - pkg_add_symbol (keyword, Vkeyword_package); + XSYMBOL (symbol)->u.s.declared_special = true; + pkg_add_symbol (symbol, QCexternal, Vkeyword_package); } else - eassert (SYMBOL_KEYWORD_P (keyword)); + { + if (status) + *status = QCinternal; + pkg_add_symbol (symbol, QCinternal, package); + } - return keyword; + return symbol; } -/* Define KEYWORD as keyword symbol. */ - Lisp_Object -pkg_define_keyword (Lisp_Object keyword) +pkg_intern_symbol (const Lisp_Object name, Lisp_Object package, + Lisp_Object *status) { - eassert (SYMBOLP (keyword)); - eassert (!EQ (keyword, Qunbound)); - eassert (SREF (SYMBOL_NAME (keyword), 0) != ':'); - - /* Symbol-value of a keyword is itself, and cannot be set. */ - XSYMBOL (keyword)->u.s.redirect = SYMBOL_PLAINVAL; - XSYMBOL (keyword)->u.s.val.value = keyword; - make_symbol_constant (keyword); - /* Mark keywords as special. This makes (let ((:key 'foo)) ...) - in lexically bound elisp signal an error, as documented. */ - XSYMBOL (keyword)->u.s.declared_special = true; - return pkg_add_symbol (keyword, Vkeyword_package); + return pkg_intern_symbol1 (name, package, status, Qunbound); } -Lisp_Object -pkg_define_non_keyword (Lisp_Object symbol) -{ - eassert (!EQ (symbol, Qunbound)); - return pkg_add_symbol (symbol, Vemacs_package); -} +/* Define SYMBOL in package. This is called from define_symbol for + built-in symbols. */ Lisp_Object -pkg_intern_non_keyword (Lisp_Object name) +pkg_define_symbol (Lisp_Object symbol, Lisp_Object package) { - return pkg_intern_symbol (name, Vearmuffs_package); + return pkg_intern_symbol1 (SYMBOL_NAME (symbol), package, NULL, symbol); } -Lisp_Object -pkg_intern_non_keyword_c_string (const char *p, ptrdiff_t len) -{ - const Lisp_Object name = make_unibyte_string (p, len); - return pkg_intern_non_keyword (name); -} +/* Intern NAME, which may or may not have a ':' in its name, that is + might be intended to be a keyword. */ Lisp_Object pkg_intern_maybe_keyword (Lisp_Object name) @@ -420,10 +366,10 @@ pkg_intern_maybe_keyword (Lisp_Object name) CHECK_STRING (name); if (SREF (name, 0) == ':') { - const Lisp_Object keyword_name = Fsubstring (name, make_fixnum (1), Qnil); - return pkg_intern_keyword (keyword_name); + name = Fsubstring (name, make_fixnum (1), Qnil); + return pkg_intern_symbol (name, Vkeyword_package, NULL); } - return pkg_intern_non_keyword (name); + return pkg_intern_symbol (name, Vearmuffs_package, NULL); } Lisp_Object @@ -431,24 +377,32 @@ pkg_lookup_non_keyword_c_string (const char *ptr, ptrdiff_t nchars, ptrdiff_t nb { eassert (*ptr != ':'); const Lisp_Object name = make_string_from_bytes (ptr, nchars, nbytes); - return lookup_symbol (name, Vearmuffs_package); + return lookup_symbol (name, Vearmuffs_package, NULL); } static Lisp_Object pkg_unintern_symbol (Lisp_Object symbol, Lisp_Object package) { CHECK_SYMBOL (symbol); - remove_shadowing_symbol (symbol, package); package = package_or_default (package); - remove_shadowing_symbol (symbol, package); - if (EQ (package, SYMBOL_PACKAGE (symbol))) + + Lisp_Object status; + Lisp_Object found = lookup_symbol (SYMBOL_NAME (symbol), package, &status); + Lisp_Object removedp = Qnil; + + if (!EQ (found, Qunbound) && !EQ (status, QCinherited)) { - remove_from_package_symbols (symbol, package); - return Qt; + /* Symbol is present in the package. Remove it from the symbol + table and shadowing list. */ + removedp = Qt; + remove_shadowing_symbol (symbol, package); + pkg_remove_symbol (symbol, package); } - /* PKG-FIXME: What to do if PACKAGE is not the home package? */ - return Qnil; + if (EQ (package, SYMBOL_PACKAGE (symbol))) + XSYMBOL (symbol)->u.s.package = Qnil; + + return removedp; } void pkg_break (void) @@ -461,7 +415,7 @@ pkg_map_package_symbols (Lisp_Object fn, Lisp_Object package) { package = check_package (package); FOR_EACH_KEY_VALUE (it_symbol, PACKAGE_SYMBOLS (package)) - call1 (fn, it_symbol.value); + call1 (fn, it_symbol.key); } @@ -479,7 +433,7 @@ pkg_map_symbols_c_fn (void (*fn) (Lisp_Object, Lisp_Object), Lisp_Object arg) { FOR_EACH_KEY_VALUE (it_package, Vpackage_registry) FOR_EACH_KEY_VALUE (it_symbol, PACKAGE_SYMBOLS (it_package.value)) - fn (it_symbol.value, arg); + fn (it_symbol.key, arg); } /*********************************************************************** @@ -508,13 +462,13 @@ fake_me_an_obarray (Lisp_Object vector) Lisp_Object package = Faref (vector, make_fixnum (0)); if (!PACKAGEP (package)) { - package = make_package (build_string ("fake obarray"), Qnil); + package = make_package (build_string ("obarray"), Qnil); Faset (vector, make_fixnum (0), package); } return package; } -/* Implements Emacs' old Fintern function. */ +/* Implements Emacs' traditional Fintern function. */ Lisp_Object pkg_emacs_intern (Lisp_Object name, Lisp_Object package) @@ -535,7 +489,7 @@ pkg_emacs_intern (Lisp_Object name, Lisp_Object package) package = fake_me_an_obarray (package); package = package_or_default (package); - return pkg_intern_symbol (name, package); + return pkg_intern_symbol (name, package, NULL); } /* Implements Emacs' old Fintern_soft function. */ @@ -561,9 +515,10 @@ pkg_emacs_intern_soft (Lisp_Object name, Lisp_Object package) package = fake_me_an_obarray (package); package = package_or_default (package); - Lisp_Object found = lookup_symbol (name, package); + Lisp_Object found = lookup_symbol (name, package, NULL); if (EQ (found, Qunbound)) return Qnil; + if (SYMBOLP (orig) && !EQ (found, orig)) return Qnil; @@ -600,11 +555,15 @@ pkg_emacs_mapatoms (Lisp_Object function, Lisp_Object package) Reader ***********************************************************************/ +/* We have read a symbol with NAME, and a package prefix for PACKAGE. + EXTERNAL means that we have seen ':' and not '::'. Value is the + symbol for that case. */ + Lisp_Object pkg_qualified_symbol (Lisp_Object name, Lisp_Object package, bool external) { /* If we want a symbol for a given package, check the - package has that symboland its accessibily. */ + package has that symbol and its accessibily. */ Lisp_Object found = Ffind_symbol (name, package); if (EQ (package, Vkeyword_package)) @@ -613,15 +572,14 @@ pkg_qualified_symbol (Lisp_Object name, Lisp_Object package, bool external) PKG-FIXME: there might already be a symbol named 'test' in the obarray, and we'd like to use that name for ':test'. That's a problem. */ - - /* PKG-FIXME: Make keywords constants. */ if (NILP (found)) - return pkg_intern_symbol (name, package); + return pkg_intern_symbol (name, package, NULL); return XCAR (found); } if (NILP (found)) - pkg_error ("Symbol '%s' is not present in package", SDATA (name)); + pkg_error ("Symbol '%s' is not accessible in package '%s'", + SDATA (name), SDATA (XPACKAGE (package)->name)); /* Check if the symbol is accesible in the package as external symbol. PKG-FIXME: Check what to do for inherited symbols. */ @@ -649,15 +607,15 @@ pkg_unqualified_symbol (Lisp_Object name) const Lisp_Object found = Ffind_symbol (name, package); if (!NILP (found)) return XCAR (found); - return pkg_intern_symbol (name, package); + return pkg_intern_symbol (name, package, NULL); } +/* Value is true if obj is a keyword symbol. */ + bool pkg_keywordp (Lisp_Object obj) { - if (!SYMBOLP (obj)) - return false; - return EQ (SYMBOL_PACKAGE (obj), Vkeyword_package); + return SYMBOLP (obj) && EQ (SYMBOL_PACKAGE (obj), Vkeyword_package); } @@ -699,8 +657,11 @@ symbol that was found, and STATUS is one of the following: { CHECK_STRING (name); package = package_or_default (package); - const Lisp_Object symbol = lookup_symbol (name, package); - return symbol_and_status (symbol, package); + Lisp_Object status; + const Lisp_Object symbol = lookup_symbol (name, package, &status); + if (EQ (symbol, Qunbound)) + return Qnil; + return list2 (symbol, status); } /* PKG-FIXME: Make this somehow compatible with Emacs' intern? */ @@ -721,8 +682,9 @@ package is the keyword package, or 'internal' if not. */) { CHECK_STRING (name); package = package_or_default (package); - const Lisp_Object symbol = pkg_intern_symbol (name, package); - return symbol_and_status (symbol, package); + Lisp_Object status; + const Lisp_Object symbol = pkg_intern_symbol (name, package, &status); + return list2 (symbol, status); } DEFUN ("cl-unintern", Fcl_unintern, Scl_unintern, 1, 2, 0, doc: -- 2.39.2