X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/67868d27f8e748264af2214fc001dab826d78ccc..b38a3aa6638889ec772a0e26083e570f051a6cab:/src/lread.c diff --git a/src/lread.c b/src/lread.c index 186b890fae..46fe6cd3e5 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1,5 +1,5 @@ /* Lisp parsing and input streams. - Copyright (C) 1985, 86, 87, 88, 89, 93, 94, 95, 97, 98, 99, 2000, 2001 + Copyright (C) 1985,86,87,88,89,93,94,95,97,98,99,2000,01,03,2004 Free Software Foundation, Inc. This file is part of GNU Emacs. @@ -33,7 +33,9 @@ Boston, MA 02111-1307, USA. */ #include #include "commands.h" #include "keyboard.h" +#include "frame.h" #include "termhooks.h" +#include "coding.h" #ifdef lint #include @@ -60,6 +62,9 @@ Boston, MA 02111-1307, USA. */ #include #endif /* HAVE_SETLOCALE */ +#ifdef HAVE_FCNTL_H +#include +#endif #ifndef O_RDONLY #define O_RDONLY 0 #endif @@ -132,6 +137,13 @@ Lisp_Object Vload_source_file_function; /* List of all DEFVAR_BOOL variables. Used by the byte optimizer. */ Lisp_Object Vbyte_boolean_vars; +/* Whether or not to add a `read-positions' property to symbols + read. */ +Lisp_Object Vread_with_symbol_positions; + +/* List of (SYMBOL . POSITION) accumulated so far. */ +Lisp_Object Vread_symbol_positions_list; + /* List of descriptors now open for Fload. */ static Lisp_Object load_descriptor_list; @@ -149,6 +161,9 @@ static int read_from_string_limit; /* Number of bytes left to read in the buffer character that `readchar' has already advanced over. */ static int readchar_backlog; +/* Number of characters read in the current call to Fread or + Fread_from_string. */ +static int readchar_count; /* This contains the last string skipped with #@. */ static char *saved_doc_string; @@ -190,7 +205,7 @@ int load_dangerous_libraries; static Lisp_Object Vbytecomp_version_regexp; static void to_multibyte P_ ((char **, char **, int *)); -static void readevalloop P_ ((Lisp_Object, FILE*, Lisp_Object, +static void readevalloop P_ ((Lisp_Object, FILE*, Lisp_Object, Lisp_Object (*) (), int, Lisp_Object, Lisp_Object)); static Lisp_Object load_unwind P_ ((Lisp_Object)); @@ -201,8 +216,14 @@ static Lisp_Object load_descriptor_unwind P_ ((Lisp_Object)); Write READCHAR to read a character, UNREAD(c) to unread c to be read again. - These macros actually read/unread a byte code, multibyte characters - are not handled here. The caller should manage them if necessary. + The READCHAR and UNREAD macros are meant for reading/unreading a + byte code; they do not handle multibyte characters. The caller + should manage them if necessary. + + [ Actually that seems to be a lie; READCHAR will definitely read + multibyte characters from buffer sources, at least. Is the + comment just out of date? + -- Colin Walters , 22 May 2002 16:36:50 -0400 ] */ #define READCHAR readchar (readcharfun) @@ -215,6 +236,8 @@ readchar (readcharfun) Lisp_Object tem; register int c; + readchar_count++; + if (BUFFERP (readcharfun)) { register struct buffer *inbuffer = XBUFFER (readcharfun); @@ -334,6 +357,7 @@ unreadchar (readcharfun, c) Lisp_Object readcharfun; int c; { + readchar_count--; if (c == -1) /* Don't back up the pointer if we're unreading the end-of-input mark, since readchar didn't advance it when we read it. */ @@ -388,10 +412,20 @@ unreadchar (readcharfun, c) call1 (readcharfun, make_number (c)); } -static Lisp_Object read0 (), read1 (), read_list (), read_vector (); -static int read_multibyte (); -static Lisp_Object substitute_object_recurse (); -static void substitute_object_in_subtree (), substitute_in_interval (); +static Lisp_Object read_internal_start P_ ((Lisp_Object, Lisp_Object, + Lisp_Object)); +static Lisp_Object read0 P_ ((Lisp_Object)); +static Lisp_Object read1 P_ ((Lisp_Object, int *, int)); + +static Lisp_Object read_list P_ ((int, Lisp_Object)); +static Lisp_Object read_vector P_ ((Lisp_Object, int)); +static int read_multibyte P_ ((int, Lisp_Object)); + +static Lisp_Object substitute_object_recurse P_ ((Lisp_Object, Lisp_Object, + Lisp_Object)); +static void substitute_object_in_subtree P_ ((Lisp_Object, + Lisp_Object)); +static void substitute_in_interval P_ ((INTERVAL, Lisp_Object)); /* Get a character from the tty. */ @@ -427,7 +461,7 @@ read_filtered_event (no_switch_frame, ascii_required, error_nonascii, if (display_hourglass_p) cancel_hourglass (); #endif - + delayed_switch_frame = Qnil; /* Read until we get an acceptable event. */ @@ -468,7 +502,7 @@ read_filtered_event (no_switch_frame, ascii_required, error_nonascii, XSETFASTINT (val, XINT (tem1) | XINT (Fcar (Fcdr (tem)))); } } - + /* If we don't have a character now, deal with it appropriately. */ if (!INTEGERP (val)) { @@ -607,11 +641,20 @@ record_load_unwind (old) return Vloads_in_progress = old; } +/* This handler function is used via internal_condition_case_1. */ + +static Lisp_Object +load_error_handler (data) + Lisp_Object data; +{ + return Qnil; +} DEFUN ("load", Fload, Sload, 1, 5, 0, doc: /* Execute a file of Lisp code named FILE. First try FILE with `.elc' appended, then try with `.el', - then try FILE unmodified. Environment variable references in FILE + then try FILE unmodified (the exact suffixes are determined by +`load-suffixes'). Environment variable references in FILE are replaced with their values by calling `substitute-in-file-name'. This function searches the directories in `load-path'. If optional second arg NOERROR is non-nil, @@ -630,10 +673,10 @@ Return t if file exists. */) register FILE *stream; register int fd = -1; register Lisp_Object lispstream; - int count = specpdl_ptr - specpdl; + int count = SPECPDL_INDEX (); Lisp_Object temp; struct gcpro gcpro1; - Lisp_Object found; + Lisp_Object found, efound; /* 1 means we printed the ".el is newer" message. */ int newer = 0; /* 1 means we are loading a compiled file. */ @@ -661,13 +704,22 @@ Return t if file exists. */) everywhere, it accidentally stayed here. Since then, enough people supposedly have things like (load "$PROJECT/foo.el") in their .emacs that it seemed risky to remove. */ - file = Fsubstitute_in_file_name (file); + if (! NILP (noerror)) + { + file = internal_condition_case_1 (Fsubstitute_in_file_name, file, + Qt, load_error_handler); + if (NILP (file)) + return Qnil; + } + else + file = Fsubstitute_in_file_name (file); + /* Avoid weird lossage with null string as arg, since it would try to load a directory as a Lisp file */ - if (XSTRING (file)->size > 0) + if (SCHARS (file) > 0) { - int size = STRING_BYTES (XSTRING (file)); + int size = SBYTES (file); Lisp_Object tmp[2]; GCPRO1 (file); @@ -676,10 +728,10 @@ Return t if file exists. */) { /* Don't insist on adding a suffix if FILE already ends with one. */ if (size > 3 - && !strcmp (XSTRING (file)->data + size - 3, ".el")) + && !strcmp (SDATA (file) + size - 3, ".el")) must_suffix = Qnil; else if (size > 4 - && !strcmp (XSTRING (file)->data + size - 4, ".elc")) + && !strcmp (SDATA (file) + size - 4, ".elc")) must_suffix = Qnil; /* Don't insist on adding a suffix if the argument includes a directory name. */ @@ -693,16 +745,15 @@ Return t if file exists. */) : Fappend (2, (tmp[0] = Vload_suffixes, tmp[1] = default_suffixes, tmp))), - &found, 0); + &found, Qnil); UNGCPRO; } if (fd == -1) { if (NILP (noerror)) - while (1) - Fsignal (Qfile_error, Fcons (build_string ("Cannot open load file"), - Fcons (file, Qnil))); + Fsignal (Qfile_error, Fcons (build_string ("Cannot open load file"), + Fcons (file, Qnil))); else return Qnil; } @@ -748,7 +799,7 @@ Return t if file exists. */) Vloads_in_progress = Fcons (found, Vloads_in_progress); } - if (!bcmp (&(XSTRING (found)->data[STRING_BYTES (XSTRING (found)) - 4]), + if (!bcmp (SDATA (found) + SBYTES (found) - 4, ".elc", 4)) /* Load .elc files directly, but not when they are remote and have no handler! */ @@ -762,31 +813,44 @@ Return t if file exists. */) { safe_p = 0; if (!load_dangerous_libraries) - error ("File `%s' was not compiled in Emacs", - XSTRING (found)->data); + { + if (fd >= 0) + emacs_close (fd); + error ("File `%s' was not compiled in Emacs", + SDATA (found)); + } else if (!NILP (nomessage)) message_with_string ("File `%s' not compiled in Emacs", found, 1); } compiled = 1; + GCPRO1 (efound); + efound = ENCODE_FILE (found); + #ifdef DOS_NT fmode = "rb"; #endif /* DOS_NT */ - stat ((char *)XSTRING (found)->data, &s1); - XSTRING (found)->data[STRING_BYTES (XSTRING (found)) - 1] = 0; - result = stat ((char *)XSTRING (found)->data, &s2); + stat ((char *)SDATA (efound), &s1); + SSET (efound, SBYTES (efound) - 1, 0); + result = stat ((char *)SDATA (efound), &s2); + SSET (efound, SBYTES (efound) - 1, 'c'); + UNGCPRO; + if (result >= 0 && (unsigned) s1.st_mtime < (unsigned) s2.st_mtime) { /* Make the progress messages mention that source is newer. */ newer = 1; /* If we won't print another message, mention this anyway. */ - if (! NILP (nomessage)) - message_with_string ("Source file `%s' newer than byte-compiled file", - found, 1); + if (!NILP (nomessage)) + { + Lisp_Object file; + file = Fsubstring (found, make_number (0), make_number (-1)); + message_with_string ("Source file `%s' newer than byte-compiled file", + file, 1); + } } - XSTRING (found)->data[STRING_BYTES (XSTRING (found)) - 1] = 'c'; } } else @@ -807,14 +871,17 @@ Return t if file exists. */) #ifdef WINDOWSNT emacs_close (fd); - stream = fopen ((char *) XSTRING (found)->data, fmode); + GCPRO1 (efound); + efound = ENCODE_FILE (found); + stream = fopen ((char *) SDATA (efound), fmode); + UNGCPRO; #else /* not WINDOWSNT */ stream = fdopen (fd, fmode); #endif /* not WINDOWSNT */ if (stream == 0) { emacs_close (fd); - error ("Failure to create stdio stream for %s", XSTRING (file)->data); + error ("Failure to create stdio stream for %s", SDATA (file)); } if (! NILP (Vpurify_flag)) @@ -878,6 +945,11 @@ Return t if file exists. */) message_with_string ("Loading %s...done", file, 1); } + if (!NILP (Fequal (build_string ("obsolete"), + Ffile_name_nondirectory + (Fdirectory_file_name (Ffile_name_directory (found)))))) + message_with_string ("Package %s is obsolete", file, 1); + return Qt; } @@ -916,9 +988,9 @@ static int complete_filename_p (pathname) Lisp_Object pathname; { - register unsigned char *s = XSTRING (pathname)->data; + register const unsigned char *s = SDATA (pathname); return (IS_DIRECTORY_SEP (s[0]) - || (XSTRING (pathname)->size > 2 + || (SCHARS (pathname) > 2 && IS_DEVICE_SEP (s[1]) && IS_DIRECTORY_SEP (s[2])) #ifdef ALTOS || *s == '@' @@ -929,6 +1001,24 @@ complete_filename_p (pathname) ); } +DEFUN ("locate-file-internal", Flocate_file_internal, Slocate_file_internal, 2, 4, 0, + doc: /* Search for FILENAME through PATH. +If SUFFIXES is non-nil, it should be a list of suffixes to append to +file name when searching. +If non-nil, PREDICATE is used instead of `file-readable-p'. +PREDICATE can also be an integer to pass to the access(2) function, +in which case file-name-handlers are ignored. */) + (filename, path, suffixes, predicate) + Lisp_Object filename, path, suffixes, predicate; +{ + Lisp_Object file; + int fd = openp (path, filename, suffixes, &file, predicate); + if (NILP (predicate) && fd > 0) + close (fd); + return file; +} + + /* Search for a file whose name is STR, looking in directories in the Lisp list PATH, and trying suffixes from SUFFIX. On success, returns a file descriptor. On failure, returns -1. @@ -936,24 +1026,25 @@ complete_filename_p (pathname) SUFFIXES is a list of strings containing possible suffixes. The empty suffix is automatically added iff the list is empty. - EXEC_ONLY nonzero means don't open the files, - just look for one that is executable. In this case, - returns 1 on success. + PREDICATE non-nil means don't open the files, + just look for one that satisfies the predicate. In this case, + returns 1 on success. The predicate can be a lisp function or + an integer to pass to `access' (in which case file-name-handlers + are ignored). If STOREPTR is nonzero, it points to a slot where the name of the file actually found should be stored as a Lisp string. nil is stored there on failure. If the file we find is remote, return -2 - but store the found remote file name in *STOREPTR. - We do not check for remote files if EXEC_ONLY is nonzero. */ + but store the found remote file name in *STOREPTR. */ int -openp (path, str, suffixes, storeptr, exec_only) +openp (path, str, suffixes, storeptr, predicate) Lisp_Object path, str; Lisp_Object suffixes; Lisp_Object *storeptr; - int exec_only; + Lisp_Object predicate; { register int fd; int fn_size = 100; @@ -963,20 +1054,22 @@ openp (path, str, suffixes, storeptr, exec_only) int want_size; Lisp_Object filename; struct stat st; - struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5; - Lisp_Object string, tail; + struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5, gcpro6; + Lisp_Object string, tail, encoded_fn; int max_suffix_len = 0; + CHECK_STRING (str); + for (tail = suffixes; CONSP (tail); tail = XCDR (tail)) { CHECK_STRING_CAR (tail); max_suffix_len = max (max_suffix_len, - STRING_BYTES (XSTRING (XCAR (tail)))); + SBYTES (XCAR (tail))); } string = filename = Qnil; - GCPRO5 (str, string, filename, path, suffixes); - + GCPRO6 (str, string, filename, path, suffixes, encoded_fn); + if (storeptr) *storeptr = Qnil; @@ -999,7 +1092,7 @@ openp (path, str, suffixes, storeptr, exec_only) /* Calculate maximum size of any filename made from this path element/specified file name and any possible suffix. */ - want_size = max_suffix_len + STRING_BYTES (XSTRING (filename)) + 1; + want_size = max_suffix_len + SBYTES (filename) + 1; if (fn_size < want_size) fn = (char *) alloca (fn_size = 100 + want_size); @@ -1007,29 +1100,30 @@ openp (path, str, suffixes, storeptr, exec_only) for (tail = NILP (suffixes) ? default_suffixes : suffixes; CONSP (tail); tail = XCDR (tail)) { - int lsuffix = STRING_BYTES (XSTRING (XCAR (tail))); + int lsuffix = SBYTES (XCAR (tail)); Lisp_Object handler; + int exists; /* Concatenate path element/specified name with the suffix. If the directory starts with /:, remove that. */ - if (XSTRING (filename)->size > 2 - && XSTRING (filename)->data[0] == '/' - && XSTRING (filename)->data[1] == ':') + if (SCHARS (filename) > 2 + && SREF (filename, 0) == '/' + && SREF (filename, 1) == ':') { - strncpy (fn, XSTRING (filename)->data + 2, - STRING_BYTES (XSTRING (filename)) - 2); - fn[STRING_BYTES (XSTRING (filename)) - 2] = 0; + strncpy (fn, SDATA (filename) + 2, + SBYTES (filename) - 2); + fn[SBYTES (filename) - 2] = 0; } else { - strncpy (fn, XSTRING (filename)->data, - STRING_BYTES (XSTRING (filename))); - fn[STRING_BYTES (XSTRING (filename))] = 0; + strncpy (fn, SDATA (filename), + SBYTES (filename)); + fn[SBYTES (filename)] = 0; } if (lsuffix != 0) /* Bug happens on CCI if lsuffix is 0. */ - strncat (fn, XSTRING (XCAR (tail))->data, lsuffix); - + strncat (fn, SDATA (XCAR (tail)), 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) @@ -1038,42 +1132,47 @@ openp (path, str, suffixes, storeptr, exec_only) 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". */ - handler = Ffind_file_name_handler (filename, Qfile_exists_p); - if (!NILP (handler) && !exec_only) - { - int exists; - - string = build_string (fn); - exists = !NILP (Ffile_readable_p (string)); - if (exists && !NILP (Ffile_directory_p (build_string (fn)))) + string = build_string (fn); + handler = Ffind_file_name_handler (string, Qfile_exists_p); + if ((!NILP (handler) || !NILP (predicate)) && !NATNUMP (predicate)) + { + if (NILP (predicate)) + exists = !NILP (Ffile_readable_p (string)); + else + exists = !NILP (call1 (predicate, string)); + if (exists && !NILP (Ffile_directory_p (string))) exists = 0; if (exists) { /* We succeeded; return this descriptor and filename. */ if (storeptr) - *storeptr = build_string (fn); + *storeptr = string; UNGCPRO; return -2; } } else { - int exists = (stat (fn, &st) >= 0 - && (st.st_mode & S_IFMT) != S_IFDIR); + const char *pfn; + + encoded_fn = ENCODE_FILE (string); + pfn = SDATA (encoded_fn); + exists = (stat (pfn, &st) >= 0 + && (st.st_mode & S_IFMT) != S_IFDIR); if (exists) { /* Check that we can access or open it. */ - if (exec_only) - fd = (access (fn, X_OK) == 0) ? 1 : -1; + if (NATNUMP (predicate)) + fd = (access (pfn, XFASTINT (predicate)) == 0) ? 1 : -1; else - fd = emacs_open (fn, O_RDONLY, 0); + fd = emacs_open (pfn, O_RDONLY, 0); if (fd >= 0) { /* We succeeded; return this descriptor and filename. */ if (storeptr) - *storeptr = build_string (fn); + *storeptr = string; UNGCPRO; return fd; } @@ -1107,9 +1206,9 @@ build_load_history (stream, source) tail = Vload_history; prev = Qnil; foundit = 0; - while (!NILP (tail)) + while (CONSP (tail)) { - tem = Fcar (tail); + tem = XCAR (tail); /* Find the feature's previous assoc list... */ if (!NILP (Fequal (source, Fcar (tem)))) @@ -1118,11 +1217,11 @@ build_load_history (stream, source) /* If we're loading, remove it. */ if (loading) - { + { if (NILP (prev)) - Vload_history = Fcdr (tail); + Vload_history = XCDR (tail); else - Fsetcdr (prev, Fcdr (tail)); + Fsetcdr (prev, XCDR (tail)); } /* Otherwise, cons on new symbols that are not already members. */ @@ -1132,20 +1231,20 @@ build_load_history (stream, source) while (CONSP (tem2)) { - newelt = Fcar (tem2); + newelt = XCAR (tem2); - if (NILP (Fmemq (newelt, tem))) - Fsetcar (tail, Fcons (Fcar (tem), - Fcons (newelt, Fcdr (tem)))); + if (NILP (Fmember (newelt, tem))) + Fsetcar (tail, Fcons (XCAR (tem), + Fcons (newelt, XCDR (tem)))); - tem2 = Fcdr (tem2); + tem2 = XCDR (tem2); QUIT; } } } else prev = tail; - tail = Fcdr (tail); + tail = XCDR (tail); QUIT; } @@ -1204,7 +1303,7 @@ readevalloop (readcharfun, stream, sourcename, evalfun, printflag, unibyte, read { register int c; register Lisp_Object val; - int count = specpdl_ptr - specpdl; + int count = SPECPDL_INDEX (); struct gcpro gcpro1; struct buffer *b = 0; int continue_reading_p; @@ -1246,7 +1345,7 @@ readevalloop (readcharfun, stream, sourcename, evalfun, printflag, unibyte, read if (!NILP (Vpurify_flag) && c == '(') { - int count1 = specpdl_ptr - specpdl; + int count1 = SPECPDL_INDEX (); record_unwind_protect (unreadpure, Qnil); val = read_list (-1, readcharfun); unbind_to (count1, Qnil); @@ -1272,7 +1371,7 @@ readevalloop (readcharfun, stream, sourcename, evalfun, printflag, unibyte, read else if (! NILP (Vload_read_function)) val = call1 (Vload_read_function, readcharfun); else - val = read0 (readcharfun); + val = read_internal_start (readcharfun, Qnil, Qnil); } val = (*evalfun) (val); @@ -1305,14 +1404,14 @@ it specifies the file name to use for `load-history'. The optional fourth argument UNIBYTE specifies `load-convert-to-unibyte' for this invocation. -The optional fifth argument DO-ALLOW-PRINT, if not-nil, specifies that +The optional fifth argument DO-ALLOW-PRINT, if non-nil, specifies that `print' and related functions should work normally even if PRINTFLAG is nil. This function preserves the position of point. */) (buffer, printflag, filename, unibyte, do_allow_print) Lisp_Object buffer, printflag, filename, unibyte, do_allow_print; { - int count = specpdl_ptr - specpdl; + int count = SPECPDL_INDEX (); Lisp_Object tem, buf; if (NILP (buffer)) @@ -1354,7 +1453,7 @@ This function does not move point. */) (start, end, printflag, read_function) Lisp_Object start, end, printflag, read_function; { - int count = specpdl_ptr - specpdl; + int count = SPECPDL_INDEX (); Lisp_Object tem, cbuf; cbuf = Fcurrent_buffer (); @@ -1393,24 +1492,14 @@ STREAM or the value of `standard-input' may be: (stream) Lisp_Object stream; { - extern Lisp_Object Fread_minibuffer (); - if (NILP (stream)) stream = Vstandard_input; if (EQ (stream, Qt)) stream = Qread_char; - - readchar_backlog = -1; - new_backquote_flag = 0; - read_objects = Qnil; - if (EQ (stream, Qread_char)) return Fread_minibuffer (build_string ("Lisp expression: "), Qnil); - if (STRINGP (stream)) - return Fcar (Fread_from_string (stream, Qnil, Qnil)); - - return read0 (stream); + return read_internal_start (stream, Qnil, Qnil); } DEFUN ("read-from-string", Fread_from_string, Sread_from_string, 1, 3, 0, @@ -1421,40 +1510,63 @@ START and END optionally delimit a substring of STRING from which to read; (string, start, end) Lisp_Object string, start, end; { - int startval, endval; - Lisp_Object tem; - + Lisp_Object ret; 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)); +} - if (NILP (end)) - endval = XSTRING (string)->size; - else - { - CHECK_NUMBER (end); - endval = XINT (end); - if (endval < 0 || endval > XSTRING (string)->size) - args_out_of_range (string, end); - } - - if (NILP (start)) - startval = 0; - else - { - CHECK_NUMBER (start); - startval = XINT (start); - if (startval < 0 || startval > endval) - args_out_of_range (string, start); - } - - read_from_string_index = startval; - read_from_string_index_byte = string_char_to_byte (string, startval); - read_from_string_limit = endval; +/* Function to set up the global context we need in toplevel read + calls. */ +static Lisp_Object +read_internal_start (stream, start, end) + Lisp_Object stream; + Lisp_Object start; /* Only used when stream is a string. */ + Lisp_Object end; /* Only used when stream is a string. */ +{ + Lisp_Object retval; + readchar_backlog = -1; + readchar_count = 0; new_backquote_flag = 0; read_objects = Qnil; + if (EQ (Vread_with_symbol_positions, Qt) + || EQ (Vread_with_symbol_positions, stream)) + Vread_symbol_positions_list = Qnil; - tem = read0 (string); - return Fcons (tem, make_number (read_from_string_index)); + if (STRINGP (stream)) + { + int startval, endval; + if (NILP (end)) + endval = SCHARS (stream); + else + { + CHECK_NUMBER (end); + endval = XINT (end); + if (endval < 0 || endval > SCHARS (stream)) + args_out_of_range (stream, end); + } + + if (NILP (start)) + startval = 0; + else + { + CHECK_NUMBER (start); + startval = XINT (start); + if (startval < 0 || startval > endval) + args_out_of_range (stream, start); + } + read_from_string_index = startval; + read_from_string_index_byte = string_char_to_byte (stream, startval); + read_from_string_limit = endval; + } + + retval = read0 (stream); + if (EQ (Vread_with_symbol_positions, Qt) + || EQ (Vread_with_symbol_positions, stream)) + Vread_symbol_positions_list = Fnreverse (Vread_symbol_positions_list); + return retval; } /* Use this for recursive reads, in contexts where internal tokens @@ -1494,10 +1606,16 @@ read_multibyte (c, readcharfun) int len = 0; int bytes; + if (c < 0) + return c; + str[len++] = c; while ((c = READCHAR) >= 0xA0 && len < MAX_MULTIBYTE_LENGTH) - str[len++] = c; + { + str[len++] = c; + readchar_count--; + } UNREAD (c); if (UNIBYTE_STR_AS_MULTIBYTE_P (str, len, bytes)) return STRING_CHAR (str, len); @@ -1590,9 +1708,13 @@ read_escape (readcharfun, stringp, byterep) return c | alt_modifier; case 's': + if (stringp) + return ' '; c = READCHAR; - if (c != '-') - error ("Invalid escape character syntax"); + if (c != '-') { + UNREAD (c); + return ' '; + } c = READCHAR; if (c == '\\') c = read_escape (readcharfun, 0, byterep); @@ -1644,7 +1766,7 @@ read_escape (readcharfun, stringp, byterep) break; } } - + *byterep = 1; return i; } @@ -1718,11 +1840,11 @@ read_integer (readcharfun, radix) } else if (c == '+') c = READCHAR; - + while (c >= 0) { int digit; - + if (c >= '0' && c <= '9') digit = c - '0'; else if (c >= 'a' && c <= 'z') @@ -1787,7 +1909,7 @@ to_multibyte (p, end, nchars) if (nbytes != *nchars) nbytes = str_as_multibyte (read_buffer, read_buffer_size, *p - read_buffer, nchars); - + *p = read_buffer + nbytes; } @@ -1872,27 +1994,28 @@ read1 (readcharfun, pch, first_in_list) if (c == '"') { Lisp_Object tmp, val; - int size_in_chars = ((XFASTINT (length) + BITS_PER_CHAR - 1) - / BITS_PER_CHAR); + int size_in_chars + = ((XFASTINT (length) + BOOL_VECTOR_BITS_PER_CHAR - 1) + / BOOL_VECTOR_BITS_PER_CHAR); UNREAD (c); tmp = read1 (readcharfun, pch, first_in_list); - if (size_in_chars != XSTRING (tmp)->size + if (size_in_chars != SCHARS (tmp) /* We used to print 1 char too many when the number of bits was a multiple of 8. Accept such input in case it came from an old version. */ && ! (XFASTINT (length) - == (XSTRING (tmp)->size - 1) * BITS_PER_CHAR)) + == (SCHARS (tmp) - 1) * BOOL_VECTOR_BITS_PER_CHAR)) Fsignal (Qinvalid_read_syntax, Fcons (make_string ("#&...", 5), Qnil)); - + val = Fmake_bool_vector (length, Qnil); - bcopy (XSTRING (tmp)->data, XBOOL_VECTOR (val)->data, + bcopy (SDATA (tmp), XBOOL_VECTOR (val)->data, size_in_chars); /* Clear the extraneous bits in the last byte. */ - if (XINT (length) != size_in_chars * BITS_PER_CHAR) + if (XINT (length) != size_in_chars * BOOL_VECTOR_BITS_PER_CHAR) XBOOL_VECTOR (val)->data[size_in_chars - 1] - &= (1 << (XINT (length) % BITS_PER_CHAR)) - 1; + &= (1 << (XINT (length) % BOOL_VECTOR_BITS_PER_CHAR)) - 1; return val; } Fsignal (Qinvalid_read_syntax, Fcons (make_string ("#&...", 5), @@ -1940,7 +2063,7 @@ read1 (readcharfun, pch, first_in_list) UNGCPRO; return tmp; } - + /* #@NUMBER is used to skip NUMBER following characters. That's used in .elc files to skip over doc strings and function definitions. */ @@ -1957,7 +2080,7 @@ read1 (readcharfun, pch, first_in_list) } if (c >= 0) UNREAD (c); - + if (load_force_doc_strings && EQ (readcharfun, Qget_file_char)) { /* If we are supposed to force doc strings into core right now, @@ -2012,6 +2135,14 @@ read1 (readcharfun, pch, first_in_list) goto retry; } + if (c == '!') + { + /* #! appears at the beginning of an executable file. + Skip the first line. */ + while (c != '\n' && c >= 0) + c = READCHAR; + goto retry; + } if (c == '$') return Vload_file_name; if (c == '\'') @@ -2055,7 +2186,7 @@ read1 (readcharfun, pch, first_in_list) /* ...and #n# will use the real value from now on. */ Fsetcdr (cell, tem); - + return tem; } /* #n# returns a previously read object. */ @@ -2068,7 +2199,7 @@ read1 (readcharfun, pch, first_in_list) } else if (c == 'r' || c == 'R') return read_integer (readcharfun, n); - + /* Fall through to error message. */ } else if (c == 'x' || c == 'X') @@ -2132,16 +2263,50 @@ read1 (readcharfun, pch, first_in_list) case '?': { int discard; + int next_char; + int ok; c = READCHAR; if (c < 0) end_of_file_error (); + /* Accept `single space' syntax like (list ? x) where the + whitespace character is SPC or TAB. + 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); + if (c == '\\') c = read_escape (readcharfun, 0, &discard); else if (BASE_LEADING_CODE_P (c)) c = read_multibyte (c, readcharfun); + next_char = READCHAR; + if (next_char == '.') + { + /* Only a dotted-pair dot is valid after a char constant. */ + int next_next_char = READCHAR; + UNREAD (next_next_char); + + ok = (next_next_char <= 040 + || (next_next_char < 0200 + && (index ("\"';([#?", next_next_char) + || (!first_in_list && next_next_char == '`') + || (new_backquote_flag && next_next_char == ',')))); + } + else + { + ok = (next_char <= 040 + || (next_char < 0200 + && (index ("\"';()[]#?", next_char) + || (!first_in_list && next_char == '`') + || (new_backquote_flag && next_char == ',')))); + } + UNREAD (next_char); + if (!ok) + Fsignal (Qinvalid_read_syntax, Fcons (make_string ("?", 1), Qnil)); + return make_number (c); } @@ -2210,7 +2375,7 @@ read1 (readcharfun, pch, first_in_list) c = 0; else if (c == (CHAR_CTL | '?')) c = 127; - + if (c & CHAR_SHIFT) { /* Shift modifier is valid only with [A-Za-z]. */ @@ -2276,6 +2441,11 @@ read1 (readcharfun, pch, first_in_list) separate characters, treat them as separate characters now. */ ; + /* We want readchar_count to be the number of characters, not + bytes. Hence we adjust for multibyte characters in the + string. ... But it doesn't seem to be necessary, because + READCHAR *does* read multibyte characters from buffers. */ + /* readchar_count -= (p - read_buffer) - nchars; */ if (read_pure) return make_pure_string (read_buffer, nchars, p - read_buffer, is_multibyte); @@ -2289,7 +2459,10 @@ read1 (readcharfun, pch, first_in_list) UNREAD (next_char); if (next_char <= 040 - || index ("\"'`,(", next_char)) + || (next_char < 0200 + && index ("\"';([#?", next_char) + || (!first_in_list && next_char == '`') + || (new_backquote_flag && next_char == ','))) { *pch = c; return Qnil; @@ -2310,9 +2483,10 @@ read1 (readcharfun, pch, first_in_list) char *end = read_buffer + read_buffer_size; while (c > 040 - && !(c == '\"' || c == '\'' || c == ';' - || c == '(' || c == ')' - || c == '[' || c == ']' || c == '#')) + && (c >= 0200 + || (!index ("\"';()[]#", c) + && !(!first_in_list && c == '`') + && !(new_backquote_flag && c == ',')))) { if (end - p < MAX_MULTIBYTE_LENGTH) { @@ -2322,7 +2496,7 @@ read1 (readcharfun, pch, first_in_list) p = read_buffer + offset; end = read_buffer + read_buffer_size; } - + if (c == '\\') { c = READCHAR; @@ -2411,11 +2585,21 @@ read1 (readcharfun, pch, first_in_list) return make_float (negative ? - value : value); } } - - if (uninterned_symbol) - return make_symbol (read_buffer); - else - return intern (read_buffer); + { + Lisp_Object result = uninterned_symbol ? make_symbol (read_buffer) + : intern (read_buffer); + if (EQ (Vread_with_symbol_positions, Qt) + || EQ (Vread_with_symbol_positions, readcharfun)) + Vread_symbol_positions_list = + /* Kind of a hack; this will probably fail if characters + in the symbol name were escaped. Not really a big + deal, though. */ + Fcons (Fcons (result, + make_number (readchar_count + - XFASTINT (Flength (Fsymbol_name (result))))), + Vread_symbol_positions_list); + return result; + } } } } @@ -2437,7 +2621,7 @@ substitute_object_in_subtree (object, placeholder) /* Make all the substitutions. */ check_object = substitute_object_recurse (object, placeholder, object); - + /* Clear seen_list because we're done with it. */ seen_list = Qnil; @@ -2481,7 +2665,7 @@ substitute_object_recurse (object, placeholder, subtree) read_objects. */ if (!EQ (Qnil, Frassq (subtree, read_objects))) seen_list = Fcons (subtree, seen_list); - + /* Recurse according to subtree's type. Every branch must return a Lisp_Object. */ switch (XTYPE (subtree)) @@ -2494,7 +2678,7 @@ substitute_object_recurse (object, placeholder, subtree) { Lisp_Object idx = make_number (i); SUBSTITUTE (Faref (subtree, idx), - Faset (subtree, idx, true_value)); + Faset (subtree, idx, true_value)); } return subtree; } @@ -2513,9 +2697,9 @@ substitute_object_recurse (object, placeholder, subtree) /* Check for text properties in each interval. substitute_in_interval contains part of the logic. */ - INTERVAL root_interval = XSTRING (subtree)->intervals; + INTERVAL root_interval = STRING_INTERVALS (subtree); Lisp_Object arg = Fcons (object, placeholder); - + traverse_intervals_noorder (root_interval, &substitute_in_interval, arg); @@ -2552,7 +2736,7 @@ isfloat_string (cp) register char *cp; { register int state; - + char *start = cp; state = 0; @@ -2659,8 +2843,8 @@ read_vector (readcharfun, bytecodeflag) /* Coerce string to unibyte (like string-as-unibyte, but without generating extra garbage and guaranteeing no change in the contents). */ - XSTRING (bytestr)->size = STRING_BYTES (XSTRING (bytestr)); - SET_STRING_BYTES (XSTRING (bytestr), -1); + STRING_SET_CHARS (bytestr, SBYTES (bytestr)); + STRING_SET_UNIBYTE (bytestr); item = Fread (bytestr); if (!CONSP (item)) @@ -2683,7 +2867,7 @@ read_vector (readcharfun, bytecodeflag) } return vector; } - + /* FLAG = 1 means check for ] to terminate rather than ) and . FLAG = -1 means check for starting with defun and make structure pure. */ @@ -2702,7 +2886,7 @@ read_list (flag, readcharfun) struct gcpro gcpro1, gcpro2; /* 0 is the normal case. 1 means this list is a doc reference; replace it with the number 0. - 2 means this list is a doc reference; replace it with the doc string. */ + 2 means this list is a doc reference; replace it with the doc string. */ int doc_reference = 0; /* Initialize this to 1 if we are reading a list. */ @@ -2872,7 +3056,6 @@ Lisp_Object initial_obarray; int oblookup_last_bucket_number; static int hash_string (); -Lisp_Object oblookup (); /* Get an error if OBARRAY is not an obarray. If it is one, return it. */ @@ -2896,7 +3079,7 @@ check_obarray (obarray) Lisp_Object intern (str) - char *str; + const char *str; { Lisp_Object tem; int len = strlen (str); @@ -2939,9 +3122,9 @@ it defaults to the value of `obarray'. */) CHECK_STRING (string); - tem = oblookup (obarray, XSTRING (string)->data, - XSTRING (string)->size, - STRING_BYTES (XSTRING (string))); + tem = oblookup (obarray, SDATA (string), + SCHARS (string), + SBYTES (string)); if (!INTEGERP (tem)) return tem; @@ -2954,7 +3137,7 @@ it defaults to the value of `obarray'. */) else XSYMBOL (sym)->interned = SYMBOL_INTERNED; - if ((XSTRING (string)->data[0] == ':') + if ((SREF (string, 0) == ':') && EQ (obarray, initial_obarray)) { XSYMBOL (sym)->constant = 1; @@ -2979,8 +3162,7 @@ it defaults to the value of `obarray'. */) (name, obarray) Lisp_Object name, obarray; { - register Lisp_Object tem; - struct Lisp_String *string; + register Lisp_Object tem, string; if (NILP (obarray)) obarray = Vobarray; obarray = check_obarray (obarray); @@ -2988,12 +3170,12 @@ it defaults to the value of `obarray'. */) if (!SYMBOLP (name)) { CHECK_STRING (name); - string = XSTRING (name); + string = name; } else - string = XSYMBOL (name)->name; + string = SYMBOL_NAME (name); - tem = oblookup (obarray, string->data, string->size, STRING_BYTES (string)); + tem = oblookup (obarray, SDATA (string), SCHARS (string), SBYTES (string)); if (INTEGERP (tem) || (SYMBOLP (name) && !EQ (name, tem))) return Qnil; else @@ -3016,16 +3198,16 @@ OBARRAY defaults to the value of the variable `obarray'. */) obarray = check_obarray (obarray); if (SYMBOLP (name)) - XSETSTRING (string, XSYMBOL (name)->name); + string = SYMBOL_NAME (name); else { CHECK_STRING (name); string = name; } - tem = oblookup (obarray, XSTRING (string)->data, - XSTRING (string)->size, - STRING_BYTES (XSTRING (string))); + tem = oblookup (obarray, SDATA (string), + SCHARS (string), + SBYTES (string)); if (INTEGERP (tem)) return Qnil; /* If arg was a symbol, don't delete anything but that symbol itself. */ @@ -3074,7 +3256,7 @@ OBARRAY defaults to the value of the variable `obarray'. */) Lisp_Object oblookup (obarray, ptr, size, size_byte) Lisp_Object obarray; - register char *ptr; + register const char *ptr; int size, size_byte; { int hash; @@ -3102,9 +3284,9 @@ oblookup (obarray, ptr, size, size_byte) else for (tail = bucket; ; XSETSYMBOL (tail, XSYMBOL (tail)->next)) { - if (STRING_BYTES (XSYMBOL (tail)->name) == size_byte - && XSYMBOL (tail)->name->size == size - && !bcmp (XSYMBOL (tail)->name->data, ptr, size_byte)) + if (SBYTES (SYMBOL_NAME (tail)) == size_byte + && SCHARS (SYMBOL_NAME (tail)) == size + && !bcmp (SDATA (SYMBOL_NAME (tail)), ptr, size_byte)) return tail; else if (XSYMBOL (tail)->next == 0) break; @@ -3115,11 +3297,11 @@ oblookup (obarray, ptr, size, size_byte) static int hash_string (ptr, len) - unsigned char *ptr; + const unsigned char *ptr; int len; { - register unsigned char *p = ptr; - register unsigned char *end = p + len; + register const unsigned char *p = ptr; + register const unsigned char *end = p + len; register unsigned char c; register int hash = 0; @@ -3193,7 +3375,7 @@ init_obarray () /* Intern nil in the obarray */ XSYMBOL (Qnil)->interned = SYMBOL_INTERNED_IN_INITIAL_OBARRAY; XSYMBOL (Qnil)->constant = 1; - + /* These locals are to kludge around a pyramid compiler bug. */ hash = hash_string ("nil", 3); /* Separate statement here to avoid VAXC bug. */ @@ -3249,7 +3431,7 @@ defalias (sname, string) void defvar_int (namestring, address) char *namestring; - int *address; + EMACS_INT *address; { Lisp_Object sym, val; sym = intern (namestring); @@ -3315,7 +3497,6 @@ defvar_per_buffer (namestring, address, type, doc) { Lisp_Object sym, val; int offset; - extern struct buffer buffer_local_symbols; sym = intern (namestring); val = allocate_misc (); @@ -3326,7 +3507,7 @@ defvar_per_buffer (namestring, address, type, doc) SET_SYMBOL_VALUE (sym, val); PER_BUFFER_SYMBOL (offset) = sym; PER_BUFFER_TYPE (offset) = type; - + if (PER_BUFFER_IDX (offset) == 0) /* Did a DEFVAR_PER_BUFFER without initializing the corresponding slot of buffer_local_flags */ @@ -3497,11 +3678,15 @@ init_lread () } #endif -#ifndef WINDOWSNT - /* When Emacs is invoked over network shares on NT, PATH_LOADSEARCH is - almost never correct, thereby causing a warning to be printed out that +#if (!(defined(WINDOWSNT) || (defined(HAVE_CARBON)))) + /* When Emacs is invoked over network shares on NT, PATH_LOADSEARCH is + almost never correct, thereby causing a warning to be printed out that confuses users. Since PATH_LOADSEARCH is always overridden by the - EMACSLOADPATH environment variable below, disable the warning on NT. */ + EMACSLOADPATH environment variable below, disable the warning on NT. + Also, when using the "self-contained" option for Carbon Emacs for MacOSX, + the "standard" paths may not exist and would be overridden by + EMACSLOADPATH as on NT. Since this depends on how the executable + was build and packaged, turn off the warnings in general */ /* Warn if dirs in the *standard* path don't exist. */ if (!turn_off_warning) @@ -3517,13 +3702,13 @@ init_lread () if (STRINGP (dirfile)) { dirfile = Fdirectory_file_name (dirfile); - if (access (XSTRING (dirfile)->data, 0) < 0) + if (access (SDATA (dirfile), 0) < 0) dir_warning ("Warning: Lisp directory `%s' does not exist.\n", XCAR (path_tail)); } } } -#endif /* WINDOWSNT */ +#endif /* !(WINDOWSNT || HAVE_CARBON) */ /* If the EMACSLOADPATH environment variable is set, use its value. This doesn't apply if we're dumping. */ @@ -3553,10 +3738,10 @@ dir_warning (format, dirname) Lisp_Object dirname; { char *buffer - = (char *) alloca (XSTRING (dirname)->size + strlen (format) + 5); + = (char *) alloca (SCHARS (dirname) + strlen (format) + 5); - fprintf (stderr, format, XSTRING (dirname)->data); - sprintf (buffer, format, XSTRING (dirname)->data); + fprintf (stderr, format, SDATA (dirname)); + sprintf (buffer, format, SDATA (dirname)); /* Don't log the warning before we've initialized!! */ if (initialized) message_dolog (buffer, strlen (buffer), 0, STRING_MULTIBYTE (dirname)); @@ -3578,6 +3763,7 @@ syms_of_lread () defsubr (&Sread_event); defsubr (&Sget_file_char); defsubr (&Smapatoms); + defsubr (&Slocate_file_internal); DEFVAR_LISP ("obarray", &Vobarray, doc: /* Symbol table for use by `intern' and `read'. @@ -3594,6 +3780,35 @@ Order is reverse chronological. */); See documentation of `read' for possible values. */); Vstandard_input = Qt; + DEFVAR_LISP ("read-with-symbol-positions", &Vread_with_symbol_positions, + doc: /* If non-nil, add position of read symbols to `read-symbol-positions-list'. + +If this variable is a buffer, then only forms read from that buffer +will be added to `read-symbol-positions-list'. +If this variable is t, then all read forms will be added. +The effect of all other values other than nil are not currently +defined, although they may be in the future. + +The positions are relative to the last call to `read' or +`read-from-string'. It is probably a bad idea to set this variable at +the toplevel; bind it instead. */); + Vread_with_symbol_positions = Qnil; + + DEFVAR_LISP ("read-symbol-positions-list", &Vread_symbol_positions_list, + doc: /* A list mapping read symbols to their positions. +This variable is modified during calls to `read' or +`read-from-string', but only when `read-with-symbol-positions' is +non-nil. + +Each element of the list looks like (SYMBOL . CHAR-POSITION), where +CHAR-POSITION is an integer giving the offset of that occurrence of the +symbol from the position where `read' or `read-from-string' started. + +Note that a symbol will appear multiple times in this list, if it was +read multiple times. The list is in the same order as the symbols +were read in. */); + Vread_symbol_positions_list = Qnil; + DEFVAR_LISP ("load-path", &Vload_path, doc: /* *List of directories to search for files to load. Each element is a string (directory name) or nil (try default directory). @@ -3631,9 +3846,12 @@ when the corresponding call to `provide' is made. */); Each alist element is a list that starts with a file name, except for one element (optional) that starts with nil and describes definitions evaluated from buffers not visiting files. -The remaining elements of each list are symbols defined as functions -or variables, and cons cells `(provide . FEATURE)', `(require . FEATURE)', -and `(autoload . SYMBOL)'. */); +The remaining elements of each list are symbols defined as functions, +and cons cells of the form `(provide . FEATURE)', `(require . FEATURE)', +`(defvar . VARIABLE), `(autoload . SYMBOL)', and `(t . SYMBOL)'. +An element `(t . SYMBOL)' precedes an entry that is just SYMBOL, +and means that SYMBOL was an autoload before this file redefined it +as a function. */); Vload_history = Qnil; DEFVAR_LISP ("load-file-name", &Vload_file_name, @@ -3753,7 +3971,10 @@ to load. See also `load-dangerous-libraries'. */); staticpro (&read_objects); read_objects = Qnil; staticpro (&seen_list); - + Vloads_in_progress = Qnil; staticpro (&Vloads_in_progress); } + +/* arch-tag: a0d02733-0f96-4844-a659-9fd53c4f414d + (do not change this comment) */