diff options
Diffstat (limited to 'src/lread.c')
| -rw-r--r-- | src/lread.c | 564 |
1 files changed, 356 insertions, 208 deletions
diff --git a/src/lread.c b/src/lread.c index e95dafcf222..1cb941e84fc 100644 --- a/src/lread.c +++ b/src/lread.c @@ -124,7 +124,7 @@ static struct android_fd_or_asset invalid_file_stream = #define file_stream struct android_fd_or_asset #define file_offset off_t -#define file_tell(n) (android_asset_lseek ((n), 0, SEEK_CUR)) +#define file_tell(n) android_asset_lseek (n, 0, SEEK_CUR) #define file_seek android_asset_lseek #define file_stream_valid_p(p) ((p).asset || (p).fd >= 0) #define file_stream_close android_close_asset @@ -1950,9 +1950,9 @@ maybe_swap_for_eln (bool no_native, Lisp_Object *filename, int *fd, = Fcons (list2 (Qcomp, CALLN (Fformat, - build_string ("Cannot look up eln " - "file as no source file " - "was found for %s"), + build_string ("Cannot look up .eln file " + "for %s because no source " + "file was found for it"), *filename)), Vdelayed_warnings_list); return; @@ -2369,8 +2369,14 @@ build_load_history (Lisp_Object filename, bool entire) front of load-history, the most-recently-loaded position. Also do this if we didn't find an existing member for the file. */ if (entire || !foundit) - Vload_history = Fcons (Fnreverse (Vcurrent_load_list), - Vload_history); + { + Lisp_Object tem = Fnreverse (Vcurrent_load_list); + eassert (EQ (filename, Fcar (tem))); + Vload_history = Fcons (tem, Vload_history); + /* FIXME: There should be an unbind_to right after calling us which + should re-establish the previous value of Vcurrent_load_list. */ + Vcurrent_load_list = Qt; + } } static void @@ -2437,11 +2443,13 @@ readevalloop (Lisp_Object readcharfun, bool whole_buffer = 0; /* True on the first time around. */ bool first_sexp = 1; - Lisp_Object macroexpand = intern ("internal-macroexpand-for-load"); + Lisp_Object macroexpand; if (!NILP (sourcename)) CHECK_STRING (sourcename); + macroexpand = Qinternal_macroexpand_for_load; + if (NILP (Ffboundp (macroexpand)) || (STRINGP (sourcename) && suffix_p (sourcename, ".elc"))) /* Don't macroexpand before the corresponding function is defined @@ -2544,15 +2552,11 @@ readevalloop (Lisp_Object readcharfun, if (! HASH_TABLE_P (read_objects_map) || XHASH_TABLE (read_objects_map)->count) read_objects_map - = make_hash_table (hashtest_eq, DEFAULT_HASH_SIZE, - DEFAULT_REHASH_SIZE, DEFAULT_REHASH_THRESHOLD, - Qnil, false); + = make_hash_table (&hashtest_eq, DEFAULT_HASH_SIZE, Weak_None, false); if (! HASH_TABLE_P (read_objects_completed) || XHASH_TABLE (read_objects_completed)->count) read_objects_completed - = make_hash_table (hashtest_eq, DEFAULT_HASH_SIZE, - DEFAULT_REHASH_SIZE, DEFAULT_REHASH_THRESHOLD, - Qnil, false); + = make_hash_table (&hashtest_eq, DEFAULT_HASH_SIZE, Weak_None, false); if (!NILP (Vpurify_flag) && c == '(') val = read0 (readcharfun, false); else @@ -2796,13 +2800,11 @@ read_internal_start (Lisp_Object stream, Lisp_Object start, Lisp_Object end, if (! HASH_TABLE_P (read_objects_map) || XHASH_TABLE (read_objects_map)->count) read_objects_map - = make_hash_table (hashtest_eq, DEFAULT_HASH_SIZE, DEFAULT_REHASH_SIZE, - DEFAULT_REHASH_THRESHOLD, Qnil, false); + = make_hash_table (&hashtest_eq, DEFAULT_HASH_SIZE, Weak_None, false); if (! HASH_TABLE_P (read_objects_completed) || XHASH_TABLE (read_objects_completed)->count) read_objects_completed - = make_hash_table (hashtest_eq, DEFAULT_HASH_SIZE, DEFAULT_REHASH_SIZE, - DEFAULT_REHASH_THRESHOLD, Qnil, false); + = make_hash_table (&hashtest_eq, DEFAULT_HASH_SIZE, Weak_None, false); if (STRINGP (stream) || ((CONSP (stream) && STRINGP (XCAR (stream))))) @@ -3412,7 +3414,7 @@ read_string_literal (Lisp_Object readcharfun) static Lisp_Object hash_table_from_plist (Lisp_Object plist) { - Lisp_Object params[12]; + Lisp_Object params[4 * 2]; Lisp_Object *par = params; /* This is repetitive but fast and simple. */ @@ -3426,31 +3428,30 @@ hash_table_from_plist (Lisp_Object plist) } \ } while (0) - ADDPARAM (size); ADDPARAM (test); ADDPARAM (weakness); - ADDPARAM (rehash_size); - ADDPARAM (rehash_threshold); ADDPARAM (purecopy); Lisp_Object data = plist_get (plist, Qdata); + if (!(NILP (data) || CONSP (data))) + error ("Hash table data is not a list"); + ptrdiff_t data_len = list_length (data); + if (data_len & 1) + error ("Hash table data length is odd"); + *par++ = QCsize; + *par++ = make_fixnum (data_len / 2); /* Now use params to make a new hash table and fill it. */ Lisp_Object ht = Fmake_hash_table (par - params, params); - Lisp_Object last = data; - FOR_EACH_TAIL_SAFE (data) + while (!NILP (data)) { Lisp_Object key = XCAR (data); data = XCDR (data); - if (!CONSP (data)) - break; Lisp_Object val = XCAR (data); - last = XCDR (data); Fputhash (key, val, ht); + data = XCDR (data); } - if (!NILP (last)) - error ("Hash table data is not a list of even length"); return ht; } @@ -3488,6 +3489,8 @@ vector_from_rev_list (Lisp_Object elems) return obj; } +static Lisp_Object get_lazy_string (Lisp_Object val); + static Lisp_Object bytecode_from_rev_list (Lisp_Object elems, Lisp_Object readcharfun) { @@ -3495,49 +3498,50 @@ bytecode_from_rev_list (Lisp_Object elems, Lisp_Object readcharfun) Lisp_Object *vec = XVECTOR (obj)->contents; ptrdiff_t size = ASIZE (obj); + if (infile && size >= COMPILED_CONSTANTS) + { + /* Always read 'lazily-loaded' bytecode (generated by the + `byte-compile-dynamic' feature prior to Emacs 30) eagerly, to + avoid code in the fast path during execution. */ + if (CONSP (vec[COMPILED_BYTECODE]) + && FIXNUMP (XCDR (vec[COMPILED_BYTECODE]))) + vec[COMPILED_BYTECODE] = get_lazy_string (vec[COMPILED_BYTECODE]); + + /* Lazily-loaded bytecode is represented by the constant slot being nil + and the bytecode slot a (lazily loaded) string containing the + print representation of (BYTECODE . CONSTANTS). Unpack the + pieces by coerceing the string to unibyte and reading the result. */ + if (NILP (vec[COMPILED_CONSTANTS]) && STRINGP (vec[COMPILED_BYTECODE])) + { + Lisp_Object enc = vec[COMPILED_BYTECODE]; + Lisp_Object pair = Fread (Fcons (enc, readcharfun)); + if (!CONSP (pair)) + invalid_syntax ("Invalid byte-code object", readcharfun); + + vec[COMPILED_BYTECODE] = XCAR (pair); + vec[COMPILED_CONSTANTS] = XCDR (pair); + } + } + if (!(size >= COMPILED_STACK_DEPTH + 1 && size <= COMPILED_INTERACTIVE + 1 && (FIXNUMP (vec[COMPILED_ARGLIST]) || CONSP (vec[COMPILED_ARGLIST]) || NILP (vec[COMPILED_ARGLIST])) + && STRINGP (vec[COMPILED_BYTECODE]) + && VECTORP (vec[COMPILED_CONSTANTS]) && FIXNATP (vec[COMPILED_STACK_DEPTH]))) invalid_syntax ("Invalid byte-code object", readcharfun); - if (load_force_doc_strings - && NILP (vec[COMPILED_CONSTANTS]) - && STRINGP (vec[COMPILED_BYTECODE])) - { - /* Lazily-loaded bytecode is represented by the constant slot being nil - and the bytecode slot a (lazily loaded) string containing the - print representation of (BYTECODE . CONSTANTS). Unpack the - pieces by coerceing the string to unibyte and reading the result. */ - Lisp_Object enc = vec[COMPILED_BYTECODE]; - Lisp_Object pair = Fread (Fcons (enc, readcharfun)); - if (!CONSP (pair)) - invalid_syntax ("Invalid byte-code object", readcharfun); - - vec[COMPILED_BYTECODE] = XCAR (pair); - vec[COMPILED_CONSTANTS] = XCDR (pair); - } + if (STRING_MULTIBYTE (vec[COMPILED_BYTECODE])) + /* BYTESTR must have been produced by Emacs 20.2 or earlier + because it produced a raw 8-bit string for byte-code and + now such a byte-code string is loaded as multibyte with + raw 8-bit characters converted to multibyte form. + Convert them back to the original unibyte form. */ + vec[COMPILED_BYTECODE] = Fstring_as_unibyte (vec[COMPILED_BYTECODE]); - if (!((STRINGP (vec[COMPILED_BYTECODE]) - && VECTORP (vec[COMPILED_CONSTANTS])) - || CONSP (vec[COMPILED_BYTECODE]))) - invalid_syntax ("Invalid byte-code object", readcharfun); - - if (STRINGP (vec[COMPILED_BYTECODE])) - { - if (STRING_MULTIBYTE (vec[COMPILED_BYTECODE])) - { - /* BYTESTR must have been produced by Emacs 20.2 or earlier - because it produced a raw 8-bit string for byte-code and - now such a byte-code string is loaded as multibyte with - raw 8-bit characters converted to multibyte form. - Convert them back to the original unibyte form. */ - vec[COMPILED_BYTECODE] = Fstring_as_unibyte (vec[COMPILED_BYTECODE]); - } - /* Bytecode must be immovable. */ - pin_string (vec[COMPILED_BYTECODE]); - } + /* Bytecode must be immovable. */ + pin_string (vec[COMPILED_BYTECODE]); XSETPVECTYPE (XVECTOR (obj), PVEC_COMPILED); return obj; @@ -4262,8 +4266,8 @@ read0 (Lisp_Object readcharfun, bool locate_syms) struct Lisp_Hash_Table *h = XHASH_TABLE (read_objects_map); Lisp_Object number = make_fixnum (n); - Lisp_Object hash; - ptrdiff_t i = hash_lookup (h, number, &hash); + hash_hash_t hash; + ptrdiff_t i = hash_lookup_get_hash (h, number, &hash); if (i >= 0) /* Not normal, but input could be malformed. */ set_hash_value_slot (h, i, placeholder); @@ -4281,7 +4285,7 @@ read0 (Lisp_Object readcharfun, bool locate_syms) /* #N# -- reference to numbered object */ struct Lisp_Hash_Table *h = XHASH_TABLE (read_objects_map); - ptrdiff_t i = hash_lookup (h, make_fixnum (n), NULL); + ptrdiff_t i = hash_lookup (h, make_fixnum (n)); if (i < 0) invalid_syntax ("#", readcharfun); obj = HASH_VALUE (h, i); @@ -4476,7 +4480,7 @@ read0 (Lisp_Object readcharfun, bool locate_syms) &longhand_chars, &longhand_bytes); - if (SYMBOLP (found)) + if (BARE_SYMBOL_P (found)) result = found; else if (longhand) { @@ -4578,8 +4582,8 @@ read0 (Lisp_Object readcharfun, bool locate_syms) struct Lisp_Hash_Table *h2 = XHASH_TABLE (read_objects_completed); - Lisp_Object hash; - ptrdiff_t i = hash_lookup (h2, placeholder, &hash); + hash_hash_t hash; + ptrdiff_t i = hash_lookup_get_hash (h2, placeholder, &hash); eassert (i < 0); hash_put (h2, placeholder, Qnil, hash); obj = placeholder; @@ -4593,8 +4597,8 @@ read0 (Lisp_Object readcharfun, bool locate_syms) { struct Lisp_Hash_Table *h2 = XHASH_TABLE (read_objects_completed); - Lisp_Object hash; - ptrdiff_t i = hash_lookup (h2, obj, &hash); + hash_hash_t hash; + ptrdiff_t i = hash_lookup_get_hash (h2, obj, &hash); eassert (i < 0); hash_put (h2, obj, Qnil, hash); } @@ -4605,8 +4609,9 @@ read0 (Lisp_Object readcharfun, bool locate_syms) /* ...and #n# will use the real value from now on. */ struct Lisp_Hash_Table *h = XHASH_TABLE (read_objects_map); - Lisp_Object hash; - ptrdiff_t i = hash_lookup (h, e->u.numbered.number, &hash); + hash_hash_t hash; + ptrdiff_t i = hash_lookup_get_hash (h, e->u.numbered.number, + &hash); eassert (i >= 0); set_hash_value_slot (h, i, obj); } @@ -4660,7 +4665,7 @@ substitute_object_recurse (struct subst *subst, Lisp_Object subtree) by #n=, which means that we can find it as a value in COMPLETED. */ if (EQ (subst->completed, Qt) - || hash_lookup (XHASH_TABLE (subst->completed), subtree, NULL) >= 0) + || hash_lookup (XHASH_TABLE (subst->completed), subtree) >= 0) subst->seen = Fcons (subtree, subst->seen); /* Recurse according to subtree's type. @@ -4881,49 +4886,65 @@ static Lisp_Object initial_obarray; static size_t oblookup_last_bucket_number; -/* Get an error if OBARRAY is not an obarray. - If it is one, return it. */ +static Lisp_Object make_obarray (unsigned bits); +/* Slow path obarray check: return the obarray to use or signal an error. */ Lisp_Object -check_obarray (Lisp_Object obarray) +check_obarray_slow (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)) + /* For compatibility, we accept vectors whose first element is 0, + and store an obarray object there. */ + if (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); + Lisp_Object obj = AREF (obarray, 0); + if (OBARRAYP (obj)) + return obj; + if (BASE_EQ (obj, make_fixnum (0))) + { + /* Put an actual obarray object in the first slot. + The rest of the vector remains unused. */ + obj = make_obarray (0); + ASET (obarray, 0, obj); + return obj; + } } - return obarray; + /* Reset Vobarray to the standard obarray for nicer error handling. */ + if (BASE_EQ (Vobarray, obarray)) Vobarray = initial_obarray; + + wrong_type_argument (Qobarrayp, obarray); } +static void grow_obarray (struct Lisp_Obarray *o); + /* Intern symbol SYM in OBARRAY using bucket INDEX. */ +/* FIXME: retype arguments as pure C types */ static Lisp_Object intern_sym (Lisp_Object sym, Lisp_Object obarray, Lisp_Object index) { - Lisp_Object *ptr; - - XSYMBOL (sym)->u.s.interned = (EQ (obarray, initial_obarray) - ? SYMBOL_INTERNED_IN_INITIAL_OBARRAY - : SYMBOL_INTERNED); + eassert (BARE_SYMBOL_P (sym) && OBARRAYP (obarray) && FIXNUMP (index)); + struct Lisp_Symbol *s = XBARE_SYMBOL (sym); + s->u.s.interned = (BASE_EQ (obarray, initial_obarray) + ? SYMBOL_INTERNED_IN_INITIAL_OBARRAY + : SYMBOL_INTERNED); - if (SREF (SYMBOL_NAME (sym), 0) == ':' && EQ (obarray, initial_obarray)) + if (SREF (s->u.s.name, 0) == ':' && BASE_EQ (obarray, initial_obarray)) { - make_symbol_constant (sym); - XSYMBOL (sym)->u.s.redirect = SYMBOL_PLAINVAL; + s->u.s.trapped_write = SYMBOL_NOWRITE; + s->u.s.redirect = SYMBOL_PLAINVAL; /* Mark keywords as special. This makes (let ((:key 'foo)) ...) in lexically bound elisp signal an error, as documented. */ - XSYMBOL (sym)->u.s.declared_special = true; - SET_SYMBOL_VAL (XSYMBOL (sym), sym); + s->u.s.declared_special = true; + SET_SYMBOL_VAL (s, sym); } - ptr = aref_addr (obarray, XFIXNUM (index)); - set_symbol_next (sym, SYMBOLP (*ptr) ? XSYMBOL (*ptr) : NULL); + struct Lisp_Obarray *o = XOBARRAY (obarray); + Lisp_Object *ptr = o->buckets + XFIXNUM (index); + s->u.s.next = BARE_SYMBOL_P (*ptr) ? XBARE_SYMBOL (*ptr) : NULL; *ptr = sym; + o->count++; + if (o->count > obarray_size (o)) + grow_obarray (o); return sym; } @@ -4932,7 +4953,7 @@ intern_sym (Lisp_Object sym, Lisp_Object obarray, Lisp_Object index) Lisp_Object intern_driver (Lisp_Object string, Lisp_Object obarray, Lisp_Object index) { - SET_SYMBOL_VAL (XSYMBOL (Qobarray_cache), Qnil); + SET_SYMBOL_VAL (XBARE_SYMBOL (Qobarray_cache), Qnil); return intern_sym (Fmake_symbol (string), obarray, index); } @@ -4945,7 +4966,7 @@ intern_1 (const char *str, ptrdiff_t len) Lisp_Object obarray = check_obarray (Vobarray); Lisp_Object tem = oblookup (obarray, str, len, len); - return (SYMBOLP (tem) ? tem + return (BARE_SYMBOL_P (tem) ? tem /* The above `oblookup' was done on the basis of nchars==nbytes, so the string has to be unibyte. */ : intern_driver (make_unibyte_string (str, len), @@ -4958,7 +4979,7 @@ intern_c_string_1 (const char *str, ptrdiff_t len) Lisp_Object obarray = check_obarray (Vobarray); Lisp_Object tem = oblookup (obarray, str, len, len); - if (!SYMBOLP (tem)) + if (!BARE_SYMBOL_P (tem)) { Lisp_Object string; @@ -5010,7 +5031,7 @@ it defaults to the value of `obarray'. */) &longhand, &longhand_chars, &longhand_bytes); - if (!SYMBOLP (tem)) + if (!BARE_SYMBOL_P (tem)) { if (longhand) { @@ -5059,10 +5080,11 @@ it defaults to the value of `obarray'. */) { /* If already a symbol, we don't do shorthand-longhand translation, as promised in the docstring. */ - string = SYMBOL_NAME (name); + Lisp_Object sym = maybe_remove_pos_from_symbol (name); + string = XSYMBOL (name)->u.s.name; tem = oblookup (obarray, SSDATA (string), SCHARS (string), SBYTES (string)); - return EQ (name, tem) ? name : Qnil; + return BASE_EQ (sym, tem) ? name : Qnil; } } @@ -5077,13 +5099,16 @@ usage: (unintern NAME OBARRAY) */) { register Lisp_Object tem; Lisp_Object string; - size_t hash; if (NILP (obarray)) obarray = Vobarray; obarray = check_obarray (obarray); if (SYMBOLP (name)) - string = SYMBOL_NAME (name); + { + if (!BARE_SYMBOL_P (name)) + name = XSYMBOL_WITH_POS (name)->sym; + string = SYMBOL_NAME (name); + } else { CHECK_STRING (name); @@ -5103,7 +5128,7 @@ usage: (unintern NAME OBARRAY) */) if (FIXNUMP (tem)) return Qnil; /* If arg was a symbol, don't delete anything but that symbol itself. */ - if (SYMBOLP (name) && !EQ (name, tem)) + if (BARE_SYMBOL_P (name) && !BASE_EQ (name, tem)) return Qnil; /* There are plenty of other symbols which will screw up the Emacs @@ -5113,41 +5138,42 @@ usage: (unintern NAME OBARRAY) */) /* if (NILP (tem) || EQ (tem, Qt)) error ("Attempt to unintern t or nil"); */ - XSYMBOL (tem)->u.s.interned = SYMBOL_UNINTERNED; + struct Lisp_Symbol *sym = XBARE_SYMBOL (tem); + sym->u.s.interned = SYMBOL_UNINTERNED; - hash = oblookup_last_bucket_number; + ptrdiff_t idx = oblookup_last_bucket_number; + Lisp_Object *loc = &XOBARRAY (obarray)->buckets[idx]; - if (EQ (AREF (obarray, hash), tem)) - { - if (XSYMBOL (tem)->u.s.next) - { - Lisp_Object sym; - XSETSYMBOL (sym, XSYMBOL (tem)->u.s.next); - ASET (obarray, hash, sym); - } - else - ASET (obarray, hash, make_fixnum (0)); - } + eassert (BARE_SYMBOL_P (*loc)); + struct Lisp_Symbol *prev = XBARE_SYMBOL (*loc); + if (sym == prev) + *loc = sym->u.s.next ? make_lisp_symbol (sym->u.s.next) : make_fixnum (0); else - { - Lisp_Object tail, following; + while (1) + { + struct Lisp_Symbol *next = prev->u.s.next; + if (next == sym) + { + prev->u.s.next = next->u.s.next; + break; + } + prev = next; + } - for (tail = AREF (obarray, hash); - XSYMBOL (tail)->u.s.next; - tail = following) - { - XSETSYMBOL (following, XSYMBOL (tail)->u.s.next); - if (EQ (following, tem)) - { - set_symbol_next (tail, XSYMBOL (following)->u.s.next); - break; - } - } - } + XOBARRAY (obarray)->count--; return Qt; } + +/* Bucket index of the string STR of length SIZE_BYTE bytes in obarray OA. */ +static ptrdiff_t +obarray_index (struct Lisp_Obarray *oa, const char *str, ptrdiff_t size_byte) +{ + EMACS_UINT hash = hash_string (str, size_byte); + return knuth_hash (reduce_emacs_uint_to_hash_hash (hash), oa->size_bits); +} + /* Return the symbol in OBARRAY whose names matches the string of SIZE characters (SIZE_BYTE bytes) at PTR. If there is no such symbol, return the integer bucket number of @@ -5158,35 +5184,27 @@ 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; + struct Lisp_Obarray *o = XOBARRAY (obarray); + ptrdiff_t idx = obarray_index (o, ptr, size_byte); + Lisp_Object bucket = o->buckets[idx]; - obarray = check_obarray (obarray); - /* This is sometimes needed in the middle of GC. */ - obsize = gc_asize (obarray); - hash = hash_string (ptr, size_byte) % obsize; - bucket = AREF (obarray, hash); - oblookup_last_bucket_number = hash; - if (BASE_EQ (bucket, make_fixnum (0))) - ; - else if (!SYMBOLP (bucket)) - /* Like CADR error message. */ - xsignal2 (Qwrong_type_argument, Qobarrayp, - build_string ("Bad data in guts of obarray")); - else - for (tail = bucket; ; XSETSYMBOL (tail, XSYMBOL (tail)->u.s.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)->u.s.next == 0) - break; - } - XSETINT (tem, hash); - return tem; + oblookup_last_bucket_number = idx; + if (!BASE_EQ (bucket, make_fixnum (0))) + { + Lisp_Object sym = bucket; + while (1) + { + struct Lisp_Symbol *s = XBARE_SYMBOL (sym); + Lisp_Object name = s->u.s.name; + if (SBYTES (name) == size_byte && SCHARS (name) == size + && memcmp (SDATA (name), ptr, size_byte) == 0) + return sym; + if (s->u.s.next == NULL) + break; + sym = make_lisp_symbol(s->u.s.next); + } + } + return make_fixnum (idx); } /* Like 'oblookup', but considers 'Vread_symbol_shorthands', @@ -5253,24 +5271,134 @@ oblookup_considering_shorthand (Lisp_Object obarray, const char *in, } -void -map_obarray (Lisp_Object obarray, void (*fn) (Lisp_Object, Lisp_Object), Lisp_Object arg) +static struct Lisp_Obarray * +allocate_obarray (void) { - ptrdiff_t i; - register Lisp_Object tail; - CHECK_VECTOR (obarray); - for (i = ASIZE (obarray) - 1; i >= 0; i--) + return ALLOCATE_PLAIN_PSEUDOVECTOR (struct Lisp_Obarray, PVEC_OBARRAY); +} + +static Lisp_Object +make_obarray (unsigned bits) +{ + struct Lisp_Obarray *o = allocate_obarray (); + o->count = 0; + o->size_bits = bits; + ptrdiff_t size = (ptrdiff_t)1 << bits; + o->buckets = hash_table_alloc_bytes (size * sizeof *o->buckets); + for (ptrdiff_t i = 0; i < size; i++) + o->buckets[i] = make_fixnum (0); + return make_lisp_obarray (o); +} + +enum { + obarray_default_bits = 3, + word_size_log2 = word_size < 8 ? 5 : 6, /* good enough */ + obarray_max_bits = min (8 * sizeof (int), + 8 * sizeof (ptrdiff_t) - word_size_log2) - 1, +}; + +static void +grow_obarray (struct Lisp_Obarray *o) +{ + ptrdiff_t old_size = obarray_size (o); + eassert (o->count > old_size); + Lisp_Object *old_buckets = o->buckets; + + int new_bits = o->size_bits + 1; + if (new_bits > obarray_max_bits) + error ("Obarray too big"); + ptrdiff_t new_size = (ptrdiff_t)1 << new_bits; + o->buckets = hash_table_alloc_bytes (new_size * sizeof *o->buckets); + for (ptrdiff_t i = 0; i < new_size; i++) + o->buckets[i] = make_fixnum (0); + o->size_bits = new_bits; + + /* Rehash symbols. + FIXME: this is expensive since we need to recompute the hash for every + symbol name. Would it be reasonable to store it in the symbol? */ + for (ptrdiff_t i = 0; i < old_size; i++) { - tail = AREF (obarray, i); - if (SYMBOLP (tail)) - while (1) - { - (*fn) (tail, arg); - if (XSYMBOL (tail)->u.s.next == 0) - break; - XSETSYMBOL (tail, XSYMBOL (tail)->u.s.next); - } + Lisp_Object obj = old_buckets[i]; + if (BARE_SYMBOL_P (obj)) + { + struct Lisp_Symbol *s = XBARE_SYMBOL (obj); + while (1) + { + Lisp_Object name = s->u.s.name; + ptrdiff_t idx = obarray_index (o, SSDATA (name), SBYTES (name)); + Lisp_Object *loc = o->buckets + idx; + struct Lisp_Symbol *next = s->u.s.next; + s->u.s.next = BARE_SYMBOL_P (*loc) ? XBARE_SYMBOL (*loc) : NULL; + *loc = make_lisp_symbol (s); + if (next == NULL) + break; + s = next; + } + } } + + hash_table_free_bytes (old_buckets, old_size * sizeof *old_buckets); +} + +DEFUN ("obarray-make", Fobarray_make, Sobarray_make, 0, 1, 0, + doc: /* Return a new obarray of size SIZE. +The obarray will grow to accommodate any number of symbols; the size, if +given, is only a hint for the expected number. */) + (Lisp_Object size) +{ + int bits; + if (NILP (size)) + bits = obarray_default_bits; + else + { + CHECK_FIXNAT (size); + EMACS_UINT n = XFIXNUM (size); + bits = elogb (n) + 1; + if (bits > obarray_max_bits) + xsignal (Qargs_out_of_range, size); + } + return make_obarray (bits); +} + +DEFUN ("obarrayp", Fobarrayp, Sobarrayp, 1, 1, 0, + doc: /* Return t iff OBJECT is an obarray. */) + (Lisp_Object object) +{ + return OBARRAYP (object) ? Qt : Qnil; +} + +DEFUN ("obarray-clear", Fobarray_clear, Sobarray_clear, 1, 1, 0, + doc: /* Remove all symbols from OBARRAY. */) + (Lisp_Object obarray) +{ + CHECK_OBARRAY (obarray); + struct Lisp_Obarray *o = XOBARRAY (obarray); + + /* This function does not bother setting the status of its contained symbols + to uninterned. It doesn't matter very much. */ + int new_bits = obarray_default_bits; + int new_size = (ptrdiff_t)1 << new_bits; + Lisp_Object *new_buckets + = hash_table_alloc_bytes (new_size * sizeof *new_buckets); + for (ptrdiff_t i = 0; i < new_size; i++) + new_buckets[i] = make_fixnum (0); + + int old_size = obarray_size (o); + hash_table_free_bytes (o->buckets, old_size * sizeof *o->buckets); + o->buckets = new_buckets; + o->size_bits = new_bits; + o->count = 0; + + return Qnil; +} + +void +map_obarray (Lisp_Object obarray, + void (*fn) (Lisp_Object, Lisp_Object), Lisp_Object arg) +{ + CHECK_OBARRAY (obarray); + DOOBARRAY (XOBARRAY (obarray), it) + (*fn) (obarray_iter_symbol (&it), arg); } static void @@ -5291,12 +5419,37 @@ OBARRAY defaults to the value of `obarray'. */) return Qnil; } -#define OBARRAY_SIZE 15121 +DEFUN ("internal--obarray-buckets", + Finternal__obarray_buckets, Sinternal__obarray_buckets, 1, 1, 0, + doc: /* Symbols in each bucket of OBARRAY. Internal use only. */) + (Lisp_Object obarray) +{ + obarray = check_obarray (obarray); + ptrdiff_t size = obarray_size (XOBARRAY (obarray)); + + Lisp_Object ret = Qnil; + for (ptrdiff_t i = 0; i < size; i++) + { + Lisp_Object bucket = Qnil; + Lisp_Object sym = XOBARRAY (obarray)->buckets[i]; + if (BARE_SYMBOL_P (sym)) + while (1) + { + bucket = Fcons (sym, bucket); + struct Lisp_Symbol *s = XBARE_SYMBOL (sym)->u.s.next; + if (!s) + break; + sym = make_lisp_symbol (s); + } + ret = Fcons (Fnreverse (bucket), ret); + } + return Fnreverse (ret); +} void init_obarray_once (void) { - Vobarray = make_vector (OBARRAY_SIZE, make_fixnum (0)); + Vobarray = make_obarray (15); initial_obarray = Vobarray; staticpro (&initial_obarray); @@ -5306,14 +5459,14 @@ init_obarray_once (void) DEFSYM (Qunbound, "unbound"); DEFSYM (Qnil, "nil"); - SET_SYMBOL_VAL (XSYMBOL (Qnil), Qnil); + SET_SYMBOL_VAL (XBARE_SYMBOL (Qnil), Qnil); make_symbol_constant (Qnil); - XSYMBOL (Qnil)->u.s.declared_special = true; + XBARE_SYMBOL (Qnil)->u.s.declared_special = true; DEFSYM (Qt, "t"); - SET_SYMBOL_VAL (XSYMBOL (Qt), Qt); + SET_SYMBOL_VAL (XBARE_SYMBOL (Qt), Qt); make_symbol_constant (Qt); - XSYMBOL (Qt)->u.s.declared_special = true; + XBARE_SYMBOL (Qt)->u.s.declared_special = true; /* Qt is correct even if not dumping. loadup.el will set to nil at end. */ Vpurify_flag = Qt; @@ -5337,16 +5490,6 @@ defsubr (union Aligned_Lisp_Subr *aname) #endif } -#ifdef NOTDEF /* Use fset in subr.el now! */ -void -defalias (struct Lisp_Subr *sname, char *string) -{ - Lisp_Object sym; - sym = intern (string); - XSETSUBR (XSYMBOL (sym)->u.s.function, sname); -} -#endif /* NOTDEF */ - /* Define an "integer variable"; a symbol whose value is forwarded to a C variable of type intmax_t. Sample call (with "xx" to fool make-docfile): DEFxxVAR_INT ("emacs-priority", &emacs_priority, "Documentation"); */ @@ -5354,9 +5497,9 @@ void defvar_int (struct Lisp_Intfwd const *i_fwd, char const *namestring) { Lisp_Object sym = intern_c_string (namestring); - XSYMBOL (sym)->u.s.declared_special = true; - XSYMBOL (sym)->u.s.redirect = SYMBOL_FORWARDED; - SET_SYMBOL_FWD (XSYMBOL (sym), i_fwd); + XBARE_SYMBOL (sym)->u.s.declared_special = true; + XBARE_SYMBOL (sym)->u.s.redirect = SYMBOL_FORWARDED; + SET_SYMBOL_FWD (XBARE_SYMBOL (sym), i_fwd); } /* Similar but define a variable whose value is t if 1, nil if 0. */ @@ -5364,9 +5507,9 @@ void defvar_bool (struct Lisp_Boolfwd const *b_fwd, char const *namestring) { Lisp_Object sym = intern_c_string (namestring); - XSYMBOL (sym)->u.s.declared_special = true; - XSYMBOL (sym)->u.s.redirect = SYMBOL_FORWARDED; - SET_SYMBOL_FWD (XSYMBOL (sym), b_fwd); + XBARE_SYMBOL (sym)->u.s.declared_special = true; + XBARE_SYMBOL (sym)->u.s.redirect = SYMBOL_FORWARDED; + SET_SYMBOL_FWD (XBARE_SYMBOL (sym), b_fwd); Vbyte_boolean_vars = Fcons (sym, Vbyte_boolean_vars); } @@ -5379,9 +5522,9 @@ void defvar_lisp_nopro (struct Lisp_Objfwd const *o_fwd, char const *namestring) { Lisp_Object sym = intern_c_string (namestring); - XSYMBOL (sym)->u.s.declared_special = true; - XSYMBOL (sym)->u.s.redirect = SYMBOL_FORWARDED; - SET_SYMBOL_FWD (XSYMBOL (sym), o_fwd); + XBARE_SYMBOL (sym)->u.s.declared_special = true; + XBARE_SYMBOL (sym)->u.s.redirect = SYMBOL_FORWARDED; + SET_SYMBOL_FWD (XBARE_SYMBOL (sym), o_fwd); } void @@ -5398,9 +5541,9 @@ void defvar_kboard (struct Lisp_Kboard_Objfwd const *ko_fwd, char const *namestring) { Lisp_Object sym = intern_c_string (namestring); - XSYMBOL (sym)->u.s.declared_special = true; - XSYMBOL (sym)->u.s.redirect = SYMBOL_FORWARDED; - SET_SYMBOL_FWD (XSYMBOL (sym), ko_fwd); + XBARE_SYMBOL (sym)->u.s.declared_special = true; + XBARE_SYMBOL (sym)->u.s.redirect = SYMBOL_FORWARDED; + SET_SYMBOL_FWD (XBARE_SYMBOL (sym), ko_fwd); } /* Check that the elements of lpath exist. */ @@ -5688,6 +5831,10 @@ syms_of_lread (void) defsubr (&Sget_file_char); defsubr (&Smapatoms); defsubr (&Slocate_file_internal); + defsubr (&Sinternal__obarray_buckets); + defsubr (&Sobarray_make); + defsubr (&Sobarrayp); + defsubr (&Sobarray_clear); DEFVAR_LISP ("obarray", Vobarray, doc: /* Symbol table for use by `intern' and `read'. @@ -5699,7 +5846,7 @@ to find all the symbols in an obarray, use `mapatoms'. */); doc: /* List of values of all expressions which were read, evaluated and printed. Order is reverse chronological. This variable is obsolete as of Emacs 28.1 and should not be used. */); - XSYMBOL (intern ("values"))->u.s.declared_special = false; + XBARE_SYMBOL (intern ("values"))->u.s.declared_special = false; DEFVAR_LISP ("standard-input", Vstandard_input, doc: /* Stream for read to get input from. @@ -5997,8 +6144,6 @@ that are loaded before your customizations are read! */); DEFSYM (Qsize, "size"); DEFSYM (Qpurecopy, "purecopy"); DEFSYM (Qweakness, "weakness"); - DEFSYM (Qrehash_size, "rehash-size"); - DEFSYM (Qrehash_threshold, "rehash-threshold"); DEFSYM (Qchar_from_name, "char-from-name"); @@ -6015,4 +6160,7 @@ See Info node `(elisp)Shorthands' for more details. */); doc: /* List of variables declared dynamic in the current scope. Only valid during macro-expansion. Internal use only. */); Vmacroexp__dynvars = Qnil; + + DEFSYM (Qinternal_macroexpand_for_load, + "internal-macroexpand-for-load"); } |