diff options
Diffstat (limited to 'src/lread.c')
| -rw-r--r-- | src/lread.c | 779 |
1 files changed, 425 insertions, 354 deletions
diff --git a/src/lread.c b/src/lread.c index b0eb29a2a1f..788e57b707f 100644 --- a/src/lread.c +++ b/src/lread.c @@ -72,6 +72,10 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #define file_tell ftell #endif +#if IEEE_FLOATING_POINT +# include <ieee754.h> +#endif + /* The objects or placeholders read with the #n=object form. A hash table maps a number to either a placeholder (while the @@ -147,10 +151,10 @@ static ptrdiff_t prev_saved_doc_string_length; /* This is the file position that string came from. */ static file_offset prev_saved_doc_string_position; -/* True means inside a new-style backquote - with no surrounding parentheses. - Fread initializes this to false, so we need not specbind it - or worry about what happens to it when there is an error. */ +/* True means inside a new-style backquote with no surrounding + parentheses. Fread initializes this to the value of + `force_new_style_backquotes', so we need not specbind it or worry + about what happens to it when there is an error. */ static bool new_backquote_flag; /* A list of file names for files being loaded in Fload. Used to @@ -164,6 +168,8 @@ static int read_emacs_mule_char (int, int (*) (int, Lisp_Object), static void readevalloop (Lisp_Object, struct infile *, Lisp_Object, bool, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object); + +static void build_load_history (Lisp_Object, bool); /* Functions that read one byte from the current source READCHARFUN or unreads one byte. If the integer argument C is -1, it returns @@ -329,7 +335,7 @@ readchar (Lisp_Object readcharfun, bool *multibyte) if (NILP (tem)) return -1; - return XINT (tem); + return XFIXNUM (tem); read_multibyte: if (unread_char >= 0) @@ -461,7 +467,7 @@ unreadchar (Lisp_Object readcharfun, int c) unread_char = c; } else - call1 (readcharfun, make_number (c)); + call1 (readcharfun, make_fixnum (c)); } static int @@ -671,7 +677,7 @@ read_filtered_event (bool no_switch_frame, bool ascii_required, do val = read_char (0, Qnil, (input_method ? Qnil : Qt), 0, NUMBERP (seconds) ? &end_time : NULL); - while (INTEGERP (val) && XINT (val) == -2); /* wrong_kboard_jmpbuf */ + while (FIXNUMP (val) && XFIXNUM (val) == -2); /* wrong_kboard_jmpbuf */ if (BUFFERP (val)) goto retry; @@ -702,12 +708,12 @@ read_filtered_event (bool no_switch_frame, bool ascii_required, /* Merge this symbol's modifier bits with the ASCII equivalent of its basic code. */ if (!NILP (tem1)) - XSETFASTINT (val, XINT (tem1) | XINT (Fcar (Fcdr (tem)))); + XSETFASTINT (val, XFIXNUM (tem1) | XFIXNUM (Fcar (Fcdr (tem)))); } } /* If we don't have a character now, deal with it appropriately. */ - if (!INTEGERP (val)) + if (!FIXNUMP (val)) { if (error_nonascii) { @@ -768,7 +774,7 @@ floating-point value. */) val = read_filtered_event (1, 1, 1, ! NILP (inherit_input_method), seconds); return (NILP (val) ? Qnil - : make_number (char_resolve_modifier_mask (XINT (val)))); + : make_fixnum (char_resolve_modifier_mask (XFIXNUM (val)))); } DEFUN ("read-event", Fread_event, Sread_event, 0, 3, 0, @@ -816,7 +822,7 @@ floating-point value. */) val = read_filtered_event (1, 1, 0, ! NILP (inherit_input_method), seconds); return (NILP (val) ? Qnil - : make_number (char_resolve_modifier_mask (XINT (val)))); + : make_fixnum (char_resolve_modifier_mask (XFIXNUM (val)))); } DEFUN ("get-file-char", Fget_file_char, Sget_file_char, 0, 0, 0, @@ -825,7 +831,7 @@ DEFUN ("get-file-char", Fget_file_char, Sget_file_char, 0, 0, 0, { if (!infile) error ("get-file-char misused"); - return make_number (readbyte_from_stdio ()); + return make_fixnum (readbyte_from_stdio ()); } @@ -1013,13 +1019,15 @@ load_error_handler (Lisp_Object data) return Qnil; } -static void -load_warn_old_style_backquotes (Lisp_Object file) +static _Noreturn void +load_error_old_style_backquotes (void) { - if (!NILP (Vlread_old_style_backquotes)) + if (NILP (Vload_file_name)) + xsignal1 (Qerror, build_string ("Old-style backquotes detected!")); + else { AUTO_STRING (format, "Loading `%s': old-style backquotes detected!"); - CALLN (Fmessage, format, file); + xsignal1 (Qerror, CALLN (Fformat_message, format, Vload_file_name)); } } @@ -1129,7 +1137,7 @@ Return t if the file exists and loads successfully. */) (Lisp_Object file, Lisp_Object noerror, Lisp_Object nomessage, Lisp_Object nosuffix, Lisp_Object must_suffix) { - FILE *stream; + FILE *stream UNINIT; int fd; int fd_index UNINIT; ptrdiff_t count = SPECPDL_INDEX (); @@ -1254,8 +1262,9 @@ Return t if the file exists and loads successfully. */) } #ifdef HAVE_MODULES - if (suffix_p (found, MODULES_SUFFIX)) - return unbind_to (count, Fmodule_load (found)); + bool is_module = suffix_p (found, MODULES_SUFFIX); +#else + bool is_module = false; #endif /* Check if we're stuck in a recursive load cycle. @@ -1292,10 +1301,6 @@ Return t if the file exists and loads successfully. */) version = -1; - /* Check for the presence of old-style quotes and warn about them. */ - specbind (Qlread_old_style_backquotes, Qnil); - record_unwind_protect (load_warn_old_style_backquotes, file); - /* Check for the presence of unescaped character literals and warn about them. */ specbind (Qlread_unescaped_character_literals, Qnil); @@ -1352,7 +1357,7 @@ Return t if the file exists and loads successfully. */) if (!NILP (nomessage) && !force_load_messages) { Lisp_Object msg_file; - msg_file = Fsubstring (found, make_number (0), make_number (-1)); + msg_file = Fsubstring (found, make_fixnum (0), make_fixnum (-1)); message_with_string ("Source file `%s' newer than byte-compiled file", msg_file, 1); } @@ -1360,7 +1365,7 @@ Return t if the file exists and loads successfully. */) } /* !load_prefer_newer */ } } - else + else if (!is_module) { /* We are loading a source file (*.el). */ if (!NILP (Vload_source_file_function)) @@ -1387,7 +1392,7 @@ Return t if the file exists and loads successfully. */) stream = NULL; errno = EINVAL; } - else + else if (!is_module) { #ifdef WINDOWSNT emacs_close (fd); @@ -1398,9 +1403,23 @@ Return t if the file exists and loads successfully. */) stream = fdopen (fd, fmode); #endif } - if (! stream) - report_file_error ("Opening stdio stream", file); - set_unwind_protect_ptr (fd_index, close_infile_unwind, stream); + + if (is_module) + { + /* `module-load' uses the file name, so we can close the stream + now. */ + if (fd >= 0) + { + emacs_close (fd); + clear_unwind_protect (fd_index); + } + } + else + { + if (! stream) + report_file_error ("Opening stdio stream", file); + set_unwind_protect_ptr (fd_index, close_infile_unwind, stream); + } if (! NILP (Vpurify_flag)) Vpreloaded_file_list = Fcons (Fpurecopy (file), Vpreloaded_file_list); @@ -1410,6 +1429,8 @@ Return t if the file exists and loads successfully. */) if (!safe_p) message_with_string ("Loading %s (compiled; note unsafe, not compiled in Emacs)...", file, 1); + else if (is_module) + message_with_string ("Loading %s (module)...", file, 1); else if (!compiled) message_with_string ("Loading %s (source)...", file, 1); else if (newer) @@ -1423,24 +1444,39 @@ Return t if the file exists and loads successfully. */) specbind (Qinhibit_file_name_operation, Qnil); specbind (Qload_in_progress, Qt); - struct infile input; - input.stream = stream; - input.lookahead = 0; - infile = &input; - - if (lisp_file_lexically_bound_p (Qget_file_char)) - Fset (Qlexical_binding, Qt); - - if (! version || version >= 22) - readevalloop (Qget_file_char, &input, hist_file_name, - 0, Qnil, Qnil, Qnil, Qnil); + if (is_module) + { +#ifdef HAVE_MODULES + specbind (Qcurrent_load_list, Qnil); + LOADHIST_ATTACH (found); + Fmodule_load (found); + build_load_history (found, true); +#else + /* This cannot happen. */ + emacs_abort (); +#endif + } else { - /* We can't handle a file which was compiled with - byte-compile-dynamic by older version of Emacs. */ - specbind (Qload_force_doc_strings, Qt); - readevalloop (Qget_emacs_mule_file_char, &input, hist_file_name, - 0, Qnil, Qnil, Qnil, Qnil); + struct infile input; + input.stream = stream; + input.lookahead = 0; + infile = &input; + + if (lisp_file_lexically_bound_p (Qget_file_char)) + Fset (Qlexical_binding, Qt); + + if (! version || version >= 22) + readevalloop (Qget_file_char, &input, hist_file_name, + 0, Qnil, Qnil, Qnil, Qnil); + else + { + /* We can't handle a file which was compiled with + byte-compile-dynamic by older version of Emacs. */ + specbind (Qload_force_doc_strings, Qt); + readevalloop (Qget_emacs_mule_file_char, &input, hist_file_name, + 0, Qnil, Qnil, Qnil, Qnil); + } } unbind_to (count, Qnil); @@ -1461,6 +1497,8 @@ Return t if the file exists and loads successfully. */) if (!safe_p) message_with_string ("Loading %s (compiled; note unsafe, not compiled in Emacs)...done", file, 1); + else if (is_module) + message_with_string ("Loading %s (module)...done", file, 1); else if (!compiled) message_with_string ("Loading %s (source)...done", file, 1); else if (newer) @@ -1563,188 +1601,193 @@ openp (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes, absolute = complete_filename_p (str); - for (; CONSP (path); path = XCDR (path)) - { - ptrdiff_t baselen, prefixlen; + /* Go through all entries in the path and see whether we find the + executable. */ + do { + ptrdiff_t baselen, prefixlen; + if (NILP (path)) + filename = str; + else filename = Fexpand_file_name (str, XCAR (path)); - if (!complete_filename_p (filename)) - /* If there are non-absolute elts in PATH (eg "."). */ - /* Of course, this could conceivably lose if luser sets - default-directory to be something non-absolute... */ - { - filename = Fexpand_file_name (filename, BVAR (current_buffer, directory)); - if (!complete_filename_p (filename)) - /* Give up on this path element! */ - continue; - } + if (!complete_filename_p (filename)) + /* If there are non-absolute elts in PATH (eg "."). */ + /* Of course, this could conceivably lose if luser sets + default-directory to be something non-absolute... */ + { + filename = Fexpand_file_name (filename, BVAR (current_buffer, directory)); + if (!complete_filename_p (filename)) + /* Give up on this path element! */ + continue; + } - /* Calculate maximum length of any filename made from - this path element/specified file name and any possible suffix. */ - want_length = max_suffix_len + SBYTES (filename); - if (fn_size <= want_length) - { - fn_size = 100 + want_length; - fn = SAFE_ALLOCA (fn_size); - } + /* Calculate maximum length of any filename made from + this path element/specified file name and any possible suffix. */ + want_length = max_suffix_len + SBYTES (filename); + if (fn_size <= want_length) + { + fn_size = 100 + want_length; + fn = SAFE_ALLOCA (fn_size); + } - /* Copy FILENAME's data to FN but remove starting /: if any. */ - prefixlen = ((SCHARS (filename) > 2 - && SREF (filename, 0) == '/' - && SREF (filename, 1) == ':') - ? 2 : 0); - baselen = SBYTES (filename) - prefixlen; - memcpy (fn, SDATA (filename) + prefixlen, baselen); - - /* Loop over suffixes. */ - for (tail = NILP (suffixes) ? list1 (empty_unibyte_string) : suffixes; - CONSP (tail); tail = XCDR (tail)) - { - Lisp_Object suffix = XCAR (tail); - ptrdiff_t fnlen, lsuffix = SBYTES (suffix); - Lisp_Object handler; - - /* Make complete filename by appending SUFFIX. */ - memcpy (fn + baselen, SDATA (suffix), lsuffix + 1); - fnlen = baselen + lsuffix; - - /* Check that the file exists and is not a directory. */ - /* We used to only check for handlers on non-absolute file names: - if (absolute) - handler = Qnil; - else - handler = Ffind_file_name_handler (filename, Qfile_exists_p); - It's not clear why that was the case and it breaks things like - (load "/bar.el") where the file is actually "/bar.el.gz". */ - /* make_string has its own ideas on when to return a unibyte - string and when a multibyte string, but we know better. - We must have a unibyte string when dumping, since - file-name encoding is shaky at best at that time, and in - particular default-file-name-coding-system is reset - several times during loadup. We therefore don't want to - encode the file before passing it to file I/O library - functions. */ - if (!STRING_MULTIBYTE (filename) && !STRING_MULTIBYTE (suffix)) - string = make_unibyte_string (fn, fnlen); - else - string = make_string (fn, fnlen); - handler = Ffind_file_name_handler (string, Qfile_exists_p); - if ((!NILP (handler) || (!NILP (predicate) && !EQ (predicate, Qt))) - && !NATNUMP (predicate)) - { - bool exists; - if (NILP (predicate) || EQ (predicate, Qt)) - exists = !NILP (Ffile_readable_p (string)); - else - { - Lisp_Object tmp = call1 (predicate, string); - if (NILP (tmp)) + /* Copy FILENAME's data to FN but remove starting /: if any. */ + prefixlen = ((SCHARS (filename) > 2 + && SREF (filename, 0) == '/' + && SREF (filename, 1) == ':') + ? 2 : 0); + baselen = SBYTES (filename) - prefixlen; + memcpy (fn, SDATA (filename) + prefixlen, baselen); + + /* Loop over suffixes. */ + for (tail = NILP (suffixes) ? list1 (empty_unibyte_string) : suffixes; + CONSP (tail); tail = XCDR (tail)) + { + Lisp_Object suffix = XCAR (tail); + ptrdiff_t fnlen, lsuffix = SBYTES (suffix); + Lisp_Object handler; + + /* Make complete filename by appending SUFFIX. */ + memcpy (fn + baselen, SDATA (suffix), lsuffix + 1); + fnlen = baselen + lsuffix; + + /* Check that the file exists and is not a directory. */ + /* We used to only check for handlers on non-absolute file names: + if (absolute) + handler = Qnil; + else + handler = Ffind_file_name_handler (filename, Qfile_exists_p); + It's not clear why that was the case and it breaks things like + (load "/bar.el") where the file is actually "/bar.el.gz". */ + /* make_string has its own ideas on when to return a unibyte + string and when a multibyte string, but we know better. + We must have a unibyte string when dumping, since + file-name encoding is shaky at best at that time, and in + particular default-file-name-coding-system is reset + several times during loadup. We therefore don't want to + encode the file before passing it to file I/O library + functions. */ + if (!STRING_MULTIBYTE (filename) && !STRING_MULTIBYTE (suffix)) + string = make_unibyte_string (fn, fnlen); + else + string = make_string (fn, fnlen); + handler = Ffind_file_name_handler (string, Qfile_exists_p); + if ((!NILP (handler) || (!NILP (predicate) && !EQ (predicate, Qt))) + && !FIXNATP (predicate)) + { + bool exists; + if (NILP (predicate) || EQ (predicate, Qt)) + exists = !NILP (Ffile_readable_p (string)); + else + { + Lisp_Object tmp = call1 (predicate, string); + if (NILP (tmp)) + exists = false; + else if (EQ (tmp, Qdir_ok) + || NILP (Ffile_directory_p (string))) + exists = true; + else + { exists = false; - else if (EQ (tmp, Qdir_ok) - || NILP (Ffile_directory_p (string))) - exists = true; - else - { - exists = false; - last_errno = EISDIR; - } - } + last_errno = EISDIR; + } + } - if (exists) - { - /* We succeeded; return this descriptor and filename. */ - if (storeptr) - *storeptr = string; - SAFE_FREE (); - return -2; - } - } - else - { - int fd; - const char *pfn; - struct stat st; + if (exists) + { + /* We succeeded; return this descriptor and filename. */ + if (storeptr) + *storeptr = string; + SAFE_FREE (); + return -2; + } + } + else + { + int fd; + const char *pfn; + struct stat st; - encoded_fn = ENCODE_FILE (string); - pfn = SSDATA (encoded_fn); + encoded_fn = ENCODE_FILE (string); + pfn = SSDATA (encoded_fn); - /* Check that we can access or open it. */ - if (NATNUMP (predicate)) - { - fd = -1; - if (INT_MAX < XFASTINT (predicate)) - last_errno = EINVAL; - else if (faccessat (AT_FDCWD, pfn, XFASTINT (predicate), - AT_EACCESS) - == 0) - { - if (file_directory_p (pfn)) - last_errno = EISDIR; - else - fd = 1; - } - } - else - { - fd = emacs_open (pfn, O_RDONLY, 0); - if (fd < 0) - { - if (errno != ENOENT) - last_errno = errno; - } - else - { - int err = (fstat (fd, &st) != 0 ? errno - : S_ISDIR (st.st_mode) ? EISDIR : 0); - if (err) - { - last_errno = err; - emacs_close (fd); - fd = -1; - } - } - } + /* Check that we can access or open it. */ + if (FIXNATP (predicate)) + { + fd = -1; + if (INT_MAX < XFIXNAT (predicate)) + last_errno = EINVAL; + else if (faccessat (AT_FDCWD, pfn, XFIXNAT (predicate), + AT_EACCESS) + == 0) + { + if (file_directory_p (encoded_fn)) + last_errno = EISDIR; + else + fd = 1; + } + } + else + { + fd = emacs_open (pfn, O_RDONLY, 0); + if (fd < 0) + { + if (errno != ENOENT) + last_errno = errno; + } + else + { + int err = (fstat (fd, &st) != 0 ? errno + : S_ISDIR (st.st_mode) ? EISDIR : 0); + if (err) + { + last_errno = err; + emacs_close (fd); + fd = -1; + } + } + } - if (fd >= 0) - { - if (newer && !NATNUMP (predicate)) - { - struct timespec mtime = get_stat_mtime (&st); + if (fd >= 0) + { + if (newer && !FIXNATP (predicate)) + { + struct timespec mtime = get_stat_mtime (&st); - if (timespec_cmp (mtime, save_mtime) <= 0) - emacs_close (fd); - else - { - if (0 <= save_fd) - emacs_close (save_fd); - save_fd = fd; - save_mtime = mtime; - save_string = string; - } - } - else - { - /* We succeeded; return this descriptor and filename. */ - if (storeptr) - *storeptr = string; - SAFE_FREE (); - return fd; - } - } + if (timespec_cmp (mtime, save_mtime) <= 0) + emacs_close (fd); + else + { + if (0 <= save_fd) + emacs_close (save_fd); + save_fd = fd; + save_mtime = mtime; + save_string = string; + } + } + else + { + /* We succeeded; return this descriptor and filename. */ + if (storeptr) + *storeptr = string; + SAFE_FREE (); + return fd; + } + } - /* No more suffixes. Return the newest. */ - if (0 <= save_fd && ! CONSP (XCDR (tail))) - { - if (storeptr) - *storeptr = save_string; - SAFE_FREE (); - return save_fd; - } - } - } - if (absolute) - break; - } + /* No more suffixes. Return the newest. */ + if (0 <= save_fd && ! CONSP (XCDR (tail))) + { + if (storeptr) + *storeptr = save_string; + SAFE_FREE (); + return save_fd; + } + } + } + if (absolute || NILP (path)) + break; + path = XCDR (path); + } while (CONSP (path)); SAFE_FREE (); errno = last_errno; @@ -1945,11 +1988,11 @@ readevalloop (Lisp_Object readcharfun, if (!NILP (start)) { /* Switch to the buffer we are reading from. */ - record_unwind_protect (save_excursion_restore, save_excursion_save ()); + record_unwind_protect_excursion (); set_buffer_internal (b); /* Save point in it. */ - record_unwind_protect (save_excursion_restore, save_excursion_save ()); + record_unwind_protect_excursion (); /* Save ZV in it. */ record_unwind_protect (save_restriction_restore, save_restriction_save ()); /* Those get unbound after we read one expression. */ @@ -1957,11 +2000,11 @@ readevalloop (Lisp_Object readcharfun, /* Set point and ZV around stuff to be read. */ Fgoto_char (start); if (!NILP (end)) - Fnarrow_to_region (make_number (BEGV), end); + Fnarrow_to_region (make_fixnum (BEGV), end); /* Just for cleanliness, convert END to a marker if it is an integer. */ - if (INTEGERP (end)) + if (FIXNUMP (end)) end = Fpoint_max_marker (); } @@ -2106,15 +2149,13 @@ This function preserves the position of point. */) specbind (Qeval_buffer_list, Fcons (buf, Veval_buffer_list)); specbind (Qstandard_output, tem); - record_unwind_protect (save_excursion_restore, save_excursion_save ()); + record_unwind_protect_excursion (); BUF_TEMP_SET_PT (XBUFFER (buf), BUF_BEGV (XBUFFER (buf))); specbind (Qlexical_binding, lisp_file_lexically_bound_p (buf) ? Qt : Qnil); BUF_TEMP_SET_PT (XBUFFER (buf), BUF_BEGV (XBUFFER (buf))); readevalloop (buf, 0, filename, !NILP (printflag), unibyte, Qnil, Qnil, Qnil); - unbind_to (count, Qnil); - - return Qnil; + return unbind_to (count, Qnil); } DEFUN ("eval-region", Feval_region, Seval_region, 2, 4, "r", @@ -2193,7 +2234,7 @@ the end of STRING. */) CHECK_STRING (string); /* `read_internal_start' sets `read_from_string_index'. */ ret = read_internal_start (string, start, end); - return Fcons (ret, make_number (read_from_string_index)); + return Fcons (ret, make_fixnum (read_from_string_index)); } /* Function to set up the global context we need in toplevel read @@ -2204,7 +2245,7 @@ read_internal_start (Lisp_Object stream, Lisp_Object start, Lisp_Object end) Lisp_Object retval; readchar_count = 0; - new_backquote_flag = 0; + new_backquote_flag = force_new_style_backquotes; /* We can get called from readevalloop which may have set these already. */ if (! HASH_TABLE_P (read_objects_map) @@ -2279,7 +2320,7 @@ read0 (Lisp_Object readcharfun) return val; xsignal1 (Qinvalid_read_syntax, - Fmake_string (make_number (1), make_number (c))); + Fmake_string (make_fixnum (1), make_fixnum (c), Qnil)); } /* Grow a read buffer BUF that contains OFFSET useful bytes of data, @@ -2313,20 +2354,22 @@ character_name_to_code (char const *name, ptrdiff_t name_len) { /* For "U+XXXX", pass the leading '+' to string_to_number to reject monstrosities like "U+-0000". */ + ptrdiff_t len = name_len - 1; Lisp_Object code = (name[0] == 'U' && name[1] == '+' - ? string_to_number (name + 1, 16, false) + ? string_to_number (name + 1, 16, &len) : call2 (Qchar_from_name, make_unibyte_string (name, name_len), Qt)); - if (! RANGED_INTEGERP (0, code, MAX_UNICODE_CHAR) - || char_surrogate_p (XINT (code))) + if (! RANGED_FIXNUMP (0, code, MAX_UNICODE_CHAR) + || len != name_len - 1 + || char_surrogate_p (XFIXNUM (code))) { AUTO_STRING (format, "\\N{%s}"); AUTO_STRING_WITH_LEN (namestr, name, name_len); xsignal1 (Qinvalid_read_syntax, CALLN (Fformat, format, namestr)); } - return XINT (code); + return XFIXNUM (code); } /* Bound on the length of a Unicode character name. As of @@ -2550,7 +2593,7 @@ read_escape (Lisp_Object readcharfun, bool stringp) AUTO_STRING (format, "Invalid character U+%04X in character name"); xsignal1 (Qinvalid_read_syntax, - CALLN (Fformat, format, make_natnum (c))); + CALLN (Fformat, format, make_fixed_natnum (c))); } /* Treat multiple adjacent whitespace characters as a single space character. This makes it easier to use @@ -2602,6 +2645,13 @@ digit_to_number (int character, int base) return digit < base ? digit : -1; } +static void +free_contents (void *p) +{ + void **ptr = (void **) p; + xfree (*ptr); +} + /* Read an integer in radix RADIX using READCHARFUN to read characters. RADIX must be in the interval [2..36]; if it isn't, a read error is signaled . Value is the integer read. Signals an @@ -2613,18 +2663,24 @@ read_integer (Lisp_Object readcharfun, EMACS_INT radix) { /* Room for sign, leading 0, other digits, trailing null byte. Also, room for invalid syntax diagnostic. */ - char buf[max (1 + 1 + UINTMAX_WIDTH + 1, - sizeof "integer, radix " + INT_STRLEN_BOUND (EMACS_INT))]; - + size_t len = max (1 + 1 + UINTMAX_WIDTH + 1, + sizeof "integer, radix " + INT_STRLEN_BOUND (EMACS_INT)); + char *buf = NULL; + char *p = buf; int valid = -1; /* 1 if valid, 0 if not, -1 if incomplete. */ + ptrdiff_t count = SPECPDL_INDEX (); + if (radix < 2 || radix > 36) valid = 0; else { - char *p = buf; int c, digit; + buf = xmalloc (len); + record_unwind_protect_ptr (free_contents, &buf); + p = buf; + c = READCHAR; if (c == '-' || c == '+') { @@ -2650,17 +2706,19 @@ read_integer (Lisp_Object readcharfun, EMACS_INT radix) valid = 0; if (valid < 0) valid = 1; - - if (p < buf + sizeof buf - 1) - *p++ = c; - else - valid = 0; - + /* Allow 1 extra byte for the \0. */ + if (p + 1 == buf + len) + { + ptrdiff_t where = p - buf; + len *= 2; + buf = xrealloc (buf, len); + p = buf + where; + } + *p++ = c; c = READCHAR; } UNREAD (c); - *p = '\0'; } if (valid != 1) @@ -2669,7 +2727,8 @@ read_integer (Lisp_Object readcharfun, EMACS_INT radix) invalid_syntax (buf); } - return string_to_number (buf, radix, 0); + *p = '\0'; + return unbind_to (count, string_to_number (buf, radix, 0)); } @@ -2734,9 +2793,9 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) if (!EQ (head, Qhash_table)) { - ptrdiff_t size = XINT (Flength (tmp)); + ptrdiff_t size = XFIXNUM (Flength (tmp)); Lisp_Object record = Fmake_record (CAR_SAFE (tmp), - make_number (size - 1), + make_fixnum (size - 1), Qnil); for (int i = 1; i < size; i++) { @@ -2821,24 +2880,24 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) /* Sub char-table can't be read as a regular vector because of a two C integer fields. */ Lisp_Object tbl, tmp = read_list (1, readcharfun); - ptrdiff_t size = XINT (Flength (tmp)); + ptrdiff_t size = XFIXNUM (Flength (tmp)); int i, depth, min_char; struct Lisp_Cons *cell; if (size == 0) error ("Zero-sized sub char-table"); - if (! RANGED_INTEGERP (1, XCAR (tmp), 3)) + if (! RANGED_FIXNUMP (1, XCAR (tmp), 3)) error ("Invalid depth in sub char-table"); - depth = XINT (XCAR (tmp)); + depth = XFIXNUM (XCAR (tmp)); if (chartab_size[depth] != size - 2) error ("Invalid size in sub char-table"); cell = XCONS (tmp), tmp = XCDR (tmp), size--; free_cons (cell); - if (! RANGED_INTEGERP (0, XCAR (tmp), MAX_CHAR)) + if (! RANGED_FIXNUMP (0, XCAR (tmp), MAX_CHAR)) error ("Invalid minimum character in sub-char-table"); - min_char = XINT (XCAR (tmp)); + min_char = XFIXNUM (XCAR (tmp)); cell = XCONS (tmp), tmp = XCDR (tmp), size--; free_cons (cell); @@ -2863,7 +2922,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) if (c == '"') { Lisp_Object tmp, val; - EMACS_INT size_in_chars = bool_vector_bytes (XFASTINT (length)); + EMACS_INT size_in_chars = bool_vector_bytes (XFIXNAT (length)); unsigned char *data; UNREAD (c); @@ -2874,17 +2933,17 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) when the number of bits was a multiple of 8. Accept such input in case it came from an old version. */ - && ! (XFASTINT (length) + && ! (XFIXNAT (length) == (SCHARS (tmp) - 1) * BOOL_VECTOR_BITS_PER_CHAR))) invalid_syntax ("#&..."); - val = make_uninit_bool_vector (XFASTINT (length)); + val = make_uninit_bool_vector (XFIXNAT (length)); data = bool_vector_uchar_data (val); memcpy (data, SDATA (tmp), size_in_chars); /* Clear the extraneous bits in the last byte. */ - if (XINT (length) != size_in_chars * BOOL_VECTOR_BITS_PER_CHAR) + if (XFIXNUM (length) != size_in_chars * BOOL_VECTOR_BITS_PER_CHAR) data[size_in_chars - 1] - &= (1 << (XINT (length) % BOOL_VECTOR_BITS_PER_CHAR)) - 1; + &= (1 << (XFIXNUM (length) % BOOL_VECTOR_BITS_PER_CHAR)) - 1; return val; } invalid_syntax ("#&..."); @@ -3097,7 +3156,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) struct Lisp_Hash_Table *h = XHASH_TABLE (read_objects_map); EMACS_UINT hash; - Lisp_Object number = make_number (n); + Lisp_Object number = make_fixnum (n); ptrdiff_t i = hash_lookup (h, number, &hash); if (i >= 0) @@ -3148,7 +3207,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) { struct Lisp_Hash_Table *h = XHASH_TABLE (read_objects_map); - ptrdiff_t i = hash_lookup (h, make_number (n), NULL); + ptrdiff_t i = hash_lookup (h, make_fixnum (n), NULL); if (i >= 0) return HASH_VALUE (h, i); } @@ -3188,10 +3247,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) first_in_list exception (old-style can still be obtained via "(\`" anyway). */ if (!new_backquote_flag && first_in_list && next_char == ' ') - { - Vlread_old_style_backquotes = Qt; - goto default_label; - } + load_error_old_style_backquotes (); else { Lisp_Object value; @@ -3242,10 +3298,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) return list2 (comma_type, value); } else - { - Vlread_old_style_backquotes = Qt; - goto default_label; - } + load_error_old_style_backquotes (); } case '?': { @@ -3262,13 +3315,13 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) Other literal whitespace like NL, CR, and FF are not accepted, as there are well-established escape sequences for these. */ if (c == ' ' || c == '\t') - return make_number (c); + return make_fixnum (c); if (c == '(' || c == ')' || c == '[' || c == ']' || c == '"' || c == ';') { CHECK_LIST (Vlread_unescaped_character_literals); - Lisp_Object char_obj = make_natnum (c); + Lisp_Object char_obj = make_fixed_natnum (c); if (NILP (Fmemq (char_obj, Vlread_unescaped_character_literals))) Vlread_unescaped_character_literals = Fcons (char_obj, Vlread_unescaped_character_literals); @@ -3288,7 +3341,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) && strchr ("\"';()[]#?`,.", next_char) != NULL)); UNREAD (next_char); if (ok) - return make_number (c); + return make_fixnum (c); invalid_syntax ("?"); } @@ -3397,7 +3450,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) return zero instead. This is for doc strings that we are really going to find in etc/DOC.nn.nn. */ if (!NILP (Vpurify_flag) && NILP (Vdoc_file_name) && cancel) - return unbind_to (count, make_number (0)); + return unbind_to (count, make_fixnum (0)); if (! force_multibyte && force_singlebyte) { @@ -3433,7 +3486,6 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) row. */ FALLTHROUGH; default: - default_label: if (c <= 040) goto retry; if (c == NO_BREAK_SPACE) goto retry; @@ -3481,17 +3533,25 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) || strchr ("\"';()[]#`,", c) == NULL)); *p = 0; + ptrdiff_t nbytes = p - read_buffer; UNREAD (c); if (!quoted && !uninterned_symbol) { - Lisp_Object result = string_to_number (read_buffer, 10, 0); - if (! NILP (result)) + ptrdiff_t len; + Lisp_Object result = string_to_number (read_buffer, 10, &len); + if (! NILP (result) && len == nbytes) return unbind_to (count, result); } + if (!quoted && multibyte) + { + int ch = STRING_CHAR ((unsigned char *) read_buffer); + if (confusable_symbol_character_p (ch)) + xsignal2 (Qinvalid_read_syntax, build_string ("strange quote"), + CALLN (Fstring, make_fixnum (ch))); + } { Lisp_Object result; - ptrdiff_t nbytes = p - read_buffer; ptrdiff_t nchars = (multibyte ? multibyte_chars_in_text ((unsigned char *) read_buffer, @@ -3530,7 +3590,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) if (EQ (Vread_with_symbol_positions, Qt) || EQ (Vread_with_symbol_positions, readcharfun)) Vread_symbol_positions_list - = Fcons (Fcons (result, make_number (start_position)), + = Fcons (Fcons (result, make_fixnum (start_position)), Vread_symbol_positions_list); return unbind_to (count, result); } @@ -3571,7 +3631,7 @@ substitute_object_recurse (struct subst *subst, Lisp_Object subtree) return subtree; /* If we've been to this node before, don't explore it again. */ - if (!EQ (Qnil, Fmemq (subtree, subst->seen))) + if (!NILP (Fmemq (subtree, subst->seen))) return subtree; /* If this node can be the entry point to a cycle, remember that @@ -3643,27 +3703,27 @@ substitute_in_interval (INTERVAL interval, void *arg) } -/* Convert STRING to a number, assuming base BASE. Return a fixnum if - STRING has integer syntax and fits in a fixnum, else return the - nearest float if STRING has either floating point or integer syntax - and BASE is 10, else return nil. If IGNORE_TRAILING, consider just - the longest prefix of STRING that has valid floating point syntax. - Signal an overflow if BASE is not 10 and the number has integer - syntax but does not fit. */ +/* Convert the initial prefix of STRING to a number, assuming base BASE. + If the prefix has floating point syntax and BASE is 10, return a + nearest float; otherwise, if the prefix has integer syntax, return + the integer; otherwise, return nil. If PLEN, set *PLEN to the + length of the numeric prefix if there is one, otherwise *PLEN is + unspecified. */ Lisp_Object -string_to_number (char const *string, int base, bool ignore_trailing) +string_to_number (char const *string, int base, ptrdiff_t *plen) { char const *cp = string; - bool float_syntax = 0; + bool float_syntax = false; double value = 0; /* Negate the value ourselves. This treats 0, NaNs, and infinity properly on IEEE floating point hosts, and works around a formerly-common bug where atof ("-0.0") drops the sign. */ bool negative = *cp == '-'; + bool positive = *cp == '+'; - bool signedp = negative || *cp == '+'; + bool signedp = negative | positive; cp += signedp; enum { INTOVERFLOW = 1, LEAD_INT = 2, DOT_CHAR = 4, TRAIL_INT = 8, @@ -3684,6 +3744,7 @@ string_to_number (char const *string, int base, bool ignore_trailing) n += digit; } } + char const *after_digits = cp; if (*cp == '.') { state |= DOT_CHAR; @@ -3712,6 +3773,7 @@ string_to_number (char const *string, int base, bool ignore_trailing) cp++; while ('0' <= *cp && *cp <= '9'); } +#if IEEE_FLOATING_POINT else if (cp[-1] == '+' && cp[0] == 'I' && cp[1] == 'N' && cp[2] == 'F') { @@ -3724,9 +3786,12 @@ string_to_number (char const *string, int base, bool ignore_trailing) { state |= E_EXP; cp += 3; - /* NAN is a "positive" NaN on all known Emacs hosts. */ - value = NAN; + union ieee754_double u + = { .ieee_nan = { .exponent = -1, .quiet_nan = 1, + .mantissa0 = n >> 31 >> 1, .mantissa1 = n }}; + value = u.d; } +#endif else cp = ecp; } @@ -3735,63 +3800,63 @@ string_to_number (char const *string, int base, bool ignore_trailing) || (state & ~INTOVERFLOW) == (LEAD_INT|E_EXP)); } - /* Return nil if the number uses invalid syntax. If IGNORE_TRAILING, accept - any prefix that matches. Otherwise, the entire string must match. */ - if (! (ignore_trailing - ? ((state & LEAD_INT) != 0 || float_syntax) - : (!*cp && ((state & ~(INTOVERFLOW | DOT_CHAR)) == LEAD_INT - || float_syntax)))) - return Qnil; + if (plen) + *plen = cp - string; - /* If the number uses integer and not float syntax, and is in C-language - range, use its value, preferably as a fixnum. */ - if (leading_digit >= 0 && ! float_syntax) + /* Return a float if the number uses float syntax. */ + if (float_syntax) { - if (state & INTOVERFLOW) - { - /* Unfortunately there's no simple and accurate way to convert - non-base-10 numbers that are out of C-language range. */ - if (base != 10) - xsignal1 (Qoverflow_error, build_string (string)); - } - else if (n <= (negative ? -MOST_NEGATIVE_FIXNUM : MOST_POSITIVE_FIXNUM)) - { - EMACS_INT signed_n = n; - return make_number (negative ? -signed_n : signed_n); - } - else - value = n; + /* Convert to floating point, unless the value is already known + because it is infinite or a NaN. */ + if (! value) + value = atof (string + signedp); + return make_float (negative ? -value : value); } - /* Either the number uses float syntax, or it does not fit into a fixnum. - Convert it from string to floating point, unless the value is already - known because it is an infinity, a NAN, or its absolute value fits in - uintmax_t. */ - if (! value) - value = atof (string + signedp); + /* Return nil if the number uses invalid syntax. */ + if (! (state & LEAD_INT)) + return Qnil; + + /* Fast path if the integer (san sign) fits in uintmax_t. */ + if (! (state & INTOVERFLOW)) + { + if (!negative) + return make_uint (n); + if (-MOST_NEGATIVE_FIXNUM < n) + return make_neg_biguint (n); + EMACS_INT signed_n = n; + return make_fixnum (-signed_n); + } - return make_float (negative ? -value : value); + /* Trim any leading "+" and trailing nondigits, then return a bignum. */ + string += positive; + if (!*after_digits) + return make_bignum_str (string, base); + ptrdiff_t trimmed_len = after_digits - string; + USE_SAFE_ALLOCA; + char *trimmed = SAFE_ALLOCA (trimmed_len + 1); + memcpy (trimmed, string, trimmed_len); + trimmed[trimmed_len] = '\0'; + Lisp_Object result = make_bignum_str (trimmed, base); + SAFE_FREE (); + return result; } static Lisp_Object read_vector (Lisp_Object readcharfun, bool bytecodeflag) { - ptrdiff_t i, size; - Lisp_Object *ptr; - Lisp_Object tem, item, vector; - struct Lisp_Cons *otem; - Lisp_Object len; - - tem = read_list (1, readcharfun); - len = Flength (tem); - vector = Fmake_vector (len, Qnil); - - size = ASIZE (vector); - ptr = XVECTOR (vector)->contents; - for (i = 0; i < size; i++) + Lisp_Object tem = read_list (1, readcharfun); + Lisp_Object len = Flength (tem); + ptrdiff_t size = XFIXNAT (len); + if (bytecodeflag && size <= COMPILED_STACK_DEPTH) + error ("Invalid byte code"); + Lisp_Object vector = make_nil_vector (size); + + Lisp_Object *ptr = XVECTOR (vector)->contents; + for (ptrdiff_t i = 0; i < size; i++) { - item = Fcar (tem); + Lisp_Object item = Fcar (tem); /* If `load-force-doc-strings' is t when reading a lazily-loaded bytecode object, the docstring containing the bytecode and constants values must be treated as unibyte and passed to @@ -3825,7 +3890,7 @@ read_vector (Lisp_Object readcharfun, bool bytecodeflag) if (!CONSP (item)) error ("Invalid byte code"); - otem = XCONS (item); + struct Lisp_Cons *otem = XCONS (item); bytestr = XCAR (item); item = XCDR (item); free_cons (otem); @@ -3845,7 +3910,7 @@ read_vector (Lisp_Object readcharfun, bool bytecodeflag) } } ASET (vector, i, item); - otem = XCONS (tem); + struct Lisp_Cons *otem = XCONS (tem); tem = Fcdr (tem); free_cons (otem); } @@ -3925,8 +3990,8 @@ read_list (bool flag, Lisp_Object readcharfun) if (ch == ')') { if (doc_reference == 1) - return make_number (0); - if (doc_reference == 2 && INTEGERP (XCDR (val))) + return make_fixnum (0); + if (doc_reference == 2 && FIXNUMP (XCDR (val))) { char *saved = NULL; file_offset saved_position; @@ -3941,7 +4006,7 @@ read_list (bool flag, Lisp_Object readcharfun) multibyte. */ /* Position is negative for user variables. */ - EMACS_INT pos = eabs (XINT (XCDR (val))); + EMACS_INT pos = eabs (XFIXNUM (XCDR (val))); if (pos >= saved_doc_string_position && pos < (saved_doc_string_position + saved_doc_string_length)) @@ -4046,7 +4111,7 @@ intern_sym (Lisp_Object sym, Lisp_Object obarray, Lisp_Object index) SET_SYMBOL_VAL (XSYMBOL (sym), sym); } - ptr = aref_addr (obarray, XINT (index)); + ptr = aref_addr (obarray, XFIXNUM (index)); set_symbol_next (sym, SYMBOLP (*ptr) ? XSYMBOL (*ptr) : NULL); *ptr = sym; return sym; @@ -4104,7 +4169,7 @@ define_symbol (Lisp_Object sym, char const *str) if (! EQ (sym, Qunbound)) { Lisp_Object bucket = oblookup (initial_obarray, str, len, len); - eassert (INTEGERP (bucket)); + eassert (FIXNUMP (bucket)); intern_sym (sym, initial_obarray, bucket); } } @@ -4150,7 +4215,7 @@ it defaults to the value of `obarray'. */) string = SYMBOL_NAME (name); tem = oblookup (obarray, SSDATA (string), SCHARS (string), SBYTES (string)); - if (INTEGERP (tem) || (SYMBOLP (name) && !EQ (name, tem))) + if (FIXNUMP (tem) || (SYMBOLP (name) && !EQ (name, tem))) return Qnil; else return tem; @@ -4182,7 +4247,7 @@ usage: (unintern NAME OBARRAY) */) tem = oblookup (obarray, SSDATA (string), SCHARS (string), SBYTES (string)); - if (INTEGERP (tem)) + if (FIXNUMP (tem)) return Qnil; /* If arg was a symbol, don't delete anything but that symbol itself. */ if (SYMBOLP (name) && !EQ (name, tem)) @@ -4192,7 +4257,7 @@ usage: (unintern NAME OBARRAY) */) 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)) + /* if (NILP (tem) || EQ (tem, Qt)) error ("Attempt to unintern t or nil"); */ XSYMBOL (tem)->u.s.interned = SYMBOL_UNINTERNED; @@ -4208,7 +4273,7 @@ usage: (unintern NAME OBARRAY) */) ASET (obarray, hash, sym); } else - ASET (obarray, hash, make_number (0)); + ASET (obarray, hash, make_fixnum (0)); } else { @@ -4251,7 +4316,7 @@ oblookup (Lisp_Object obarray, register const char *ptr, ptrdiff_t size, ptrdiff hash = hash_string (ptr, size_byte) % obsize; bucket = AREF (obarray, hash); oblookup_last_bucket_number = hash; - if (EQ (bucket, make_number (0))) + if (EQ (bucket, make_fixnum (0))) ; else if (!SYMBOLP (bucket)) error ("Bad data in guts of obarray"); /* Like CADR error message. */ @@ -4312,7 +4377,7 @@ OBARRAY defaults to the value of `obarray'. */) void init_obarray (void) { - Vobarray = Fmake_vector (make_number (OBARRAY_SIZE), make_number (0)); + Vobarray = make_vector (OBARRAY_SIZE, make_fixnum (0)); initial_obarray = Vobarray; staticpro (&initial_obarray); @@ -4338,8 +4403,9 @@ init_obarray (void) } void -defsubr (struct Lisp_Subr *sname) +defsubr (union Aligned_Lisp_Subr *aname) { + struct Lisp_Subr *sname = &aname->s; Lisp_Object sym, tem; sym = intern_c_string (sname->symbol_name); XSETPVECTYPE (sname, PVEC_SUBR); @@ -4898,7 +4964,7 @@ directory. These file names are converted to absolute at startup. */); If the file loaded had extension `.elc', and the corresponding source file exists, this variable contains the name of source file, suitable for use by functions like `custom-save-all' which edit the init file. -While Emacs loads and evaluates the init file, value is the real name +While Emacs loads and evaluates any init file, value is the real name of the file, regardless of whether or not it has the `.elc' extension. */); Vuser_init_file = Qnil; @@ -4988,12 +5054,6 @@ variables, this must be set in the first line of a file. */); doc: /* List of buffers being read from by calls to `eval-buffer' and `eval-region'. */); Veval_buffer_list = Qnil; - DEFVAR_LISP ("lread--old-style-backquotes", Vlread_old_style_backquotes, - doc: /* Set to non-nil when `read' encounters an old-style backquote. -For internal use only. */); - Vlread_old_style_backquotes = Qnil; - DEFSYM (Qlread_old_style_backquotes, "lread--old-style-backquotes"); - DEFVAR_LISP ("lread--unescaped-character-literals", Vlread_unescaped_character_literals, doc: /* List of deprecated unescaped character literals encountered by `read'. @@ -5018,6 +5078,17 @@ Note that if you customize this, obviously it will not affect files that are loaded before your customizations are read! */); load_prefer_newer = 0; + DEFVAR_BOOL ("force-new-style-backquotes", force_new_style_backquotes, + doc: /* Non-nil means to always use the current syntax for backquotes. +If nil, `load' and `read' raise errors when encountering some +old-style variants of backquote and comma. If non-nil, these +constructs are always interpreted as described in the Info node +`(elisp)Backquotes', even if that interpretation is incompatible with +previous versions of Emacs. Setting this variable to non-nil makes +Emacs compatible with the behavior planned for Emacs 28. In Emacs 28, +this variable will become obsolete. */); + force_new_style_backquotes = false; + /* Vsource_directory was initialized in init_lread. */ DEFSYM (Qcurrent_load_list, "current-load-list"); |