Merge from origin/emacs-25
[emacs.git] / src / lread.c
blobecd482793a9a05d5ab231b1ebe2d6a90aea037b6
1 /* Lisp parsing and input streams.
3 Copyright (C) 1985-1989, 1993-1995, 1997-2016 Free Software Foundation,
4 Inc.
6 This file is part of GNU Emacs.
8 GNU Emacs is free software: you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation, either version 3 of the License, or (at
11 your option) any later version.
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
21 /* Tell globals.h to define tables needed by init_obarray. */
22 #define DEFINE_SYMBOLS
24 #include <config.h>
25 #include "sysstdio.h"
26 #include <sys/types.h>
27 #include <sys/stat.h>
28 #include <sys/file.h>
29 #include <errno.h>
30 #include <limits.h> /* For CHAR_BIT. */
31 #include <math.h>
32 #include <stat-time.h>
33 #include "lisp.h"
34 #include "dispextern.h"
35 #include "intervals.h"
36 #include "character.h"
37 #include "buffer.h"
38 #include "charset.h"
39 #include <epaths.h>
40 #include "commands.h"
41 #include "keyboard.h"
42 #include "systime.h"
43 #include "termhooks.h"
44 #include "blockinput.h"
45 #include <c-ctype.h>
47 #ifdef MSDOS
48 #include "msdos.h"
49 #if __DJGPP__ == 2 && __DJGPP_MINOR__ < 5
50 # define INFINITY __builtin_inf()
51 # define NAN __builtin_nan("")
52 #endif
53 #endif
55 #ifdef HAVE_NS
56 #include "nsterm.h"
57 #endif
59 #include <unistd.h>
61 #ifdef HAVE_SETLOCALE
62 #include <locale.h>
63 #endif /* HAVE_SETLOCALE */
65 #include <fcntl.h>
67 #ifdef HAVE_FSEEKO
68 #define file_offset off_t
69 #define file_tell ftello
70 #else
71 #define file_offset long
72 #define file_tell ftell
73 #endif
75 /* The association list of objects read with the #n=object form.
76 Each member of the list has the form (n . object), and is used to
77 look up the object for the corresponding #n# construct.
78 It must be set to nil before all top-level calls to read0. */
79 static Lisp_Object read_objects;
81 /* File for get_file_char to read from. Use by load. */
82 static FILE *instream;
84 /* For use within read-from-string (this reader is non-reentrant!!) */
85 static ptrdiff_t read_from_string_index;
86 static ptrdiff_t read_from_string_index_byte;
87 static ptrdiff_t read_from_string_limit;
89 /* Number of characters read in the current call to Fread or
90 Fread_from_string. */
91 static EMACS_INT readchar_count;
93 /* This contains the last string skipped with #@. */
94 static char *saved_doc_string;
95 /* Length of buffer allocated in saved_doc_string. */
96 static ptrdiff_t saved_doc_string_size;
97 /* Length of actual data in saved_doc_string. */
98 static ptrdiff_t saved_doc_string_length;
99 /* This is the file position that string came from. */
100 static file_offset saved_doc_string_position;
102 /* This contains the previous string skipped with #@.
103 We copy it from saved_doc_string when a new string
104 is put in saved_doc_string. */
105 static char *prev_saved_doc_string;
106 /* Length of buffer allocated in prev_saved_doc_string. */
107 static ptrdiff_t prev_saved_doc_string_size;
108 /* Length of actual data in prev_saved_doc_string. */
109 static ptrdiff_t prev_saved_doc_string_length;
110 /* This is the file position that string came from. */
111 static file_offset prev_saved_doc_string_position;
113 /* True means inside a new-style backquote
114 with no surrounding parentheses.
115 Fread initializes this to false, so we need not specbind it
116 or worry about what happens to it when there is an error. */
117 static bool new_backquote_flag;
119 /* A list of file names for files being loaded in Fload. Used to
120 check for recursive loads. */
122 static Lisp_Object Vloads_in_progress;
124 static int read_emacs_mule_char (int, int (*) (int, Lisp_Object),
125 Lisp_Object);
127 static void readevalloop (Lisp_Object, FILE *, Lisp_Object, bool,
128 Lisp_Object, Lisp_Object,
129 Lisp_Object, Lisp_Object);
131 /* Functions that read one byte from the current source READCHARFUN
132 or unreads one byte. If the integer argument C is -1, it returns
133 one read byte, or -1 when there's no more byte in the source. If C
134 is 0 or positive, it unreads C, and the return value is not
135 interesting. */
137 static int readbyte_for_lambda (int, Lisp_Object);
138 static int readbyte_from_file (int, Lisp_Object);
139 static int readbyte_from_string (int, Lisp_Object);
141 /* Handle unreading and rereading of characters.
142 Write READCHAR to read a character,
143 UNREAD(c) to unread c to be read again.
145 These macros correctly read/unread multibyte characters. */
147 #define READCHAR readchar (readcharfun, NULL)
148 #define UNREAD(c) unreadchar (readcharfun, c)
150 /* Same as READCHAR but set *MULTIBYTE to the multibyteness of the source. */
151 #define READCHAR_REPORT_MULTIBYTE(multibyte) readchar (readcharfun, multibyte)
153 /* When READCHARFUN is Qget_file_char, Qget_emacs_mule_file_char,
154 Qlambda, or a cons, we use this to keep an unread character because
155 a file stream can't handle multibyte-char unreading. The value -1
156 means that there's no unread character. */
157 static int unread_char;
159 static int
160 readchar (Lisp_Object readcharfun, bool *multibyte)
162 Lisp_Object tem;
163 register int c;
164 int (*readbyte) (int, Lisp_Object);
165 unsigned char buf[MAX_MULTIBYTE_LENGTH];
166 int i, len;
167 bool emacs_mule_encoding = 0;
169 if (multibyte)
170 *multibyte = 0;
172 readchar_count++;
174 if (BUFFERP (readcharfun))
176 register struct buffer *inbuffer = XBUFFER (readcharfun);
178 ptrdiff_t pt_byte = BUF_PT_BYTE (inbuffer);
180 if (! BUFFER_LIVE_P (inbuffer))
181 return -1;
183 if (pt_byte >= BUF_ZV_BYTE (inbuffer))
184 return -1;
186 if (! NILP (BVAR (inbuffer, enable_multibyte_characters)))
188 /* Fetch the character code from the buffer. */
189 unsigned char *p = BUF_BYTE_ADDRESS (inbuffer, pt_byte);
190 BUF_INC_POS (inbuffer, pt_byte);
191 c = STRING_CHAR (p);
192 if (multibyte)
193 *multibyte = 1;
195 else
197 c = BUF_FETCH_BYTE (inbuffer, pt_byte);
198 if (! ASCII_CHAR_P (c))
199 c = BYTE8_TO_CHAR (c);
200 pt_byte++;
202 SET_BUF_PT_BOTH (inbuffer, BUF_PT (inbuffer) + 1, pt_byte);
204 return c;
206 if (MARKERP (readcharfun))
208 register struct buffer *inbuffer = XMARKER (readcharfun)->buffer;
210 ptrdiff_t bytepos = marker_byte_position (readcharfun);
212 if (bytepos >= BUF_ZV_BYTE (inbuffer))
213 return -1;
215 if (! NILP (BVAR (inbuffer, enable_multibyte_characters)))
217 /* Fetch the character code from the buffer. */
218 unsigned char *p = BUF_BYTE_ADDRESS (inbuffer, bytepos);
219 BUF_INC_POS (inbuffer, bytepos);
220 c = STRING_CHAR (p);
221 if (multibyte)
222 *multibyte = 1;
224 else
226 c = BUF_FETCH_BYTE (inbuffer, bytepos);
227 if (! ASCII_CHAR_P (c))
228 c = BYTE8_TO_CHAR (c);
229 bytepos++;
232 XMARKER (readcharfun)->bytepos = bytepos;
233 XMARKER (readcharfun)->charpos++;
235 return c;
238 if (EQ (readcharfun, Qlambda))
240 readbyte = readbyte_for_lambda;
241 goto read_multibyte;
244 if (EQ (readcharfun, Qget_file_char))
246 readbyte = readbyte_from_file;
247 goto read_multibyte;
250 if (STRINGP (readcharfun))
252 if (read_from_string_index >= read_from_string_limit)
253 c = -1;
254 else if (STRING_MULTIBYTE (readcharfun))
256 if (multibyte)
257 *multibyte = 1;
258 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c, readcharfun,
259 read_from_string_index,
260 read_from_string_index_byte);
262 else
264 c = SREF (readcharfun, read_from_string_index_byte);
265 read_from_string_index++;
266 read_from_string_index_byte++;
268 return c;
271 if (CONSP (readcharfun) && STRINGP (XCAR (readcharfun)))
273 /* This is the case that read_vector is reading from a unibyte
274 string that contains a byte sequence previously skipped
275 because of #@NUMBER. The car part of readcharfun is that
276 string, and the cdr part is a value of readcharfun given to
277 read_vector. */
278 readbyte = readbyte_from_string;
279 if (EQ (XCDR (readcharfun), Qget_emacs_mule_file_char))
280 emacs_mule_encoding = 1;
281 goto read_multibyte;
284 if (EQ (readcharfun, Qget_emacs_mule_file_char))
286 readbyte = readbyte_from_file;
287 emacs_mule_encoding = 1;
288 goto read_multibyte;
291 tem = call0 (readcharfun);
293 if (NILP (tem))
294 return -1;
295 return XINT (tem);
297 read_multibyte:
298 if (unread_char >= 0)
300 c = unread_char;
301 unread_char = -1;
302 return c;
304 c = (*readbyte) (-1, readcharfun);
305 if (c < 0)
306 return c;
307 if (multibyte)
308 *multibyte = 1;
309 if (ASCII_CHAR_P (c))
310 return c;
311 if (emacs_mule_encoding)
312 return read_emacs_mule_char (c, readbyte, readcharfun);
313 i = 0;
314 buf[i++] = c;
315 len = BYTES_BY_CHAR_HEAD (c);
316 while (i < len)
318 c = (*readbyte) (-1, readcharfun);
319 if (c < 0 || ! TRAILING_CODE_P (c))
321 while (--i > 1)
322 (*readbyte) (buf[i], readcharfun);
323 return BYTE8_TO_CHAR (buf[0]);
325 buf[i++] = c;
327 return STRING_CHAR (buf);
330 #define FROM_FILE_P(readcharfun) \
331 (EQ (readcharfun, Qget_file_char) \
332 || EQ (readcharfun, Qget_emacs_mule_file_char))
334 static void
335 skip_dyn_bytes (Lisp_Object readcharfun, ptrdiff_t n)
337 if (FROM_FILE_P (readcharfun))
339 block_input (); /* FIXME: Not sure if it's needed. */
340 fseek (instream, n, SEEK_CUR);
341 unblock_input ();
343 else
344 { /* We're not reading directly from a file. In that case, it's difficult
345 to reliably count bytes, since these are usually meant for the file's
346 encoding, whereas we're now typically in the internal encoding.
347 But luckily, skip_dyn_bytes is used to skip over a single
348 dynamic-docstring (or dynamic byte-code) which is always quoted such
349 that \037 is the final char. */
350 int c;
351 do {
352 c = READCHAR;
353 } while (c >= 0 && c != '\037');
357 static void
358 skip_dyn_eof (Lisp_Object readcharfun)
360 if (FROM_FILE_P (readcharfun))
362 block_input (); /* FIXME: Not sure if it's needed. */
363 fseek (instream, 0, SEEK_END);
364 unblock_input ();
366 else
367 while (READCHAR >= 0);
370 /* Unread the character C in the way appropriate for the stream READCHARFUN.
371 If the stream is a user function, call it with the char as argument. */
373 static void
374 unreadchar (Lisp_Object readcharfun, int c)
376 readchar_count--;
377 if (c == -1)
378 /* Don't back up the pointer if we're unreading the end-of-input mark,
379 since readchar didn't advance it when we read it. */
381 else if (BUFFERP (readcharfun))
383 struct buffer *b = XBUFFER (readcharfun);
384 ptrdiff_t charpos = BUF_PT (b);
385 ptrdiff_t bytepos = BUF_PT_BYTE (b);
387 if (! NILP (BVAR (b, enable_multibyte_characters)))
388 BUF_DEC_POS (b, bytepos);
389 else
390 bytepos--;
392 SET_BUF_PT_BOTH (b, charpos - 1, bytepos);
394 else if (MARKERP (readcharfun))
396 struct buffer *b = XMARKER (readcharfun)->buffer;
397 ptrdiff_t bytepos = XMARKER (readcharfun)->bytepos;
399 XMARKER (readcharfun)->charpos--;
400 if (! NILP (BVAR (b, enable_multibyte_characters)))
401 BUF_DEC_POS (b, bytepos);
402 else
403 bytepos--;
405 XMARKER (readcharfun)->bytepos = bytepos;
407 else if (STRINGP (readcharfun))
409 read_from_string_index--;
410 read_from_string_index_byte
411 = string_char_to_byte (readcharfun, read_from_string_index);
413 else if (CONSP (readcharfun) && STRINGP (XCAR (readcharfun)))
415 unread_char = c;
417 else if (EQ (readcharfun, Qlambda))
419 unread_char = c;
421 else if (FROM_FILE_P (readcharfun))
423 unread_char = c;
425 else
426 call1 (readcharfun, make_number (c));
429 static int
430 readbyte_for_lambda (int c, Lisp_Object readcharfun)
432 return read_bytecode_char (c >= 0);
436 static int
437 readbyte_from_file (int c, Lisp_Object readcharfun)
439 if (c >= 0)
441 block_input ();
442 ungetc (c, instream);
443 unblock_input ();
444 return 0;
447 block_input ();
448 c = getc (instream);
450 /* Interrupted reads have been observed while reading over the network. */
451 while (c == EOF && ferror (instream) && errno == EINTR)
453 unblock_input ();
454 QUIT;
455 block_input ();
456 clearerr (instream);
457 c = getc (instream);
460 unblock_input ();
462 return (c == EOF ? -1 : c);
465 static int
466 readbyte_from_string (int c, Lisp_Object readcharfun)
468 Lisp_Object string = XCAR (readcharfun);
470 if (c >= 0)
472 read_from_string_index--;
473 read_from_string_index_byte
474 = string_char_to_byte (string, read_from_string_index);
477 if (read_from_string_index >= read_from_string_limit)
478 c = -1;
479 else
480 FETCH_STRING_CHAR_ADVANCE (c, string,
481 read_from_string_index,
482 read_from_string_index_byte);
483 return c;
487 /* Read one non-ASCII character from INSTREAM. The character is
488 encoded in `emacs-mule' and the first byte is already read in
489 C. */
491 static int
492 read_emacs_mule_char (int c, int (*readbyte) (int, Lisp_Object), Lisp_Object readcharfun)
494 /* Emacs-mule coding uses at most 4-byte for one character. */
495 unsigned char buf[4];
496 int len = emacs_mule_bytes[c];
497 struct charset *charset;
498 int i;
499 unsigned code;
501 if (len == 1)
502 /* C is not a valid leading-code of `emacs-mule'. */
503 return BYTE8_TO_CHAR (c);
505 i = 0;
506 buf[i++] = c;
507 while (i < len)
509 c = (*readbyte) (-1, readcharfun);
510 if (c < 0xA0)
512 while (--i > 1)
513 (*readbyte) (buf[i], readcharfun);
514 return BYTE8_TO_CHAR (buf[0]);
516 buf[i++] = c;
519 if (len == 2)
521 charset = CHARSET_FROM_ID (emacs_mule_charset[buf[0]]);
522 code = buf[1] & 0x7F;
524 else if (len == 3)
526 if (buf[0] == EMACS_MULE_LEADING_CODE_PRIVATE_11
527 || buf[0] == EMACS_MULE_LEADING_CODE_PRIVATE_12)
529 charset = CHARSET_FROM_ID (emacs_mule_charset[buf[1]]);
530 code = buf[2] & 0x7F;
532 else
534 charset = CHARSET_FROM_ID (emacs_mule_charset[buf[0]]);
535 code = ((buf[1] << 8) | buf[2]) & 0x7F7F;
538 else
540 charset = CHARSET_FROM_ID (emacs_mule_charset[buf[1]]);
541 code = ((buf[2] << 8) | buf[3]) & 0x7F7F;
543 c = DECODE_CHAR (charset, code);
544 if (c < 0)
545 Fsignal (Qinvalid_read_syntax,
546 list1 (build_string ("invalid multibyte form")));
547 return c;
551 static Lisp_Object read_internal_start (Lisp_Object, Lisp_Object,
552 Lisp_Object);
553 static Lisp_Object read0 (Lisp_Object);
554 static Lisp_Object read1 (Lisp_Object, int *, bool);
556 static Lisp_Object read_list (bool, Lisp_Object);
557 static Lisp_Object read_vector (Lisp_Object, bool);
559 static Lisp_Object substitute_object_recurse (Lisp_Object, Lisp_Object,
560 Lisp_Object);
561 static void substitute_object_in_subtree (Lisp_Object,
562 Lisp_Object);
563 static void substitute_in_interval (INTERVAL, Lisp_Object);
566 /* Get a character from the tty. */
568 /* Read input events until we get one that's acceptable for our purposes.
570 If NO_SWITCH_FRAME, switch-frame events are stashed
571 until we get a character we like, and then stuffed into
572 unread_switch_frame.
574 If ASCII_REQUIRED, check function key events to see
575 if the unmodified version of the symbol has a Qascii_character
576 property, and use that character, if present.
578 If ERROR_NONASCII, signal an error if the input we
579 get isn't an ASCII character with modifiers. If it's false but
580 ASCII_REQUIRED is true, just re-read until we get an ASCII
581 character.
583 If INPUT_METHOD, invoke the current input method
584 if the character warrants that.
586 If SECONDS is a number, wait that many seconds for input, and
587 return Qnil if no input arrives within that time. */
589 static Lisp_Object
590 read_filtered_event (bool no_switch_frame, bool ascii_required,
591 bool error_nonascii, bool input_method, Lisp_Object seconds)
593 Lisp_Object val, delayed_switch_frame;
594 struct timespec end_time;
596 #ifdef HAVE_WINDOW_SYSTEM
597 if (display_hourglass_p)
598 cancel_hourglass ();
599 #endif
601 delayed_switch_frame = Qnil;
603 /* Compute timeout. */
604 if (NUMBERP (seconds))
606 double duration = extract_float (seconds);
607 struct timespec wait_time = dtotimespec (duration);
608 end_time = timespec_add (current_timespec (), wait_time);
611 /* Read until we get an acceptable event. */
612 retry:
614 val = read_char (0, Qnil, (input_method ? Qnil : Qt), 0,
615 NUMBERP (seconds) ? &end_time : NULL);
616 while (INTEGERP (val) && XINT (val) == -2); /* wrong_kboard_jmpbuf */
618 if (BUFFERP (val))
619 goto retry;
621 /* `switch-frame' events are put off until after the next ASCII
622 character. This is better than signaling an error just because
623 the last characters were typed to a separate minibuffer frame,
624 for example. Eventually, some code which can deal with
625 switch-frame events will read it and process it. */
626 if (no_switch_frame
627 && EVENT_HAS_PARAMETERS (val)
628 && EQ (EVENT_HEAD_KIND (EVENT_HEAD (val)), Qswitch_frame))
630 delayed_switch_frame = val;
631 goto retry;
634 if (ascii_required && !(NUMBERP (seconds) && NILP (val)))
636 /* Convert certain symbols to their ASCII equivalents. */
637 if (SYMBOLP (val))
639 Lisp_Object tem, tem1;
640 tem = Fget (val, Qevent_symbol_element_mask);
641 if (!NILP (tem))
643 tem1 = Fget (Fcar (tem), Qascii_character);
644 /* Merge this symbol's modifier bits
645 with the ASCII equivalent of its basic code. */
646 if (!NILP (tem1))
647 XSETFASTINT (val, XINT (tem1) | XINT (Fcar (Fcdr (tem))));
651 /* If we don't have a character now, deal with it appropriately. */
652 if (!INTEGERP (val))
654 if (error_nonascii)
656 Vunread_command_events = list1 (val);
657 error ("Non-character input-event");
659 else
660 goto retry;
664 if (! NILP (delayed_switch_frame))
665 unread_switch_frame = delayed_switch_frame;
667 #if 0
669 #ifdef HAVE_WINDOW_SYSTEM
670 if (display_hourglass_p)
671 start_hourglass ();
672 #endif
674 #endif
676 return val;
679 DEFUN ("read-char", Fread_char, Sread_char, 0, 3, 0,
680 doc: /* Read a character from the command input (keyboard or macro).
681 It is returned as a number.
682 If the character has modifiers, they are resolved and reflected to the
683 character code if possible (e.g. C-SPC -> 0).
685 If the user generates an event which is not a character (i.e. a mouse
686 click or function key event), `read-char' signals an error. As an
687 exception, switch-frame events are put off until non-character events
688 can be read.
689 If you want to read non-character events, or ignore them, call
690 `read-event' or `read-char-exclusive' instead.
692 If the optional argument PROMPT is non-nil, display that as a prompt.
693 If the optional argument INHERIT-INPUT-METHOD is non-nil and some
694 input method is turned on in the current buffer, that input method
695 is used for reading a character.
696 If the optional argument SECONDS is non-nil, it should be a number
697 specifying the maximum number of seconds to wait for input. If no
698 input arrives in that time, return nil. SECONDS may be a
699 floating-point value. */)
700 (Lisp_Object prompt, Lisp_Object inherit_input_method, Lisp_Object seconds)
702 Lisp_Object val;
704 if (! NILP (prompt))
705 message_with_string ("%s", prompt, 0);
706 val = read_filtered_event (1, 1, 1, ! NILP (inherit_input_method), seconds);
708 return (NILP (val) ? Qnil
709 : make_number (char_resolve_modifier_mask (XINT (val))));
712 DEFUN ("read-event", Fread_event, Sread_event, 0, 3, 0,
713 doc: /* Read an event object from the input stream.
714 If the optional argument PROMPT is non-nil, display that as a prompt.
715 If the optional argument INHERIT-INPUT-METHOD is non-nil and some
716 input method is turned on in the current buffer, that input method
717 is used for reading a character.
718 If the optional argument SECONDS is non-nil, it should be a number
719 specifying the maximum number of seconds to wait for input. If no
720 input arrives in that time, return nil. SECONDS may be a
721 floating-point value. */)
722 (Lisp_Object prompt, Lisp_Object inherit_input_method, Lisp_Object seconds)
724 if (! NILP (prompt))
725 message_with_string ("%s", prompt, 0);
726 return read_filtered_event (0, 0, 0, ! NILP (inherit_input_method), seconds);
729 DEFUN ("read-char-exclusive", Fread_char_exclusive, Sread_char_exclusive, 0, 3, 0,
730 doc: /* Read a character from the command input (keyboard or macro).
731 It is returned as a number. Non-character events are ignored.
732 If the character has modifiers, they are resolved and reflected to the
733 character code if possible (e.g. C-SPC -> 0).
735 If the optional argument PROMPT is non-nil, display that as a prompt.
736 If the optional argument INHERIT-INPUT-METHOD is non-nil and some
737 input method is turned on in the current buffer, that input method
738 is used for reading a character.
739 If the optional argument SECONDS is non-nil, it should be a number
740 specifying the maximum number of seconds to wait for input. If no
741 input arrives in that time, return nil. SECONDS may be a
742 floating-point value. */)
743 (Lisp_Object prompt, Lisp_Object inherit_input_method, Lisp_Object seconds)
745 Lisp_Object val;
747 if (! NILP (prompt))
748 message_with_string ("%s", prompt, 0);
750 val = read_filtered_event (1, 1, 0, ! NILP (inherit_input_method), seconds);
752 return (NILP (val) ? Qnil
753 : make_number (char_resolve_modifier_mask (XINT (val))));
756 DEFUN ("get-file-char", Fget_file_char, Sget_file_char, 0, 0, 0,
757 doc: /* Don't use this yourself. */)
758 (void)
760 register Lisp_Object val;
761 block_input ();
762 XSETINT (val, getc (instream));
763 unblock_input ();
764 return val;
770 /* Return true if the lisp code read using READCHARFUN defines a non-nil
771 `lexical-binding' file variable. After returning, the stream is
772 positioned following the first line, if it is a comment or #! line,
773 otherwise nothing is read. */
775 static bool
776 lisp_file_lexically_bound_p (Lisp_Object readcharfun)
778 int ch = READCHAR;
780 if (ch == '#')
782 ch = READCHAR;
783 if (ch != '!')
785 UNREAD (ch);
786 UNREAD ('#');
787 return 0;
789 while (ch != '\n' && ch != EOF)
790 ch = READCHAR;
791 if (ch == '\n') ch = READCHAR;
792 /* It is OK to leave the position after a #! line, since
793 that is what read1 does. */
796 if (ch != ';')
797 /* The first line isn't a comment, just give up. */
799 UNREAD (ch);
800 return 0;
802 else
803 /* Look for an appropriate file-variable in the first line. */
805 bool rv = 0;
806 enum {
807 NOMINAL, AFTER_FIRST_DASH, AFTER_ASTERIX
808 } beg_end_state = NOMINAL;
809 bool in_file_vars = 0;
811 #define UPDATE_BEG_END_STATE(ch) \
812 if (beg_end_state == NOMINAL) \
813 beg_end_state = (ch == '-' ? AFTER_FIRST_DASH : NOMINAL); \
814 else if (beg_end_state == AFTER_FIRST_DASH) \
815 beg_end_state = (ch == '*' ? AFTER_ASTERIX : NOMINAL); \
816 else if (beg_end_state == AFTER_ASTERIX) \
818 if (ch == '-') \
819 in_file_vars = !in_file_vars; \
820 beg_end_state = NOMINAL; \
823 /* Skip until we get to the file vars, if any. */
826 ch = READCHAR;
827 UPDATE_BEG_END_STATE (ch);
829 while (!in_file_vars && ch != '\n' && ch != EOF);
831 while (in_file_vars)
833 char var[100], val[100];
834 unsigned i;
836 ch = READCHAR;
838 /* Read a variable name. */
839 while (ch == ' ' || ch == '\t')
840 ch = READCHAR;
842 i = 0;
843 while (ch != ':' && ch != '\n' && ch != EOF && in_file_vars)
845 if (i < sizeof var - 1)
846 var[i++] = ch;
847 UPDATE_BEG_END_STATE (ch);
848 ch = READCHAR;
851 /* Stop scanning if no colon was found before end marker. */
852 if (!in_file_vars || ch == '\n' || ch == EOF)
853 break;
855 while (i > 0 && (var[i - 1] == ' ' || var[i - 1] == '\t'))
856 i--;
857 var[i] = '\0';
859 if (ch == ':')
861 /* Read a variable value. */
862 ch = READCHAR;
864 while (ch == ' ' || ch == '\t')
865 ch = READCHAR;
867 i = 0;
868 while (ch != ';' && ch != '\n' && ch != EOF && in_file_vars)
870 if (i < sizeof val - 1)
871 val[i++] = ch;
872 UPDATE_BEG_END_STATE (ch);
873 ch = READCHAR;
875 if (! in_file_vars)
876 /* The value was terminated by an end-marker, which remove. */
877 i -= 3;
878 while (i > 0 && (val[i - 1] == ' ' || val[i - 1] == '\t'))
879 i--;
880 val[i] = '\0';
882 if (strcmp (var, "lexical-binding") == 0)
883 /* This is it... */
885 rv = (strcmp (val, "nil") != 0);
886 break;
891 while (ch != '\n' && ch != EOF)
892 ch = READCHAR;
894 return rv;
898 /* Value is a version number of byte compiled code if the file
899 associated with file descriptor FD is a compiled Lisp file that's
900 safe to load. Only files compiled with Emacs are safe to load.
901 Files compiled with XEmacs can lead to a crash in Fbyte_code
902 because of an incompatible change in the byte compiler. */
904 static int
905 safe_to_load_version (int fd)
907 char buf[512];
908 int nbytes, i;
909 int version = 1;
911 /* Read the first few bytes from the file, and look for a line
912 specifying the byte compiler version used. */
913 nbytes = emacs_read (fd, buf, sizeof buf);
914 if (nbytes > 0)
916 /* Skip to the next newline, skipping over the initial `ELC'
917 with NUL bytes following it, but note the version. */
918 for (i = 0; i < nbytes && buf[i] != '\n'; ++i)
919 if (i == 4)
920 version = buf[i];
922 if (i >= nbytes
923 || fast_c_string_match_ignore_case (Vbytecomp_version_regexp,
924 buf + i, nbytes - i) < 0)
925 version = 0;
928 lseek (fd, 0, SEEK_SET);
929 return version;
933 /* Callback for record_unwind_protect. Restore the old load list OLD,
934 after loading a file successfully. */
936 static void
937 record_load_unwind (Lisp_Object old)
939 Vloads_in_progress = old;
942 /* This handler function is used via internal_condition_case_1. */
944 static Lisp_Object
945 load_error_handler (Lisp_Object data)
947 return Qnil;
950 static void
951 load_warn_old_style_backquotes (Lisp_Object file)
953 if (!NILP (Vold_style_backquotes))
955 AUTO_STRING (format, "Loading `%s': old-style backquotes detected!");
956 CALLN (Fmessage, format, file);
960 DEFUN ("get-load-suffixes", Fget_load_suffixes, Sget_load_suffixes, 0, 0, 0,
961 doc: /* Return the suffixes that `load' should try if a suffix is \
962 required.
963 This uses the variables `load-suffixes' and `load-file-rep-suffixes'. */)
964 (void)
966 Lisp_Object lst = Qnil, suffixes = Vload_suffixes, suffix, ext;
967 while (CONSP (suffixes))
969 Lisp_Object exts = Vload_file_rep_suffixes;
970 suffix = XCAR (suffixes);
971 suffixes = XCDR (suffixes);
972 while (CONSP (exts))
974 ext = XCAR (exts);
975 exts = XCDR (exts);
976 lst = Fcons (concat2 (suffix, ext), lst);
979 return Fnreverse (lst);
982 /* Returns true if STRING ends with SUFFIX */
983 static bool
984 suffix_p (Lisp_Object string, const char *suffix)
986 ptrdiff_t suffix_len = strlen (suffix);
987 ptrdiff_t string_len = SBYTES (string);
989 return string_len >= suffix_len && !strcmp (SSDATA (string) + string_len - suffix_len, suffix);
992 DEFUN ("load", Fload, Sload, 1, 5, 0,
993 doc: /* Execute a file of Lisp code named FILE.
994 First try FILE with `.elc' appended, then try with `.el', then try
995 with a system-dependent suffix of dynamic modules (see `load-suffixes'),
996 then try FILE unmodified (the exact suffixes in the exact order are
997 determined by `load-suffixes'). Environment variable references in
998 FILE are replaced with their values by calling `substitute-in-file-name'.
999 This function searches the directories in `load-path'.
1001 If optional second arg NOERROR is non-nil,
1002 report no error if FILE doesn't exist.
1003 Print messages at start and end of loading unless
1004 optional third arg NOMESSAGE is non-nil (but `force-load-messages'
1005 overrides that).
1006 If optional fourth arg NOSUFFIX is non-nil, don't try adding
1007 suffixes to the specified name FILE.
1008 If optional fifth arg MUST-SUFFIX is non-nil, insist on
1009 the suffix `.elc' or `.el' or the module suffix; don't accept just
1010 FILE unless it ends in one of those suffixes or includes a directory name.
1012 If NOSUFFIX is nil, then if a file could not be found, try looking for
1013 a different representation of the file by adding non-empty suffixes to
1014 its name, before trying another file. Emacs uses this feature to find
1015 compressed versions of files when Auto Compression mode is enabled.
1016 If NOSUFFIX is non-nil, disable this feature.
1018 The suffixes that this function tries out, when NOSUFFIX is nil, are
1019 given by the return value of `get-load-suffixes' and the values listed
1020 in `load-file-rep-suffixes'. If MUST-SUFFIX is non-nil, only the
1021 return value of `get-load-suffixes' is used, i.e. the file name is
1022 required to have a non-empty suffix.
1024 When searching suffixes, this function normally stops at the first
1025 one that exists. If the option `load-prefer-newer' is non-nil,
1026 however, it tries all suffixes, and uses whichever file is the newest.
1028 Loading a file records its definitions, and its `provide' and
1029 `require' calls, in an element of `load-history' whose
1030 car is the file name loaded. See `load-history'.
1032 While the file is in the process of being loaded, the variable
1033 `load-in-progress' is non-nil and the variable `load-file-name'
1034 is bound to the file's name.
1036 Return t if the file exists and loads successfully. */)
1037 (Lisp_Object file, Lisp_Object noerror, Lisp_Object nomessage,
1038 Lisp_Object nosuffix, Lisp_Object must_suffix)
1040 FILE *stream;
1041 int fd;
1042 int fd_index UNINIT;
1043 ptrdiff_t count = SPECPDL_INDEX ();
1044 Lisp_Object found, efound, hist_file_name;
1045 /* True means we printed the ".el is newer" message. */
1046 bool newer = 0;
1047 /* True means we are loading a compiled file. */
1048 bool compiled = 0;
1049 Lisp_Object handler;
1050 bool safe_p = 1;
1051 const char *fmode = "r" FOPEN_TEXT;
1052 int version;
1054 CHECK_STRING (file);
1056 /* If file name is magic, call the handler. */
1057 /* This shouldn't be necessary any more now that `openp' handles it right.
1058 handler = Ffind_file_name_handler (file, Qload);
1059 if (!NILP (handler))
1060 return call5 (handler, Qload, file, noerror, nomessage, nosuffix); */
1062 /* The presence of this call is the result of a historical accident:
1063 it used to be in every file-operation and when it got removed
1064 everywhere, it accidentally stayed here. Since then, enough people
1065 supposedly have things like (load "$PROJECT/foo.el") in their .emacs
1066 that it seemed risky to remove. */
1067 if (! NILP (noerror))
1069 file = internal_condition_case_1 (Fsubstitute_in_file_name, file,
1070 Qt, load_error_handler);
1071 if (NILP (file))
1072 return Qnil;
1074 else
1075 file = Fsubstitute_in_file_name (file);
1077 /* Avoid weird lossage with null string as arg,
1078 since it would try to load a directory as a Lisp file. */
1079 if (SCHARS (file) == 0)
1081 fd = -1;
1082 errno = ENOENT;
1084 else
1086 Lisp_Object suffixes;
1087 found = Qnil;
1089 if (! NILP (must_suffix))
1091 /* Don't insist on adding a suffix if FILE already ends with one. */
1092 if (suffix_p (file, ".el")
1093 || suffix_p (file, ".elc")
1094 #ifdef HAVE_MODULES
1095 || suffix_p (file, MODULES_SUFFIX)
1096 #endif
1098 must_suffix = Qnil;
1099 /* Don't insist on adding a suffix
1100 if the argument includes a directory name. */
1101 else if (! NILP (Ffile_name_directory (file)))
1102 must_suffix = Qnil;
1105 if (!NILP (nosuffix))
1106 suffixes = Qnil;
1107 else
1109 suffixes = Fget_load_suffixes ();
1110 if (NILP (must_suffix))
1111 suffixes = CALLN (Fappend, suffixes, Vload_file_rep_suffixes);
1114 fd = openp (Vload_path, file, suffixes, &found, Qnil, load_prefer_newer);
1117 if (fd == -1)
1119 if (NILP (noerror))
1120 report_file_error ("Cannot open load file", file);
1121 return Qnil;
1124 /* Tell startup.el whether or not we found the user's init file. */
1125 if (EQ (Qt, Vuser_init_file))
1126 Vuser_init_file = found;
1128 /* If FD is -2, that means openp found a magic file. */
1129 if (fd == -2)
1131 if (NILP (Fequal (found, file)))
1132 /* If FOUND is a different file name from FILE,
1133 find its handler even if we have already inhibited
1134 the `load' operation on FILE. */
1135 handler = Ffind_file_name_handler (found, Qt);
1136 else
1137 handler = Ffind_file_name_handler (found, Qload);
1138 if (! NILP (handler))
1139 return call5 (handler, Qload, found, noerror, nomessage, Qt);
1140 #ifdef DOS_NT
1141 /* Tramp has to deal with semi-broken packages that prepend
1142 drive letters to remote files. For that reason, Tramp
1143 catches file operations that test for file existence, which
1144 makes openp think X:/foo.elc files are remote. However,
1145 Tramp does not catch `load' operations for such files, so we
1146 end up with a nil as the `load' handler above. If we would
1147 continue with fd = -2, we will behave wrongly, and in
1148 particular try reading a .elc file in the "rt" mode instead
1149 of "rb". See bug #9311 for the results. To work around
1150 this, we try to open the file locally, and go with that if it
1151 succeeds. */
1152 fd = emacs_open (SSDATA (ENCODE_FILE (found)), O_RDONLY, 0);
1153 if (fd == -1)
1154 fd = -2;
1155 #endif
1158 if (0 <= fd)
1160 fd_index = SPECPDL_INDEX ();
1161 record_unwind_protect_int (close_file_unwind, fd);
1164 #ifdef HAVE_MODULES
1165 if (suffix_p (found, MODULES_SUFFIX))
1166 return unbind_to (count, Fmodule_load (found));
1167 #endif
1169 /* Check if we're stuck in a recursive load cycle.
1171 2000-09-21: It's not possible to just check for the file loaded
1172 being a member of Vloads_in_progress. This fails because of the
1173 way the byte compiler currently works; `provide's are not
1174 evaluated, see font-lock.el/jit-lock.el as an example. This
1175 leads to a certain amount of ``normal'' recursion.
1177 Also, just loading a file recursively is not always an error in
1178 the general case; the second load may do something different. */
1180 int load_count = 0;
1181 Lisp_Object tem;
1182 for (tem = Vloads_in_progress; CONSP (tem); tem = XCDR (tem))
1183 if (!NILP (Fequal (found, XCAR (tem))) && (++load_count > 3))
1184 signal_error ("Recursive load", Fcons (found, Vloads_in_progress));
1185 record_unwind_protect (record_load_unwind, Vloads_in_progress);
1186 Vloads_in_progress = Fcons (found, Vloads_in_progress);
1189 /* All loads are by default dynamic, unless the file itself specifies
1190 otherwise using a file-variable in the first line. This is bound here
1191 so that it takes effect whether or not we use
1192 Vload_source_file_function. */
1193 specbind (Qlexical_binding, Qnil);
1195 /* Get the name for load-history. */
1196 hist_file_name = (! NILP (Vpurify_flag)
1197 ? concat2 (Ffile_name_directory (file),
1198 Ffile_name_nondirectory (found))
1199 : found) ;
1201 version = -1;
1203 /* Check for the presence of old-style quotes and warn about them. */
1204 specbind (Qold_style_backquotes, Qnil);
1205 record_unwind_protect (load_warn_old_style_backquotes, file);
1207 int is_elc;
1208 if ((is_elc = suffix_p (found, ".elc")) != 0
1209 /* version = 1 means the file is empty, in which case we can
1210 treat it as not byte-compiled. */
1211 || (fd >= 0 && (version = safe_to_load_version (fd)) > 1))
1212 /* Load .elc files directly, but not when they are
1213 remote and have no handler! */
1215 if (fd != -2)
1217 struct stat s1, s2;
1218 int result;
1220 if (version < 0
1221 && ! (version = safe_to_load_version (fd)))
1223 safe_p = 0;
1224 if (!load_dangerous_libraries)
1225 error ("File `%s' was not compiled in Emacs", SDATA (found));
1226 else if (!NILP (nomessage) && !force_load_messages)
1227 message_with_string ("File `%s' not compiled in Emacs", found, 1);
1230 compiled = 1;
1232 efound = ENCODE_FILE (found);
1233 fmode = "r" FOPEN_BINARY;
1235 /* openp already checked for newness, no point doing it again.
1236 FIXME would be nice to get a message when openp
1237 ignores suffix order due to load_prefer_newer. */
1238 if (!load_prefer_newer && is_elc)
1240 result = stat (SSDATA (efound), &s1);
1241 if (result == 0)
1243 SSET (efound, SBYTES (efound) - 1, 0);
1244 result = stat (SSDATA (efound), &s2);
1245 SSET (efound, SBYTES (efound) - 1, 'c');
1248 if (result == 0
1249 && timespec_cmp (get_stat_mtime (&s1), get_stat_mtime (&s2)) < 0)
1251 /* Make the progress messages mention that source is newer. */
1252 newer = 1;
1254 /* If we won't print another message, mention this anyway. */
1255 if (!NILP (nomessage) && !force_load_messages)
1257 Lisp_Object msg_file;
1258 msg_file = Fsubstring (found, make_number (0), make_number (-1));
1259 message_with_string ("Source file `%s' newer than byte-compiled file",
1260 msg_file, 1);
1263 } /* !load_prefer_newer */
1266 else
1268 /* We are loading a source file (*.el). */
1269 if (!NILP (Vload_source_file_function))
1271 Lisp_Object val;
1273 if (fd >= 0)
1275 emacs_close (fd);
1276 clear_unwind_protect (fd_index);
1278 val = call4 (Vload_source_file_function, found, hist_file_name,
1279 NILP (noerror) ? Qnil : Qt,
1280 (NILP (nomessage) || force_load_messages) ? Qnil : Qt);
1281 return unbind_to (count, val);
1285 if (fd < 0)
1287 /* We somehow got here with fd == -2, meaning the file is deemed
1288 to be remote. Don't even try to reopen the file locally;
1289 just force a failure. */
1290 stream = NULL;
1291 errno = EINVAL;
1293 else
1295 #ifdef WINDOWSNT
1296 emacs_close (fd);
1297 clear_unwind_protect (fd_index);
1298 efound = ENCODE_FILE (found);
1299 stream = emacs_fopen (SSDATA (efound), fmode);
1300 #else
1301 stream = fdopen (fd, fmode);
1302 #endif
1304 if (! stream)
1305 report_file_error ("Opening stdio stream", file);
1306 set_unwind_protect_ptr (fd_index, fclose_unwind, stream);
1308 if (! NILP (Vpurify_flag))
1309 Vpreloaded_file_list = Fcons (Fpurecopy (file), Vpreloaded_file_list);
1311 if (NILP (nomessage) || force_load_messages)
1313 if (!safe_p)
1314 message_with_string ("Loading %s (compiled; note unsafe, not compiled in Emacs)...",
1315 file, 1);
1316 else if (!compiled)
1317 message_with_string ("Loading %s (source)...", file, 1);
1318 else if (newer)
1319 message_with_string ("Loading %s (compiled; note, source file is newer)...",
1320 file, 1);
1321 else /* The typical case; compiled file newer than source file. */
1322 message_with_string ("Loading %s...", file, 1);
1325 specbind (Qload_file_name, found);
1326 specbind (Qinhibit_file_name_operation, Qnil);
1327 specbind (Qload_in_progress, Qt);
1329 instream = stream;
1330 if (lisp_file_lexically_bound_p (Qget_file_char))
1331 Fset (Qlexical_binding, Qt);
1333 if (! version || version >= 22)
1334 readevalloop (Qget_file_char, stream, hist_file_name,
1335 0, Qnil, Qnil, Qnil, Qnil);
1336 else
1338 /* We can't handle a file which was compiled with
1339 byte-compile-dynamic by older version of Emacs. */
1340 specbind (Qload_force_doc_strings, Qt);
1341 readevalloop (Qget_emacs_mule_file_char, stream, hist_file_name,
1342 0, Qnil, Qnil, Qnil, Qnil);
1344 unbind_to (count, Qnil);
1346 /* Run any eval-after-load forms for this file. */
1347 if (!NILP (Ffboundp (Qdo_after_load_evaluation)))
1348 call1 (Qdo_after_load_evaluation, hist_file_name) ;
1350 xfree (saved_doc_string);
1351 saved_doc_string = 0;
1352 saved_doc_string_size = 0;
1354 xfree (prev_saved_doc_string);
1355 prev_saved_doc_string = 0;
1356 prev_saved_doc_string_size = 0;
1358 if (!noninteractive && (NILP (nomessage) || force_load_messages))
1360 if (!safe_p)
1361 message_with_string ("Loading %s (compiled; note unsafe, not compiled in Emacs)...done",
1362 file, 1);
1363 else if (!compiled)
1364 message_with_string ("Loading %s (source)...done", file, 1);
1365 else if (newer)
1366 message_with_string ("Loading %s (compiled; note, source file is newer)...done",
1367 file, 1);
1368 else /* The typical case; compiled file newer than source file. */
1369 message_with_string ("Loading %s...done", file, 1);
1372 return Qt;
1375 static bool
1376 complete_filename_p (Lisp_Object pathname)
1378 const unsigned char *s = SDATA (pathname);
1379 return (IS_DIRECTORY_SEP (s[0])
1380 || (SCHARS (pathname) > 2
1381 && IS_DEVICE_SEP (s[1]) && IS_DIRECTORY_SEP (s[2])));
1384 DEFUN ("locate-file-internal", Flocate_file_internal, Slocate_file_internal, 2, 4, 0,
1385 doc: /* Search for FILENAME through PATH.
1386 Returns the file's name in absolute form, or nil if not found.
1387 If SUFFIXES is non-nil, it should be a list of suffixes to append to
1388 file name when searching.
1389 If non-nil, PREDICATE is used instead of `file-readable-p'.
1390 PREDICATE can also be an integer to pass to the faccessat(2) function,
1391 in which case file-name-handlers are ignored.
1392 This function will normally skip directories, so if you want it to find
1393 directories, make sure the PREDICATE function returns `dir-ok' for them. */)
1394 (Lisp_Object filename, Lisp_Object path, Lisp_Object suffixes, Lisp_Object predicate)
1396 Lisp_Object file;
1397 int fd = openp (path, filename, suffixes, &file, predicate, false);
1398 if (NILP (predicate) && fd >= 0)
1399 emacs_close (fd);
1400 return file;
1403 /* Search for a file whose name is STR, looking in directories
1404 in the Lisp list PATH, and trying suffixes from SUFFIX.
1405 On success, return a file descriptor (or 1 or -2 as described below).
1406 On failure, return -1 and set errno.
1408 SUFFIXES is a list of strings containing possible suffixes.
1409 The empty suffix is automatically added if the list is empty.
1411 PREDICATE t means the files are binary.
1412 PREDICATE non-nil and non-t means don't open the files,
1413 just look for one that satisfies the predicate. In this case,
1414 return 1 on success. The predicate can be a lisp function or
1415 an integer to pass to `access' (in which case file-name-handlers
1416 are ignored).
1418 If STOREPTR is nonzero, it points to a slot where the name of
1419 the file actually found should be stored as a Lisp string.
1420 nil is stored there on failure.
1422 If the file we find is remote, return -2
1423 but store the found remote file name in *STOREPTR.
1425 If NEWER is true, try all SUFFIXes and return the result for the
1426 newest file that exists. Does not apply to remote files,
1427 or if a non-nil and non-t PREDICATE is specified. */
1430 openp (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes,
1431 Lisp_Object *storeptr, Lisp_Object predicate, bool newer)
1433 ptrdiff_t fn_size = 100;
1434 char buf[100];
1435 char *fn = buf;
1436 bool absolute;
1437 ptrdiff_t want_length;
1438 Lisp_Object filename;
1439 Lisp_Object string, tail, encoded_fn, save_string;
1440 ptrdiff_t max_suffix_len = 0;
1441 int last_errno = ENOENT;
1442 int save_fd = -1;
1443 USE_SAFE_ALLOCA;
1445 /* The last-modified time of the newest matching file found.
1446 Initialize it to something less than all valid timestamps. */
1447 struct timespec save_mtime = make_timespec (TYPE_MINIMUM (time_t), -1);
1449 CHECK_STRING (str);
1451 for (tail = suffixes; CONSP (tail); tail = XCDR (tail))
1453 CHECK_STRING_CAR (tail);
1454 max_suffix_len = max (max_suffix_len,
1455 SBYTES (XCAR (tail)));
1458 string = filename = encoded_fn = save_string = Qnil;
1460 if (storeptr)
1461 *storeptr = Qnil;
1463 absolute = complete_filename_p (str);
1465 for (; CONSP (path); path = XCDR (path))
1467 ptrdiff_t baselen, prefixlen;
1469 filename = Fexpand_file_name (str, XCAR (path));
1470 if (!complete_filename_p (filename))
1471 /* If there are non-absolute elts in PATH (eg "."). */
1472 /* Of course, this could conceivably lose if luser sets
1473 default-directory to be something non-absolute... */
1475 filename = Fexpand_file_name (filename, BVAR (current_buffer, directory));
1476 if (!complete_filename_p (filename))
1477 /* Give up on this path element! */
1478 continue;
1481 /* Calculate maximum length of any filename made from
1482 this path element/specified file name and any possible suffix. */
1483 want_length = max_suffix_len + SBYTES (filename);
1484 if (fn_size <= want_length)
1486 fn_size = 100 + want_length;
1487 fn = SAFE_ALLOCA (fn_size);
1490 /* Copy FILENAME's data to FN but remove starting /: if any. */
1491 prefixlen = ((SCHARS (filename) > 2
1492 && SREF (filename, 0) == '/'
1493 && SREF (filename, 1) == ':')
1494 ? 2 : 0);
1495 baselen = SBYTES (filename) - prefixlen;
1496 memcpy (fn, SDATA (filename) + prefixlen, baselen);
1498 /* Loop over suffixes. */
1499 for (tail = NILP (suffixes) ? list1 (empty_unibyte_string) : suffixes;
1500 CONSP (tail); tail = XCDR (tail))
1502 Lisp_Object suffix = XCAR (tail);
1503 ptrdiff_t fnlen, lsuffix = SBYTES (suffix);
1504 Lisp_Object handler;
1506 /* Make complete filename by appending SUFFIX. */
1507 memcpy (fn + baselen, SDATA (suffix), lsuffix + 1);
1508 fnlen = baselen + lsuffix;
1510 /* Check that the file exists and is not a directory. */
1511 /* We used to only check for handlers on non-absolute file names:
1512 if (absolute)
1513 handler = Qnil;
1514 else
1515 handler = Ffind_file_name_handler (filename, Qfile_exists_p);
1516 It's not clear why that was the case and it breaks things like
1517 (load "/bar.el") where the file is actually "/bar.el.gz". */
1518 /* make_string has its own ideas on when to return a unibyte
1519 string and when a multibyte string, but we know better.
1520 We must have a unibyte string when dumping, since
1521 file-name encoding is shaky at best at that time, and in
1522 particular default-file-name-coding-system is reset
1523 several times during loadup. We therefore don't want to
1524 encode the file before passing it to file I/O library
1525 functions. */
1526 if (!STRING_MULTIBYTE (filename) && !STRING_MULTIBYTE (suffix))
1527 string = make_unibyte_string (fn, fnlen);
1528 else
1529 string = make_string (fn, fnlen);
1530 handler = Ffind_file_name_handler (string, Qfile_exists_p);
1531 if ((!NILP (handler) || (!NILP (predicate) && !EQ (predicate, Qt)))
1532 && !NATNUMP (predicate))
1534 bool exists;
1535 if (NILP (predicate) || EQ (predicate, Qt))
1536 exists = !NILP (Ffile_readable_p (string));
1537 else
1539 Lisp_Object tmp = call1 (predicate, string);
1540 if (NILP (tmp))
1541 exists = false;
1542 else if (EQ (tmp, Qdir_ok)
1543 || NILP (Ffile_directory_p (string)))
1544 exists = true;
1545 else
1547 exists = false;
1548 last_errno = EISDIR;
1552 if (exists)
1554 /* We succeeded; return this descriptor and filename. */
1555 if (storeptr)
1556 *storeptr = string;
1557 SAFE_FREE ();
1558 return -2;
1561 else
1563 int fd;
1564 const char *pfn;
1565 struct stat st;
1567 encoded_fn = ENCODE_FILE (string);
1568 pfn = SSDATA (encoded_fn);
1570 /* Check that we can access or open it. */
1571 if (NATNUMP (predicate))
1573 fd = -1;
1574 if (INT_MAX < XFASTINT (predicate))
1575 last_errno = EINVAL;
1576 else if (faccessat (AT_FDCWD, pfn, XFASTINT (predicate),
1577 AT_EACCESS)
1578 == 0)
1580 if (file_directory_p (pfn))
1581 last_errno = EISDIR;
1582 else
1583 fd = 1;
1586 else
1588 fd = emacs_open (pfn, O_RDONLY, 0);
1589 if (fd < 0)
1591 if (errno != ENOENT)
1592 last_errno = errno;
1594 else
1596 int err = (fstat (fd, &st) != 0 ? errno
1597 : S_ISDIR (st.st_mode) ? EISDIR : 0);
1598 if (err)
1600 last_errno = err;
1601 emacs_close (fd);
1602 fd = -1;
1607 if (fd >= 0)
1609 if (newer && !NATNUMP (predicate))
1611 struct timespec mtime = get_stat_mtime (&st);
1613 if (timespec_cmp (mtime, save_mtime) <= 0)
1614 emacs_close (fd);
1615 else
1617 if (0 <= save_fd)
1618 emacs_close (save_fd);
1619 save_fd = fd;
1620 save_mtime = mtime;
1621 save_string = string;
1624 else
1626 /* We succeeded; return this descriptor and filename. */
1627 if (storeptr)
1628 *storeptr = string;
1629 SAFE_FREE ();
1630 return fd;
1634 /* No more suffixes. Return the newest. */
1635 if (0 <= save_fd && ! CONSP (XCDR (tail)))
1637 if (storeptr)
1638 *storeptr = save_string;
1639 SAFE_FREE ();
1640 return save_fd;
1644 if (absolute)
1645 break;
1648 SAFE_FREE ();
1649 errno = last_errno;
1650 return -1;
1654 /* Merge the list we've accumulated of globals from the current input source
1655 into the load_history variable. The details depend on whether
1656 the source has an associated file name or not.
1658 FILENAME is the file name that we are loading from.
1660 ENTIRE is true if loading that entire file, false if evaluating
1661 part of it. */
1663 static void
1664 build_load_history (Lisp_Object filename, bool entire)
1666 Lisp_Object tail, prev, newelt;
1667 Lisp_Object tem, tem2;
1668 bool foundit = 0;
1670 tail = Vload_history;
1671 prev = Qnil;
1673 while (CONSP (tail))
1675 tem = XCAR (tail);
1677 /* Find the feature's previous assoc list... */
1678 if (!NILP (Fequal (filename, Fcar (tem))))
1680 foundit = 1;
1682 /* If we're loading the entire file, remove old data. */
1683 if (entire)
1685 if (NILP (prev))
1686 Vload_history = XCDR (tail);
1687 else
1688 Fsetcdr (prev, XCDR (tail));
1691 /* Otherwise, cons on new symbols that are not already members. */
1692 else
1694 tem2 = Vcurrent_load_list;
1696 while (CONSP (tem2))
1698 newelt = XCAR (tem2);
1700 if (NILP (Fmember (newelt, tem)))
1701 Fsetcar (tail, Fcons (XCAR (tem),
1702 Fcons (newelt, XCDR (tem))));
1704 tem2 = XCDR (tem2);
1705 QUIT;
1709 else
1710 prev = tail;
1711 tail = XCDR (tail);
1712 QUIT;
1715 /* If we're loading an entire file, cons the new assoc onto the
1716 front of load-history, the most-recently-loaded position. Also
1717 do this if we didn't find an existing member for the file. */
1718 if (entire || !foundit)
1719 Vload_history = Fcons (Fnreverse (Vcurrent_load_list),
1720 Vload_history);
1723 static void
1724 readevalloop_1 (int old)
1726 load_convert_to_unibyte = old;
1729 /* Signal an `end-of-file' error, if possible with file name
1730 information. */
1732 static _Noreturn void
1733 end_of_file_error (void)
1735 if (STRINGP (Vload_file_name))
1736 xsignal1 (Qend_of_file, Vload_file_name);
1738 xsignal0 (Qend_of_file);
1741 static Lisp_Object
1742 readevalloop_eager_expand_eval (Lisp_Object val, Lisp_Object macroexpand)
1744 /* If we macroexpand the toplevel form non-recursively and it ends
1745 up being a `progn' (or if it was a progn to start), treat each
1746 form in the progn as a top-level form. This way, if one form in
1747 the progn defines a macro, that macro is in effect when we expand
1748 the remaining forms. See similar code in bytecomp.el. */
1749 val = call2 (macroexpand, val, Qnil);
1750 if (EQ (CAR_SAFE (val), Qprogn))
1752 Lisp_Object subforms = XCDR (val);
1754 for (val = Qnil; CONSP (subforms); subforms = XCDR (subforms))
1755 val = readevalloop_eager_expand_eval (XCAR (subforms),
1756 macroexpand);
1758 else
1759 val = eval_sub (call2 (macroexpand, val, Qt));
1760 return val;
1763 /* UNIBYTE specifies how to set load_convert_to_unibyte
1764 for this invocation.
1765 READFUN, if non-nil, is used instead of `read'.
1767 START, END specify region to read in current buffer (from eval-region).
1768 If the input is not from a buffer, they must be nil. */
1770 static void
1771 readevalloop (Lisp_Object readcharfun,
1772 FILE *stream,
1773 Lisp_Object sourcename,
1774 bool printflag,
1775 Lisp_Object unibyte, Lisp_Object readfun,
1776 Lisp_Object start, Lisp_Object end)
1778 int c;
1779 Lisp_Object val;
1780 ptrdiff_t count = SPECPDL_INDEX ();
1781 struct buffer *b = 0;
1782 bool continue_reading_p;
1783 Lisp_Object lex_bound;
1784 /* True if reading an entire buffer. */
1785 bool whole_buffer = 0;
1786 /* True on the first time around. */
1787 bool first_sexp = 1;
1788 Lisp_Object macroexpand = intern ("internal-macroexpand-for-load");
1790 if (NILP (Ffboundp (macroexpand))
1791 /* Don't macroexpand in .elc files, since it should have been done
1792 already. We actually don't know whether we're in a .elc file or not,
1793 so we use circumstantial evidence: .el files normally go through
1794 Vload_source_file_function -> load-with-code-conversion
1795 -> eval-buffer. */
1796 || EQ (readcharfun, Qget_file_char)
1797 || EQ (readcharfun, Qget_emacs_mule_file_char))
1798 macroexpand = Qnil;
1800 if (MARKERP (readcharfun))
1802 if (NILP (start))
1803 start = readcharfun;
1806 if (BUFFERP (readcharfun))
1807 b = XBUFFER (readcharfun);
1808 else if (MARKERP (readcharfun))
1809 b = XMARKER (readcharfun)->buffer;
1811 /* We assume START is nil when input is not from a buffer. */
1812 if (! NILP (start) && !b)
1813 emacs_abort ();
1815 specbind (Qstandard_input, readcharfun);
1816 specbind (Qcurrent_load_list, Qnil);
1817 record_unwind_protect_int (readevalloop_1, load_convert_to_unibyte);
1818 load_convert_to_unibyte = !NILP (unibyte);
1820 /* If lexical binding is active (either because it was specified in
1821 the file's header, or via a buffer-local variable), create an empty
1822 lexical environment, otherwise, turn off lexical binding. */
1823 lex_bound = find_symbol_value (Qlexical_binding);
1824 specbind (Qinternal_interpreter_environment,
1825 (NILP (lex_bound) || EQ (lex_bound, Qunbound)
1826 ? Qnil : list1 (Qt)));
1828 /* Try to ensure sourcename is a truename, except whilst preloading. */
1829 if (NILP (Vpurify_flag)
1830 && !NILP (sourcename) && !NILP (Ffile_name_absolute_p (sourcename))
1831 && !NILP (Ffboundp (Qfile_truename)))
1832 sourcename = call1 (Qfile_truename, sourcename) ;
1834 LOADHIST_ATTACH (sourcename);
1836 continue_reading_p = 1;
1837 while (continue_reading_p)
1839 ptrdiff_t count1 = SPECPDL_INDEX ();
1841 if (b != 0 && !BUFFER_LIVE_P (b))
1842 error ("Reading from killed buffer");
1844 if (!NILP (start))
1846 /* Switch to the buffer we are reading from. */
1847 record_unwind_protect (save_excursion_restore, save_excursion_save ());
1848 set_buffer_internal (b);
1850 /* Save point in it. */
1851 record_unwind_protect (save_excursion_restore, save_excursion_save ());
1852 /* Save ZV in it. */
1853 record_unwind_protect (save_restriction_restore, save_restriction_save ());
1854 /* Those get unbound after we read one expression. */
1856 /* Set point and ZV around stuff to be read. */
1857 Fgoto_char (start);
1858 if (!NILP (end))
1859 Fnarrow_to_region (make_number (BEGV), end);
1861 /* Just for cleanliness, convert END to a marker
1862 if it is an integer. */
1863 if (INTEGERP (end))
1864 end = Fpoint_max_marker ();
1867 /* On the first cycle, we can easily test here
1868 whether we are reading the whole buffer. */
1869 if (b && first_sexp)
1870 whole_buffer = (PT == BEG && ZV == Z);
1872 instream = stream;
1873 read_next:
1874 c = READCHAR;
1875 if (c == ';')
1877 while ((c = READCHAR) != '\n' && c != -1);
1878 goto read_next;
1880 if (c < 0)
1882 unbind_to (count1, Qnil);
1883 break;
1886 /* Ignore whitespace here, so we can detect eof. */
1887 if (c == ' ' || c == '\t' || c == '\n' || c == '\f' || c == '\r'
1888 || c == NO_BREAK_SPACE)
1889 goto read_next;
1891 if (!NILP (Vpurify_flag) && c == '(')
1893 val = read_list (0, readcharfun);
1895 else
1897 UNREAD (c);
1898 read_objects = Qnil;
1899 if (!NILP (readfun))
1901 val = call1 (readfun, readcharfun);
1903 /* If READCHARFUN has set point to ZV, we should
1904 stop reading, even if the form read sets point
1905 to a different value when evaluated. */
1906 if (BUFFERP (readcharfun))
1908 struct buffer *buf = XBUFFER (readcharfun);
1909 if (BUF_PT (buf) == BUF_ZV (buf))
1910 continue_reading_p = 0;
1913 else if (! NILP (Vload_read_function))
1914 val = call1 (Vload_read_function, readcharfun);
1915 else
1916 val = read_internal_start (readcharfun, Qnil, Qnil);
1919 if (!NILP (start) && continue_reading_p)
1920 start = Fpoint_marker ();
1922 /* Restore saved point and BEGV. */
1923 unbind_to (count1, Qnil);
1925 /* Now eval what we just read. */
1926 if (!NILP (macroexpand))
1927 val = readevalloop_eager_expand_eval (val, macroexpand);
1928 else
1929 val = eval_sub (val);
1931 if (printflag)
1933 Vvalues = Fcons (val, Vvalues);
1934 if (EQ (Vstandard_output, Qt))
1935 Fprin1 (val, Qnil);
1936 else
1937 Fprint (val, Qnil);
1940 first_sexp = 0;
1943 build_load_history (sourcename,
1944 stream || whole_buffer);
1946 unbind_to (count, Qnil);
1949 DEFUN ("eval-buffer", Feval_buffer, Seval_buffer, 0, 5, "",
1950 doc: /* Execute the accessible portion of current buffer as Lisp code.
1951 You can use \\[narrow-to-region] to limit the part of buffer to be evaluated.
1952 When called from a Lisp program (i.e., not interactively), this
1953 function accepts up to five optional arguments:
1954 BUFFER is the buffer to evaluate (nil means use current buffer),
1955 or a name of a buffer (a string).
1956 PRINTFLAG controls printing of output by any output functions in the
1957 evaluated code, such as `print', `princ', and `prin1':
1958 a value of nil means discard it; anything else is the stream to print to.
1959 See Info node `(elisp)Output Streams' for details on streams.
1960 FILENAME specifies the file name to use for `load-history'.
1961 UNIBYTE, if non-nil, specifies `load-convert-to-unibyte' for this
1962 invocation.
1963 DO-ALLOW-PRINT, if non-nil, specifies that output functions in the
1964 evaluated code should work normally even if PRINTFLAG is nil, in
1965 which case the output is displayed in the echo area.
1967 This function preserves the position of point. */)
1968 (Lisp_Object buffer, Lisp_Object printflag, Lisp_Object filename, Lisp_Object unibyte, Lisp_Object do_allow_print)
1970 ptrdiff_t count = SPECPDL_INDEX ();
1971 Lisp_Object tem, buf;
1973 if (NILP (buffer))
1974 buf = Fcurrent_buffer ();
1975 else
1976 buf = Fget_buffer (buffer);
1977 if (NILP (buf))
1978 error ("No such buffer");
1980 if (NILP (printflag) && NILP (do_allow_print))
1981 tem = Qsymbolp;
1982 else
1983 tem = printflag;
1985 if (NILP (filename))
1986 filename = BVAR (XBUFFER (buf), filename);
1988 specbind (Qeval_buffer_list, Fcons (buf, Veval_buffer_list));
1989 specbind (Qstandard_output, tem);
1990 record_unwind_protect (save_excursion_restore, save_excursion_save ());
1991 BUF_TEMP_SET_PT (XBUFFER (buf), BUF_BEGV (XBUFFER (buf)));
1992 specbind (Qlexical_binding, lisp_file_lexically_bound_p (buf) ? Qt : Qnil);
1993 readevalloop (buf, 0, filename,
1994 !NILP (printflag), unibyte, Qnil, Qnil, Qnil);
1995 unbind_to (count, Qnil);
1997 return Qnil;
2000 DEFUN ("eval-region", Feval_region, Seval_region, 2, 4, "r",
2001 doc: /* Execute the region as Lisp code.
2002 When called from programs, expects two arguments,
2003 giving starting and ending indices in the current buffer
2004 of the text to be executed.
2005 Programs can pass third argument PRINTFLAG which controls output:
2006 a value of nil means discard it; anything else is stream for printing it.
2007 See Info node `(elisp)Output Streams' for details on streams.
2008 Also the fourth argument READ-FUNCTION, if non-nil, is used
2009 instead of `read' to read each expression. It gets one argument
2010 which is the input stream for reading characters.
2012 This function does not move point. */)
2013 (Lisp_Object start, Lisp_Object end, Lisp_Object printflag, Lisp_Object read_function)
2015 /* FIXME: Do the eval-sexp-add-defvars dance! */
2016 ptrdiff_t count = SPECPDL_INDEX ();
2017 Lisp_Object tem, cbuf;
2019 cbuf = Fcurrent_buffer ();
2021 if (NILP (printflag))
2022 tem = Qsymbolp;
2023 else
2024 tem = printflag;
2025 specbind (Qstandard_output, tem);
2026 specbind (Qeval_buffer_list, Fcons (cbuf, Veval_buffer_list));
2028 /* `readevalloop' calls functions which check the type of start and end. */
2029 readevalloop (cbuf, 0, BVAR (XBUFFER (cbuf), filename),
2030 !NILP (printflag), Qnil, read_function,
2031 start, end);
2033 return unbind_to (count, Qnil);
2037 DEFUN ("read", Fread, Sread, 0, 1, 0,
2038 doc: /* Read one Lisp expression as text from STREAM, return as Lisp object.
2039 If STREAM is nil, use the value of `standard-input' (which see).
2040 STREAM or the value of `standard-input' may be:
2041 a buffer (read from point and advance it)
2042 a marker (read from where it points and advance it)
2043 a function (call it with no arguments for each character,
2044 call it with a char as argument to push a char back)
2045 a string (takes text from string, starting at the beginning)
2046 t (read text line using minibuffer and use it, or read from
2047 standard input in batch mode). */)
2048 (Lisp_Object stream)
2050 if (NILP (stream))
2051 stream = Vstandard_input;
2052 if (EQ (stream, Qt))
2053 stream = Qread_char;
2054 if (EQ (stream, Qread_char))
2055 /* FIXME: ?! When is this used !? */
2056 return call1 (intern ("read-minibuffer"),
2057 build_string ("Lisp expression: "));
2059 return read_internal_start (stream, Qnil, Qnil);
2062 DEFUN ("read-from-string", Fread_from_string, Sread_from_string, 1, 3, 0,
2063 doc: /* Read one Lisp expression which is represented as text by STRING.
2064 Returns a cons: (OBJECT-READ . FINAL-STRING-INDEX).
2065 FINAL-STRING-INDEX is an integer giving the position of the next
2066 remaining character in STRING. START and END optionally delimit
2067 a substring of STRING from which to read; they default to 0 and
2068 \(length STRING) respectively. Negative values are counted from
2069 the end of STRING. */)
2070 (Lisp_Object string, Lisp_Object start, Lisp_Object end)
2072 Lisp_Object ret;
2073 CHECK_STRING (string);
2074 /* `read_internal_start' sets `read_from_string_index'. */
2075 ret = read_internal_start (string, start, end);
2076 return Fcons (ret, make_number (read_from_string_index));
2079 /* Function to set up the global context we need in toplevel read
2080 calls. START and END only used when STREAM is a string. */
2081 static Lisp_Object
2082 read_internal_start (Lisp_Object stream, Lisp_Object start, Lisp_Object end)
2084 Lisp_Object retval;
2086 readchar_count = 0;
2087 new_backquote_flag = 0;
2088 read_objects = Qnil;
2089 if (EQ (Vread_with_symbol_positions, Qt)
2090 || EQ (Vread_with_symbol_positions, stream))
2091 Vread_symbol_positions_list = Qnil;
2093 if (STRINGP (stream)
2094 || ((CONSP (stream) && STRINGP (XCAR (stream)))))
2096 ptrdiff_t startval, endval;
2097 Lisp_Object string;
2099 if (STRINGP (stream))
2100 string = stream;
2101 else
2102 string = XCAR (stream);
2104 validate_subarray (string, start, end, SCHARS (string),
2105 &startval, &endval);
2107 read_from_string_index = startval;
2108 read_from_string_index_byte = string_char_to_byte (string, startval);
2109 read_from_string_limit = endval;
2112 retval = read0 (stream);
2113 if (EQ (Vread_with_symbol_positions, Qt)
2114 || EQ (Vread_with_symbol_positions, stream))
2115 Vread_symbol_positions_list = Fnreverse (Vread_symbol_positions_list);
2116 return retval;
2120 /* Signal Qinvalid_read_syntax error.
2121 S is error string of length N (if > 0) */
2123 static _Noreturn void
2124 invalid_syntax (const char *s)
2126 xsignal1 (Qinvalid_read_syntax, build_string (s));
2130 /* Use this for recursive reads, in contexts where internal tokens
2131 are not allowed. */
2133 static Lisp_Object
2134 read0 (Lisp_Object readcharfun)
2136 register Lisp_Object val;
2137 int c;
2139 val = read1 (readcharfun, &c, 0);
2140 if (!c)
2141 return val;
2143 xsignal1 (Qinvalid_read_syntax,
2144 Fmake_string (make_number (1), make_number (c)));
2147 static ptrdiff_t read_buffer_size;
2148 static char *read_buffer;
2150 /* Grow the read buffer by at least MAX_MULTIBYTE_LENGTH bytes. */
2152 static void
2153 grow_read_buffer (void)
2155 read_buffer = xpalloc (read_buffer, &read_buffer_size,
2156 MAX_MULTIBYTE_LENGTH, -1, 1);
2159 /* Return the scalar value that has the Unicode character name NAME.
2160 Raise 'invalid-read-syntax' if there is no such character. */
2161 static int
2162 character_name_to_code (char const *name, ptrdiff_t name_len)
2164 /* For "U+XXXX", pass the leading '+' to string_to_number to reject
2165 monstrosities like "U+-0000". */
2166 Lisp_Object code
2167 = (name[0] == 'U' && name[1] == '+'
2168 ? string_to_number (name + 1, 16, false)
2169 : call2 (Qchar_from_name, make_unibyte_string (name, name_len), Qt));
2171 if (! RANGED_INTEGERP (0, code, MAX_UNICODE_CHAR)
2172 || char_surrogate_p (XINT (code)))
2174 AUTO_STRING (format, "\\N{%s}");
2175 AUTO_STRING_WITH_LEN (namestr, name, name_len);
2176 xsignal1 (Qinvalid_read_syntax, CALLN (Fformat, format, namestr));
2179 return XINT (code);
2182 /* Bound on the length of a Unicode character name. As of
2183 Unicode 9.0.0 the maximum is 83, so this should be safe. */
2184 enum { UNICODE_CHARACTER_NAME_LENGTH_BOUND = 200 };
2186 /* Read a \-escape sequence, assuming we already read the `\'.
2187 If the escape sequence forces unibyte, return eight-bit char. */
2189 static int
2190 read_escape (Lisp_Object readcharfun, bool stringp)
2192 int c = READCHAR;
2193 /* \u allows up to four hex digits, \U up to eight. Default to the
2194 behavior for \u, and change this value in the case that \U is seen. */
2195 int unicode_hex_count = 4;
2197 switch (c)
2199 case -1:
2200 end_of_file_error ();
2202 case 'a':
2203 return '\007';
2204 case 'b':
2205 return '\b';
2206 case 'd':
2207 return 0177;
2208 case 'e':
2209 return 033;
2210 case 'f':
2211 return '\f';
2212 case 'n':
2213 return '\n';
2214 case 'r':
2215 return '\r';
2216 case 't':
2217 return '\t';
2218 case 'v':
2219 return '\v';
2220 case '\n':
2221 return -1;
2222 case ' ':
2223 if (stringp)
2224 return -1;
2225 return ' ';
2227 case 'M':
2228 c = READCHAR;
2229 if (c != '-')
2230 error ("Invalid escape character syntax");
2231 c = READCHAR;
2232 if (c == '\\')
2233 c = read_escape (readcharfun, 0);
2234 return c | meta_modifier;
2236 case 'S':
2237 c = READCHAR;
2238 if (c != '-')
2239 error ("Invalid escape character syntax");
2240 c = READCHAR;
2241 if (c == '\\')
2242 c = read_escape (readcharfun, 0);
2243 return c | shift_modifier;
2245 case 'H':
2246 c = READCHAR;
2247 if (c != '-')
2248 error ("Invalid escape character syntax");
2249 c = READCHAR;
2250 if (c == '\\')
2251 c = read_escape (readcharfun, 0);
2252 return c | hyper_modifier;
2254 case 'A':
2255 c = READCHAR;
2256 if (c != '-')
2257 error ("Invalid escape character syntax");
2258 c = READCHAR;
2259 if (c == '\\')
2260 c = read_escape (readcharfun, 0);
2261 return c | alt_modifier;
2263 case 's':
2264 c = READCHAR;
2265 if (stringp || c != '-')
2267 UNREAD (c);
2268 return ' ';
2270 c = READCHAR;
2271 if (c == '\\')
2272 c = read_escape (readcharfun, 0);
2273 return c | super_modifier;
2275 case 'C':
2276 c = READCHAR;
2277 if (c != '-')
2278 error ("Invalid escape character syntax");
2279 case '^':
2280 c = READCHAR;
2281 if (c == '\\')
2282 c = read_escape (readcharfun, 0);
2283 if ((c & ~CHAR_MODIFIER_MASK) == '?')
2284 return 0177 | (c & CHAR_MODIFIER_MASK);
2285 else if (! SINGLE_BYTE_CHAR_P ((c & ~CHAR_MODIFIER_MASK)))
2286 return c | ctrl_modifier;
2287 /* ASCII control chars are made from letters (both cases),
2288 as well as the non-letters within 0100...0137. */
2289 else if ((c & 0137) >= 0101 && (c & 0137) <= 0132)
2290 return (c & (037 | ~0177));
2291 else if ((c & 0177) >= 0100 && (c & 0177) <= 0137)
2292 return (c & (037 | ~0177));
2293 else
2294 return c | ctrl_modifier;
2296 case '0':
2297 case '1':
2298 case '2':
2299 case '3':
2300 case '4':
2301 case '5':
2302 case '6':
2303 case '7':
2304 /* An octal escape, as in ANSI C. */
2306 register int i = c - '0';
2307 register int count = 0;
2308 while (++count < 3)
2310 if ((c = READCHAR) >= '0' && c <= '7')
2312 i *= 8;
2313 i += c - '0';
2315 else
2317 UNREAD (c);
2318 break;
2322 if (i >= 0x80 && i < 0x100)
2323 i = BYTE8_TO_CHAR (i);
2324 return i;
2327 case 'x':
2328 /* A hex escape, as in ANSI C. */
2330 unsigned int i = 0;
2331 int count = 0;
2332 while (1)
2334 c = READCHAR;
2335 if (c >= '0' && c <= '9')
2337 i *= 16;
2338 i += c - '0';
2340 else if ((c >= 'a' && c <= 'f')
2341 || (c >= 'A' && c <= 'F'))
2343 i *= 16;
2344 if (c >= 'a' && c <= 'f')
2345 i += c - 'a' + 10;
2346 else
2347 i += c - 'A' + 10;
2349 else
2351 UNREAD (c);
2352 break;
2354 /* Allow hex escapes as large as ?\xfffffff, because some
2355 packages use them to denote characters with modifiers. */
2356 if ((CHAR_META | (CHAR_META - 1)) < i)
2357 error ("Hex character out of range: \\x%x...", i);
2358 count += count < 3;
2361 if (count < 3 && i >= 0x80)
2362 return BYTE8_TO_CHAR (i);
2363 return i;
2366 case 'U':
2367 /* Post-Unicode-2.0: Up to eight hex chars. */
2368 unicode_hex_count = 8;
2369 case 'u':
2371 /* A Unicode escape. We only permit them in strings and characters,
2372 not arbitrarily in the source code, as in some other languages. */
2374 unsigned int i = 0;
2375 int count = 0;
2377 while (++count <= unicode_hex_count)
2379 c = READCHAR;
2380 /* `isdigit' and `isalpha' may be locale-specific, which we don't
2381 want. */
2382 if (c >= '0' && c <= '9') i = (i << 4) + (c - '0');
2383 else if (c >= 'a' && c <= 'f') i = (i << 4) + (c - 'a') + 10;
2384 else if (c >= 'A' && c <= 'F') i = (i << 4) + (c - 'A') + 10;
2385 else
2386 error ("Non-hex digit used for Unicode escape");
2388 if (i > 0x10FFFF)
2389 error ("Non-Unicode character: 0x%x", i);
2390 return i;
2393 case 'N':
2394 /* Named character. */
2396 c = READCHAR;
2397 if (c != '{')
2398 invalid_syntax ("Expected opening brace after \\N");
2399 char name[UNICODE_CHARACTER_NAME_LENGTH_BOUND + 1];
2400 bool whitespace = false;
2401 ptrdiff_t length = 0;
2402 while (true)
2404 c = READCHAR;
2405 if (c < 0)
2406 end_of_file_error ();
2407 if (c == '}')
2408 break;
2409 if (! (0 < c && c < 0x80))
2411 AUTO_STRING (format,
2412 "Invalid character U+%04X in character name");
2413 xsignal1 (Qinvalid_read_syntax,
2414 CALLN (Fformat, format, make_natnum (c)));
2416 /* Treat multiple adjacent whitespace characters as a
2417 single space character. This makes it easier to use
2418 character names in e.g. multi-line strings. */
2419 if (c_isspace (c))
2421 if (whitespace)
2422 continue;
2423 c = ' ';
2424 whitespace = true;
2426 else
2427 whitespace = false;
2428 name[length++] = c;
2429 if (length >= sizeof name)
2430 invalid_syntax ("Character name too long");
2432 if (length == 0)
2433 invalid_syntax ("Empty character name");
2434 name[length] = '\0';
2435 return character_name_to_code (name, length);
2438 default:
2439 return c;
2443 /* Return the digit that CHARACTER stands for in the given BASE.
2444 Return -1 if CHARACTER is out of range for BASE,
2445 and -2 if CHARACTER is not valid for any supported BASE. */
2446 static int
2447 digit_to_number (int character, int base)
2449 int digit;
2451 if ('0' <= character && character <= '9')
2452 digit = character - '0';
2453 else if ('a' <= character && character <= 'z')
2454 digit = character - 'a' + 10;
2455 else if ('A' <= character && character <= 'Z')
2456 digit = character - 'A' + 10;
2457 else
2458 return -2;
2460 return digit < base ? digit : -1;
2463 /* Read an integer in radix RADIX using READCHARFUN to read
2464 characters. RADIX must be in the interval [2..36]; if it isn't, a
2465 read error is signaled . Value is the integer read. Signals an
2466 error if encountering invalid read syntax or if RADIX is out of
2467 range. */
2469 static Lisp_Object
2470 read_integer (Lisp_Object readcharfun, EMACS_INT radix)
2472 /* Room for sign, leading 0, other digits, trailing null byte.
2473 Also, room for invalid syntax diagnostic. */
2474 char buf[max (1 + 1 + sizeof (uintmax_t) * CHAR_BIT + 1,
2475 sizeof "integer, radix " + INT_STRLEN_BOUND (EMACS_INT))];
2477 int valid = -1; /* 1 if valid, 0 if not, -1 if incomplete. */
2479 if (radix < 2 || radix > 36)
2480 valid = 0;
2481 else
2483 char *p = buf;
2484 int c, digit;
2486 c = READCHAR;
2487 if (c == '-' || c == '+')
2489 *p++ = c;
2490 c = READCHAR;
2493 if (c == '0')
2495 *p++ = c;
2496 valid = 1;
2498 /* Ignore redundant leading zeros, so the buffer doesn't
2499 fill up with them. */
2501 c = READCHAR;
2502 while (c == '0');
2505 while ((digit = digit_to_number (c, radix)) >= -1)
2507 if (digit == -1)
2508 valid = 0;
2509 if (valid < 0)
2510 valid = 1;
2512 if (p < buf + sizeof buf - 1)
2513 *p++ = c;
2514 else
2515 valid = 0;
2517 c = READCHAR;
2520 UNREAD (c);
2521 *p = '\0';
2524 if (! valid)
2526 sprintf (buf, "integer, radix %"pI"d", radix);
2527 invalid_syntax (buf);
2530 return string_to_number (buf, radix, 0);
2534 /* If the next token is ')' or ']' or '.', we store that character
2535 in *PCH and the return value is not interesting. Else, we store
2536 zero in *PCH and we read and return one lisp object.
2538 FIRST_IN_LIST is true if this is the first element of a list. */
2540 static Lisp_Object
2541 read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
2543 int c;
2544 bool uninterned_symbol = 0;
2545 bool multibyte;
2547 *pch = 0;
2549 retry:
2551 c = READCHAR_REPORT_MULTIBYTE (&multibyte);
2552 if (c < 0)
2553 end_of_file_error ();
2555 switch (c)
2557 case '(':
2558 return read_list (0, readcharfun);
2560 case '[':
2561 return read_vector (readcharfun, 0);
2563 case ')':
2564 case ']':
2566 *pch = c;
2567 return Qnil;
2570 case '#':
2571 c = READCHAR;
2572 if (c == 's')
2574 c = READCHAR;
2575 if (c == '(')
2577 /* Accept extended format for hashtables (extensible to
2578 other types), e.g.
2579 #s(hash-table size 2 test equal data (k1 v1 k2 v2)) */
2580 Lisp_Object tmp = read_list (0, readcharfun);
2581 Lisp_Object head = CAR_SAFE (tmp);
2582 Lisp_Object data = Qnil;
2583 Lisp_Object val = Qnil;
2584 /* The size is 2 * number of allowed keywords to
2585 make-hash-table. */
2586 Lisp_Object params[10];
2587 Lisp_Object ht;
2588 Lisp_Object key = Qnil;
2589 int param_count = 0;
2591 if (!EQ (head, Qhash_table))
2592 error ("Invalid extended read marker at head of #s list "
2593 "(only hash-table allowed)");
2595 tmp = CDR_SAFE (tmp);
2597 /* This is repetitive but fast and simple. */
2598 params[param_count] = QCsize;
2599 params[param_count + 1] = Fplist_get (tmp, Qsize);
2600 if (!NILP (params[param_count + 1]))
2601 param_count += 2;
2603 params[param_count] = QCtest;
2604 params[param_count + 1] = Fplist_get (tmp, Qtest);
2605 if (!NILP (params[param_count + 1]))
2606 param_count += 2;
2608 params[param_count] = QCweakness;
2609 params[param_count + 1] = Fplist_get (tmp, Qweakness);
2610 if (!NILP (params[param_count + 1]))
2611 param_count += 2;
2613 params[param_count] = QCrehash_size;
2614 params[param_count + 1] = Fplist_get (tmp, Qrehash_size);
2615 if (!NILP (params[param_count + 1]))
2616 param_count += 2;
2618 params[param_count] = QCrehash_threshold;
2619 params[param_count + 1] = Fplist_get (tmp, Qrehash_threshold);
2620 if (!NILP (params[param_count + 1]))
2621 param_count += 2;
2623 /* This is the hashtable data. */
2624 data = Fplist_get (tmp, Qdata);
2626 /* Now use params to make a new hashtable and fill it. */
2627 ht = Fmake_hash_table (param_count, params);
2629 while (CONSP (data))
2631 key = XCAR (data);
2632 data = XCDR (data);
2633 if (!CONSP (data))
2634 error ("Odd number of elements in hashtable data");
2635 val = XCAR (data);
2636 data = XCDR (data);
2637 Fputhash (key, val, ht);
2640 return ht;
2642 UNREAD (c);
2643 invalid_syntax ("#");
2645 if (c == '^')
2647 c = READCHAR;
2648 if (c == '[')
2650 Lisp_Object tmp;
2651 tmp = read_vector (readcharfun, 0);
2652 if (ASIZE (tmp) < CHAR_TABLE_STANDARD_SLOTS)
2653 error ("Invalid size char-table");
2654 XSETPVECTYPE (XVECTOR (tmp), PVEC_CHAR_TABLE);
2655 return tmp;
2657 else if (c == '^')
2659 c = READCHAR;
2660 if (c == '[')
2662 /* Sub char-table can't be read as a regular
2663 vector because of a two C integer fields. */
2664 Lisp_Object tbl, tmp = read_list (1, readcharfun);
2665 ptrdiff_t size = XINT (Flength (tmp));
2666 int i, depth, min_char;
2667 struct Lisp_Cons *cell;
2669 if (size == 0)
2670 error ("Zero-sized sub char-table");
2672 if (! RANGED_INTEGERP (1, XCAR (tmp), 3))
2673 error ("Invalid depth in sub char-table");
2674 depth = XINT (XCAR (tmp));
2675 if (chartab_size[depth] != size - 2)
2676 error ("Invalid size in sub char-table");
2677 cell = XCONS (tmp), tmp = XCDR (tmp), size--;
2678 free_cons (cell);
2680 if (! RANGED_INTEGERP (0, XCAR (tmp), MAX_CHAR))
2681 error ("Invalid minimum character in sub-char-table");
2682 min_char = XINT (XCAR (tmp));
2683 cell = XCONS (tmp), tmp = XCDR (tmp), size--;
2684 free_cons (cell);
2686 tbl = make_uninit_sub_char_table (depth, min_char);
2687 for (i = 0; i < size; i++)
2689 XSUB_CHAR_TABLE (tbl)->contents[i] = XCAR (tmp);
2690 cell = XCONS (tmp), tmp = XCDR (tmp);
2691 free_cons (cell);
2693 return tbl;
2695 invalid_syntax ("#^^");
2697 invalid_syntax ("#^");
2699 if (c == '&')
2701 Lisp_Object length;
2702 length = read1 (readcharfun, pch, first_in_list);
2703 c = READCHAR;
2704 if (c == '"')
2706 Lisp_Object tmp, val;
2707 EMACS_INT size_in_chars = bool_vector_bytes (XFASTINT (length));
2708 unsigned char *data;
2710 UNREAD (c);
2711 tmp = read1 (readcharfun, pch, first_in_list);
2712 if (STRING_MULTIBYTE (tmp)
2713 || (size_in_chars != SCHARS (tmp)
2714 /* We used to print 1 char too many
2715 when the number of bits was a multiple of 8.
2716 Accept such input in case it came from an old
2717 version. */
2718 && ! (XFASTINT (length)
2719 == (SCHARS (tmp) - 1) * BOOL_VECTOR_BITS_PER_CHAR)))
2720 invalid_syntax ("#&...");
2722 val = make_uninit_bool_vector (XFASTINT (length));
2723 data = bool_vector_uchar_data (val);
2724 memcpy (data, SDATA (tmp), size_in_chars);
2725 /* Clear the extraneous bits in the last byte. */
2726 if (XINT (length) != size_in_chars * BOOL_VECTOR_BITS_PER_CHAR)
2727 data[size_in_chars - 1]
2728 &= (1 << (XINT (length) % BOOL_VECTOR_BITS_PER_CHAR)) - 1;
2729 return val;
2731 invalid_syntax ("#&...");
2733 if (c == '[')
2735 /* Accept compiled functions at read-time so that we don't have to
2736 build them using function calls. */
2737 Lisp_Object tmp;
2738 struct Lisp_Vector *vec;
2739 tmp = read_vector (readcharfun, 1);
2740 vec = XVECTOR (tmp);
2741 if (vec->header.size == 0)
2742 invalid_syntax ("Empty byte-code object");
2743 make_byte_code (vec);
2744 return tmp;
2746 if (c == '(')
2748 Lisp_Object tmp;
2749 int ch;
2751 /* Read the string itself. */
2752 tmp = read1 (readcharfun, &ch, 0);
2753 if (ch != 0 || !STRINGP (tmp))
2754 invalid_syntax ("#");
2755 /* Read the intervals and their properties. */
2756 while (1)
2758 Lisp_Object beg, end, plist;
2760 beg = read1 (readcharfun, &ch, 0);
2761 end = plist = Qnil;
2762 if (ch == ')')
2763 break;
2764 if (ch == 0)
2765 end = read1 (readcharfun, &ch, 0);
2766 if (ch == 0)
2767 plist = read1 (readcharfun, &ch, 0);
2768 if (ch)
2769 invalid_syntax ("Invalid string property list");
2770 Fset_text_properties (beg, end, plist, tmp);
2773 return tmp;
2776 /* #@NUMBER is used to skip NUMBER following bytes.
2777 That's used in .elc files to skip over doc strings
2778 and function definitions. */
2779 if (c == '@')
2781 enum { extra = 100 };
2782 ptrdiff_t i, nskip = 0, digits = 0;
2784 /* Read a decimal integer. */
2785 while ((c = READCHAR) >= 0
2786 && c >= '0' && c <= '9')
2788 if ((STRING_BYTES_BOUND - extra) / 10 <= nskip)
2789 string_overflow ();
2790 digits++;
2791 nskip *= 10;
2792 nskip += c - '0';
2793 if (digits == 2 && nskip == 0)
2794 { /* We've just seen #@00, which means "skip to end". */
2795 skip_dyn_eof (readcharfun);
2796 return Qnil;
2799 if (nskip > 0)
2800 /* We can't use UNREAD here, because in the code below we side-step
2801 READCHAR. Instead, assume the first char after #@NNN occupies
2802 a single byte, which is the case normally since it's just
2803 a space. */
2804 nskip--;
2805 else
2806 UNREAD (c);
2808 if (load_force_doc_strings
2809 && (FROM_FILE_P (readcharfun)))
2811 /* If we are supposed to force doc strings into core right now,
2812 record the last string that we skipped,
2813 and record where in the file it comes from. */
2815 /* But first exchange saved_doc_string
2816 with prev_saved_doc_string, so we save two strings. */
2818 char *temp = saved_doc_string;
2819 ptrdiff_t temp_size = saved_doc_string_size;
2820 file_offset temp_pos = saved_doc_string_position;
2821 ptrdiff_t temp_len = saved_doc_string_length;
2823 saved_doc_string = prev_saved_doc_string;
2824 saved_doc_string_size = prev_saved_doc_string_size;
2825 saved_doc_string_position = prev_saved_doc_string_position;
2826 saved_doc_string_length = prev_saved_doc_string_length;
2828 prev_saved_doc_string = temp;
2829 prev_saved_doc_string_size = temp_size;
2830 prev_saved_doc_string_position = temp_pos;
2831 prev_saved_doc_string_length = temp_len;
2834 if (saved_doc_string_size == 0)
2836 saved_doc_string = xmalloc (nskip + extra);
2837 saved_doc_string_size = nskip + extra;
2839 if (nskip > saved_doc_string_size)
2841 saved_doc_string = xrealloc (saved_doc_string, nskip + extra);
2842 saved_doc_string_size = nskip + extra;
2845 saved_doc_string_position = file_tell (instream);
2847 /* Copy that many characters into saved_doc_string. */
2848 block_input ();
2849 for (i = 0; i < nskip && c >= 0; i++)
2850 saved_doc_string[i] = c = getc (instream);
2851 unblock_input ();
2853 saved_doc_string_length = i;
2855 else
2856 /* Skip that many bytes. */
2857 skip_dyn_bytes (readcharfun, nskip);
2859 goto retry;
2861 if (c == '!')
2863 /* #! appears at the beginning of an executable file.
2864 Skip the first line. */
2865 while (c != '\n' && c >= 0)
2866 c = READCHAR;
2867 goto retry;
2869 if (c == '$')
2870 return Vload_file_name;
2871 if (c == '\'')
2872 return list2 (Qfunction, read0 (readcharfun));
2873 /* #:foo is the uninterned symbol named foo. */
2874 if (c == ':')
2876 uninterned_symbol = 1;
2877 c = READCHAR;
2878 if (!(c > 040
2879 && c != NO_BREAK_SPACE
2880 && (c >= 0200
2881 || strchr ("\"';()[]#`,", c) == NULL)))
2883 /* No symbol character follows, this is the empty
2884 symbol. */
2885 UNREAD (c);
2886 return Fmake_symbol (empty_unibyte_string);
2888 goto read_symbol;
2890 /* ## is the empty symbol. */
2891 if (c == '#')
2892 return Fintern (empty_unibyte_string, Qnil);
2893 /* Reader forms that can reuse previously read objects. */
2894 if (c >= '0' && c <= '9')
2896 EMACS_INT n = 0;
2897 Lisp_Object tem;
2899 /* Read a non-negative integer. */
2900 while (c >= '0' && c <= '9')
2902 if (MOST_POSITIVE_FIXNUM / 10 < n
2903 || MOST_POSITIVE_FIXNUM < n * 10 + c - '0')
2904 n = MOST_POSITIVE_FIXNUM + 1;
2905 else
2906 n = n * 10 + c - '0';
2907 c = READCHAR;
2910 if (n <= MOST_POSITIVE_FIXNUM)
2912 if (c == 'r' || c == 'R')
2913 return read_integer (readcharfun, n);
2915 if (! NILP (Vread_circle))
2917 /* #n=object returns object, but associates it with
2918 n for #n#. */
2919 if (c == '=')
2921 /* Make a placeholder for #n# to use temporarily. */
2922 AUTO_CONS (placeholder, Qnil, Qnil);
2923 Lisp_Object cell = Fcons (make_number (n), placeholder);
2924 read_objects = Fcons (cell, read_objects);
2926 /* Read the object itself. */
2927 tem = read0 (readcharfun);
2929 /* Now put it everywhere the placeholder was... */
2930 substitute_object_in_subtree (tem, placeholder);
2932 /* ...and #n# will use the real value from now on. */
2933 Fsetcdr (cell, tem);
2935 return tem;
2938 /* #n# returns a previously read object. */
2939 if (c == '#')
2941 tem = Fassq (make_number (n), read_objects);
2942 if (CONSP (tem))
2943 return XCDR (tem);
2947 /* Fall through to error message. */
2949 else if (c == 'x' || c == 'X')
2950 return read_integer (readcharfun, 16);
2951 else if (c == 'o' || c == 'O')
2952 return read_integer (readcharfun, 8);
2953 else if (c == 'b' || c == 'B')
2954 return read_integer (readcharfun, 2);
2956 UNREAD (c);
2957 invalid_syntax ("#");
2959 case ';':
2960 while ((c = READCHAR) >= 0 && c != '\n');
2961 goto retry;
2963 case '\'':
2964 return list2 (Qquote, read0 (readcharfun));
2966 case '`':
2968 int next_char = READCHAR;
2969 UNREAD (next_char);
2970 /* Transition from old-style to new-style:
2971 If we see "(`" it used to mean old-style, which usually works
2972 fine because ` should almost never appear in such a position
2973 for new-style. But occasionally we need "(`" to mean new
2974 style, so we try to distinguish the two by the fact that we
2975 can either write "( `foo" or "(` foo", where the first
2976 intends to use new-style whereas the second intends to use
2977 old-style. For Emacs-25, we should completely remove this
2978 first_in_list exception (old-style can still be obtained via
2979 "(\`" anyway). */
2980 if (!new_backquote_flag && first_in_list && next_char == ' ')
2982 Vold_style_backquotes = Qt;
2983 goto default_label;
2985 else
2987 Lisp_Object value;
2988 bool saved_new_backquote_flag = new_backquote_flag;
2990 new_backquote_flag = 1;
2991 value = read0 (readcharfun);
2992 new_backquote_flag = saved_new_backquote_flag;
2994 return list2 (Qbackquote, value);
2997 case ',':
2999 int next_char = READCHAR;
3000 UNREAD (next_char);
3001 /* Transition from old-style to new-style:
3002 It used to be impossible to have a new-style , other than within
3003 a new-style `. This is sufficient when ` and , are used in the
3004 normal way, but ` and , can also appear in args to macros that
3005 will not interpret them in the usual way, in which case , may be
3006 used without any ` anywhere near.
3007 So we now use the same heuristic as for backquote: old-style
3008 unquotes are only recognized when first on a list, and when
3009 followed by a space.
3010 Because it's more difficult to peek 2 chars ahead, a new-style
3011 ,@ can still not be used outside of a `, unless it's in the middle
3012 of a list. */
3013 if (new_backquote_flag
3014 || !first_in_list
3015 || (next_char != ' ' && next_char != '@'))
3017 Lisp_Object comma_type = Qnil;
3018 Lisp_Object value;
3019 int ch = READCHAR;
3021 if (ch == '@')
3022 comma_type = Qcomma_at;
3023 else if (ch == '.')
3024 comma_type = Qcomma_dot;
3025 else
3027 if (ch >= 0) UNREAD (ch);
3028 comma_type = Qcomma;
3031 value = read0 (readcharfun);
3032 return list2 (comma_type, value);
3034 else
3036 Vold_style_backquotes = Qt;
3037 goto default_label;
3040 case '?':
3042 int modifiers;
3043 int next_char;
3044 bool ok;
3046 c = READCHAR;
3047 if (c < 0)
3048 end_of_file_error ();
3050 /* Accept `single space' syntax like (list ? x) where the
3051 whitespace character is SPC or TAB.
3052 Other literal whitespace like NL, CR, and FF are not accepted,
3053 as there are well-established escape sequences for these. */
3054 if (c == ' ' || c == '\t')
3055 return make_number (c);
3057 if (c == '\\')
3058 c = read_escape (readcharfun, 0);
3059 modifiers = c & CHAR_MODIFIER_MASK;
3060 c &= ~CHAR_MODIFIER_MASK;
3061 if (CHAR_BYTE8_P (c))
3062 c = CHAR_TO_BYTE8 (c);
3063 c |= modifiers;
3065 next_char = READCHAR;
3066 ok = (next_char <= 040
3067 || (next_char < 0200
3068 && strchr ("\"';()[]#?`,.", next_char) != NULL));
3069 UNREAD (next_char);
3070 if (ok)
3071 return make_number (c);
3073 invalid_syntax ("?");
3076 case '"':
3078 char *p = read_buffer;
3079 char *end = read_buffer + read_buffer_size;
3080 int ch;
3081 /* True if we saw an escape sequence specifying
3082 a multibyte character. */
3083 bool force_multibyte = 0;
3084 /* True if we saw an escape sequence specifying
3085 a single-byte character. */
3086 bool force_singlebyte = 0;
3087 bool cancel = 0;
3088 ptrdiff_t nchars = 0;
3090 while ((ch = READCHAR) >= 0
3091 && ch != '\"')
3093 if (end - p < MAX_MULTIBYTE_LENGTH)
3095 ptrdiff_t offset = p - read_buffer;
3096 grow_read_buffer ();
3097 p = read_buffer + offset;
3098 end = read_buffer + read_buffer_size;
3101 if (ch == '\\')
3103 int modifiers;
3105 ch = read_escape (readcharfun, 1);
3107 /* CH is -1 if \ newline or \ space has just been seen. */
3108 if (ch == -1)
3110 if (p == read_buffer)
3111 cancel = 1;
3112 continue;
3115 modifiers = ch & CHAR_MODIFIER_MASK;
3116 ch = ch & ~CHAR_MODIFIER_MASK;
3118 if (CHAR_BYTE8_P (ch))
3119 force_singlebyte = 1;
3120 else if (! ASCII_CHAR_P (ch))
3121 force_multibyte = 1;
3122 else /* I.e. ASCII_CHAR_P (ch). */
3124 /* Allow `\C- ' and `\C-?'. */
3125 if (modifiers == CHAR_CTL)
3127 if (ch == ' ')
3128 ch = 0, modifiers = 0;
3129 else if (ch == '?')
3130 ch = 127, modifiers = 0;
3132 if (modifiers & CHAR_SHIFT)
3134 /* Shift modifier is valid only with [A-Za-z]. */
3135 if (ch >= 'A' && ch <= 'Z')
3136 modifiers &= ~CHAR_SHIFT;
3137 else if (ch >= 'a' && ch <= 'z')
3138 ch -= ('a' - 'A'), modifiers &= ~CHAR_SHIFT;
3141 if (modifiers & CHAR_META)
3143 /* Move the meta bit to the right place for a
3144 string. */
3145 modifiers &= ~CHAR_META;
3146 ch = BYTE8_TO_CHAR (ch | 0x80);
3147 force_singlebyte = 1;
3151 /* Any modifiers remaining are invalid. */
3152 if (modifiers)
3153 error ("Invalid modifier in string");
3154 p += CHAR_STRING (ch, (unsigned char *) p);
3156 else
3158 p += CHAR_STRING (ch, (unsigned char *) p);
3159 if (CHAR_BYTE8_P (ch))
3160 force_singlebyte = 1;
3161 else if (! ASCII_CHAR_P (ch))
3162 force_multibyte = 1;
3164 nchars++;
3167 if (ch < 0)
3168 end_of_file_error ();
3170 /* If purifying, and string starts with \ newline,
3171 return zero instead. This is for doc strings
3172 that we are really going to find in etc/DOC.nn.nn. */
3173 if (!NILP (Vpurify_flag) && NILP (Vdoc_file_name) && cancel)
3174 return make_number (0);
3176 if (! force_multibyte && force_singlebyte)
3178 /* READ_BUFFER contains raw 8-bit bytes and no multibyte
3179 forms. Convert it to unibyte. */
3180 nchars = str_as_unibyte ((unsigned char *) read_buffer,
3181 p - read_buffer);
3182 p = read_buffer + nchars;
3185 return make_specified_string (read_buffer, nchars, p - read_buffer,
3186 (force_multibyte
3187 || (p - read_buffer != nchars)));
3190 case '.':
3192 int next_char = READCHAR;
3193 UNREAD (next_char);
3195 if (next_char <= 040
3196 || (next_char < 0200
3197 && strchr ("\"';([#?`,", next_char) != NULL))
3199 *pch = c;
3200 return Qnil;
3203 /* Otherwise, we fall through! Note that the atom-reading loop
3204 below will now loop at least once, assuring that we will not
3205 try to UNREAD two characters in a row. */
3207 default:
3208 default_label:
3209 if (c <= 040) goto retry;
3210 if (c == NO_BREAK_SPACE)
3211 goto retry;
3213 read_symbol:
3215 char *p = read_buffer;
3216 bool quoted = 0;
3217 EMACS_INT start_position = readchar_count - 1;
3220 char *end = read_buffer + read_buffer_size;
3224 if (end - p < MAX_MULTIBYTE_LENGTH)
3226 ptrdiff_t offset = p - read_buffer;
3227 grow_read_buffer ();
3228 p = read_buffer + offset;
3229 end = read_buffer + read_buffer_size;
3232 if (c == '\\')
3234 c = READCHAR;
3235 if (c == -1)
3236 end_of_file_error ();
3237 quoted = 1;
3240 if (multibyte)
3241 p += CHAR_STRING (c, (unsigned char *) p);
3242 else
3243 *p++ = c;
3244 c = READCHAR;
3246 while (c > 040
3247 && c != NO_BREAK_SPACE
3248 && (c >= 0200
3249 || strchr ("\"';()[]#`,", c) == NULL));
3251 if (p == end)
3253 ptrdiff_t offset = p - read_buffer;
3254 grow_read_buffer ();
3255 p = read_buffer + offset;
3256 end = read_buffer + read_buffer_size;
3258 *p = 0;
3259 UNREAD (c);
3262 if (!quoted && !uninterned_symbol)
3264 Lisp_Object result = string_to_number (read_buffer, 10, 0);
3265 if (! NILP (result))
3266 return result;
3269 Lisp_Object name, result;
3270 ptrdiff_t nbytes = p - read_buffer;
3271 ptrdiff_t nchars
3272 = (multibyte
3273 ? multibyte_chars_in_text ((unsigned char *) read_buffer,
3274 nbytes)
3275 : nbytes);
3277 name = ((uninterned_symbol && ! NILP (Vpurify_flag)
3278 ? make_pure_string : make_specified_string)
3279 (read_buffer, nchars, nbytes, multibyte));
3280 result = (uninterned_symbol ? Fmake_symbol (name)
3281 : Fintern (name, Qnil));
3283 if (EQ (Vread_with_symbol_positions, Qt)
3284 || EQ (Vread_with_symbol_positions, readcharfun))
3285 Vread_symbol_positions_list
3286 = Fcons (Fcons (result, make_number (start_position)),
3287 Vread_symbol_positions_list);
3288 return result;
3295 /* List of nodes we've seen during substitute_object_in_subtree. */
3296 static Lisp_Object seen_list;
3298 static void
3299 substitute_object_in_subtree (Lisp_Object object, Lisp_Object placeholder)
3301 Lisp_Object check_object;
3303 /* We haven't seen any objects when we start. */
3304 seen_list = Qnil;
3306 /* Make all the substitutions. */
3307 check_object
3308 = substitute_object_recurse (object, placeholder, object);
3310 /* Clear seen_list because we're done with it. */
3311 seen_list = Qnil;
3313 /* The returned object here is expected to always eq the
3314 original. */
3315 if (!EQ (check_object, object))
3316 error ("Unexpected mutation error in reader");
3319 /* Feval doesn't get called from here, so no gc protection is needed. */
3320 #define SUBSTITUTE(get_val, set_val) \
3321 do { \
3322 Lisp_Object old_value = get_val; \
3323 Lisp_Object true_value \
3324 = substitute_object_recurse (object, placeholder, \
3325 old_value); \
3327 if (!EQ (old_value, true_value)) \
3329 set_val; \
3331 } while (0)
3333 static Lisp_Object
3334 substitute_object_recurse (Lisp_Object object, Lisp_Object placeholder, Lisp_Object subtree)
3336 /* If we find the placeholder, return the target object. */
3337 if (EQ (placeholder, subtree))
3338 return object;
3340 /* If we've been to this node before, don't explore it again. */
3341 if (!EQ (Qnil, Fmemq (subtree, seen_list)))
3342 return subtree;
3344 /* If this node can be the entry point to a cycle, remember that
3345 we've seen it. It can only be such an entry point if it was made
3346 by #n=, which means that we can find it as a value in
3347 read_objects. */
3348 if (!EQ (Qnil, Frassq (subtree, read_objects)))
3349 seen_list = Fcons (subtree, seen_list);
3351 /* Recurse according to subtree's type.
3352 Every branch must return a Lisp_Object. */
3353 switch (XTYPE (subtree))
3355 case Lisp_Vectorlike:
3357 ptrdiff_t i = 0, length = 0;
3358 if (BOOL_VECTOR_P (subtree))
3359 return subtree; /* No sub-objects anyway. */
3360 else if (CHAR_TABLE_P (subtree) || SUB_CHAR_TABLE_P (subtree)
3361 || COMPILEDP (subtree) || HASH_TABLE_P (subtree))
3362 length = ASIZE (subtree) & PSEUDOVECTOR_SIZE_MASK;
3363 else if (VECTORP (subtree))
3364 length = ASIZE (subtree);
3365 else
3366 /* An unknown pseudovector may contain non-Lisp fields, so we
3367 can't just blindly traverse all its fields. We used to call
3368 `Flength' which signaled `sequencep', so I just preserved this
3369 behavior. */
3370 wrong_type_argument (Qsequencep, subtree);
3372 if (SUB_CHAR_TABLE_P (subtree))
3373 i = 2;
3374 for ( ; i < length; i++)
3375 SUBSTITUTE (AREF (subtree, i),
3376 ASET (subtree, i, true_value));
3377 return subtree;
3380 case Lisp_Cons:
3382 SUBSTITUTE (XCAR (subtree),
3383 XSETCAR (subtree, true_value));
3384 SUBSTITUTE (XCDR (subtree),
3385 XSETCDR (subtree, true_value));
3386 return subtree;
3389 case Lisp_String:
3391 /* Check for text properties in each interval.
3392 substitute_in_interval contains part of the logic. */
3394 INTERVAL root_interval = string_intervals (subtree);
3395 AUTO_CONS (arg, object, placeholder);
3397 traverse_intervals_noorder (root_interval,
3398 &substitute_in_interval, arg);
3400 return subtree;
3403 /* Other types don't recurse any further. */
3404 default:
3405 return subtree;
3409 /* Helper function for substitute_object_recurse. */
3410 static void
3411 substitute_in_interval (INTERVAL interval, Lisp_Object arg)
3413 Lisp_Object object = Fcar (arg);
3414 Lisp_Object placeholder = Fcdr (arg);
3416 SUBSTITUTE (interval->plist, set_interval_plist (interval, true_value));
3420 #define LEAD_INT 1
3421 #define DOT_CHAR 2
3422 #define TRAIL_INT 4
3423 #define E_EXP 16
3426 /* Convert STRING to a number, assuming base BASE. Return a fixnum if CP has
3427 integer syntax and fits in a fixnum, else return the nearest float if CP has
3428 either floating point or integer syntax and BASE is 10, else return nil. If
3429 IGNORE_TRAILING, consider just the longest prefix of CP that has
3430 valid floating point syntax. Signal an overflow if BASE is not 10 and the
3431 number has integer syntax but does not fit. */
3433 Lisp_Object
3434 string_to_number (char const *string, int base, bool ignore_trailing)
3436 int state;
3437 char const *cp = string;
3438 int leading_digit;
3439 bool float_syntax = 0;
3440 double value = 0;
3442 /* Negate the value ourselves. This treats 0, NaNs, and infinity properly on
3443 IEEE floating point hosts, and works around a formerly-common bug where
3444 atof ("-0.0") drops the sign. */
3445 bool negative = *cp == '-';
3447 bool signedp = negative || *cp == '+';
3448 cp += signedp;
3450 state = 0;
3452 leading_digit = digit_to_number (*cp, base);
3453 if (leading_digit >= 0)
3455 state |= LEAD_INT;
3457 ++cp;
3458 while (digit_to_number (*cp, base) >= 0);
3460 if (*cp == '.')
3462 state |= DOT_CHAR;
3463 cp++;
3466 if (base == 10)
3468 if ('0' <= *cp && *cp <= '9')
3470 state |= TRAIL_INT;
3472 cp++;
3473 while ('0' <= *cp && *cp <= '9');
3475 if (*cp == 'e' || *cp == 'E')
3477 char const *ecp = cp;
3478 cp++;
3479 if (*cp == '+' || *cp == '-')
3480 cp++;
3481 if ('0' <= *cp && *cp <= '9')
3483 state |= E_EXP;
3485 cp++;
3486 while ('0' <= *cp && *cp <= '9');
3488 else if (cp[-1] == '+'
3489 && cp[0] == 'I' && cp[1] == 'N' && cp[2] == 'F')
3491 state |= E_EXP;
3492 cp += 3;
3493 value = INFINITY;
3495 else if (cp[-1] == '+'
3496 && cp[0] == 'N' && cp[1] == 'a' && cp[2] == 'N')
3498 state |= E_EXP;
3499 cp += 3;
3500 /* NAN is a "positive" NaN on all known Emacs hosts. */
3501 value = NAN;
3503 else
3504 cp = ecp;
3507 float_syntax = ((state & (DOT_CHAR|TRAIL_INT)) == (DOT_CHAR|TRAIL_INT)
3508 || state == (LEAD_INT|E_EXP));
3511 /* Return nil if the number uses invalid syntax. If IGNORE_TRAILING, accept
3512 any prefix that matches. Otherwise, the entire string must match. */
3513 if (! (ignore_trailing
3514 ? ((state & LEAD_INT) != 0 || float_syntax)
3515 : (!*cp && ((state & ~DOT_CHAR) == LEAD_INT || float_syntax))))
3516 return Qnil;
3518 /* If the number uses integer and not float syntax, and is in C-language
3519 range, use its value, preferably as a fixnum. */
3520 if (leading_digit >= 0 && ! float_syntax)
3522 uintmax_t n;
3524 /* Fast special case for single-digit integers. This also avoids a
3525 glitch when BASE is 16 and IGNORE_TRAILING, because in that
3526 case some versions of strtoumax accept numbers like "0x1" that Emacs
3527 does not allow. */
3528 if (digit_to_number (string[signedp + 1], base) < 0)
3529 return make_number (negative ? -leading_digit : leading_digit);
3531 errno = 0;
3532 n = strtoumax (string + signedp, NULL, base);
3533 if (errno == ERANGE)
3535 /* Unfortunately there's no simple and accurate way to convert
3536 non-base-10 numbers that are out of C-language range. */
3537 if (base != 10)
3538 xsignal1 (Qoverflow_error, build_string (string));
3540 else if (n <= (negative ? -MOST_NEGATIVE_FIXNUM : MOST_POSITIVE_FIXNUM))
3542 EMACS_INT signed_n = n;
3543 return make_number (negative ? -signed_n : signed_n);
3545 else
3546 value = n;
3549 /* Either the number uses float syntax, or it does not fit into a fixnum.
3550 Convert it from string to floating point, unless the value is already
3551 known because it is an infinity, a NAN, or its absolute value fits in
3552 uintmax_t. */
3553 if (! value)
3554 value = atof (string + signedp);
3556 return make_float (negative ? -value : value);
3560 static Lisp_Object
3561 read_vector (Lisp_Object readcharfun, bool bytecodeflag)
3563 ptrdiff_t i, size;
3564 Lisp_Object *ptr;
3565 Lisp_Object tem, item, vector;
3566 struct Lisp_Cons *otem;
3567 Lisp_Object len;
3569 tem = read_list (1, readcharfun);
3570 len = Flength (tem);
3571 vector = Fmake_vector (len, Qnil);
3573 size = ASIZE (vector);
3574 ptr = XVECTOR (vector)->contents;
3575 for (i = 0; i < size; i++)
3577 item = Fcar (tem);
3578 /* If `load-force-doc-strings' is t when reading a lazily-loaded
3579 bytecode object, the docstring containing the bytecode and
3580 constants values must be treated as unibyte and passed to
3581 Fread, to get the actual bytecode string and constants vector. */
3582 if (bytecodeflag && load_force_doc_strings)
3584 if (i == COMPILED_BYTECODE)
3586 if (!STRINGP (item))
3587 error ("Invalid byte code");
3589 /* Delay handling the bytecode slot until we know whether
3590 it is lazily-loaded (we can tell by whether the
3591 constants slot is nil). */
3592 ASET (vector, COMPILED_CONSTANTS, item);
3593 item = Qnil;
3595 else if (i == COMPILED_CONSTANTS)
3597 Lisp_Object bytestr = ptr[COMPILED_CONSTANTS];
3599 if (NILP (item))
3601 /* Coerce string to unibyte (like string-as-unibyte,
3602 but without generating extra garbage and
3603 guaranteeing no change in the contents). */
3604 STRING_SET_CHARS (bytestr, SBYTES (bytestr));
3605 STRING_SET_UNIBYTE (bytestr);
3607 item = Fread (Fcons (bytestr, readcharfun));
3608 if (!CONSP (item))
3609 error ("Invalid byte code");
3611 otem = XCONS (item);
3612 bytestr = XCAR (item);
3613 item = XCDR (item);
3614 free_cons (otem);
3617 /* Now handle the bytecode slot. */
3618 ASET (vector, COMPILED_BYTECODE, bytestr);
3620 else if (i == COMPILED_DOC_STRING
3621 && STRINGP (item)
3622 && ! STRING_MULTIBYTE (item))
3624 if (EQ (readcharfun, Qget_emacs_mule_file_char))
3625 item = Fdecode_coding_string (item, Qemacs_mule, Qnil, Qnil);
3626 else
3627 item = Fstring_as_multibyte (item);
3630 ASET (vector, i, item);
3631 otem = XCONS (tem);
3632 tem = Fcdr (tem);
3633 free_cons (otem);
3635 return vector;
3638 /* FLAG means check for ']' to terminate rather than ')' and '.'. */
3640 static Lisp_Object
3641 read_list (bool flag, Lisp_Object readcharfun)
3643 Lisp_Object val, tail;
3644 Lisp_Object elt, tem;
3645 /* 0 is the normal case.
3646 1 means this list is a doc reference; replace it with the number 0.
3647 2 means this list is a doc reference; replace it with the doc string. */
3648 int doc_reference = 0;
3650 /* Initialize this to 1 if we are reading a list. */
3651 bool first_in_list = flag <= 0;
3653 val = Qnil;
3654 tail = Qnil;
3656 while (1)
3658 int ch;
3659 elt = read1 (readcharfun, &ch, first_in_list);
3661 first_in_list = 0;
3663 /* While building, if the list starts with #$, treat it specially. */
3664 if (EQ (elt, Vload_file_name)
3665 && ! NILP (elt)
3666 && !NILP (Vpurify_flag))
3668 if (NILP (Vdoc_file_name))
3669 /* We have not yet called Snarf-documentation, so assume
3670 this file is described in the DOC file
3671 and Snarf-documentation will fill in the right value later.
3672 For now, replace the whole list with 0. */
3673 doc_reference = 1;
3674 else
3675 /* We have already called Snarf-documentation, so make a relative
3676 file name for this file, so it can be found properly
3677 in the installed Lisp directory.
3678 We don't use Fexpand_file_name because that would make
3679 the directory absolute now. */
3681 AUTO_STRING (dot_dot_lisp, "../lisp/");
3682 elt = concat2 (dot_dot_lisp, Ffile_name_nondirectory (elt));
3685 else if (EQ (elt, Vload_file_name)
3686 && ! NILP (elt)
3687 && load_force_doc_strings)
3688 doc_reference = 2;
3690 if (ch)
3692 if (flag > 0)
3694 if (ch == ']')
3695 return val;
3696 invalid_syntax (") or . in a vector");
3698 if (ch == ')')
3699 return val;
3700 if (ch == '.')
3702 if (!NILP (tail))
3703 XSETCDR (tail, read0 (readcharfun));
3704 else
3705 val = read0 (readcharfun);
3706 read1 (readcharfun, &ch, 0);
3708 if (ch == ')')
3710 if (doc_reference == 1)
3711 return make_number (0);
3712 if (doc_reference == 2 && INTEGERP (XCDR (val)))
3714 char *saved = NULL;
3715 file_offset saved_position;
3716 /* Get a doc string from the file we are loading.
3717 If it's in saved_doc_string, get it from there.
3719 Here, we don't know if the string is a
3720 bytecode string or a doc string. As a
3721 bytecode string must be unibyte, we always
3722 return a unibyte string. If it is actually a
3723 doc string, caller must make it
3724 multibyte. */
3726 /* Position is negative for user variables. */
3727 EMACS_INT pos = eabs (XINT (XCDR (val)));
3728 if (pos >= saved_doc_string_position
3729 && pos < (saved_doc_string_position
3730 + saved_doc_string_length))
3732 saved = saved_doc_string;
3733 saved_position = saved_doc_string_position;
3735 /* Look in prev_saved_doc_string the same way. */
3736 else if (pos >= prev_saved_doc_string_position
3737 && pos < (prev_saved_doc_string_position
3738 + prev_saved_doc_string_length))
3740 saved = prev_saved_doc_string;
3741 saved_position = prev_saved_doc_string_position;
3743 if (saved)
3745 ptrdiff_t start = pos - saved_position;
3746 ptrdiff_t from, to;
3748 /* Process quoting with ^A,
3749 and find the end of the string,
3750 which is marked with ^_ (037). */
3751 for (from = start, to = start;
3752 saved[from] != 037;)
3754 int c = saved[from++];
3755 if (c == 1)
3757 c = saved[from++];
3758 saved[to++] = (c == 1 ? c
3759 : c == '0' ? 0
3760 : c == '_' ? 037
3761 : c);
3763 else
3764 saved[to++] = c;
3767 return make_unibyte_string (saved + start,
3768 to - start);
3770 else
3771 return get_doc_string (val, 1, 0);
3774 return val;
3776 invalid_syntax (". in wrong context");
3778 invalid_syntax ("] in a list");
3780 tem = list1 (elt);
3781 if (!NILP (tail))
3782 XSETCDR (tail, tem);
3783 else
3784 val = tem;
3785 tail = tem;
3789 static Lisp_Object initial_obarray;
3791 /* `oblookup' stores the bucket number here, for the sake of Funintern. */
3793 static size_t oblookup_last_bucket_number;
3795 /* Get an error if OBARRAY is not an obarray.
3796 If it is one, return it. */
3798 Lisp_Object
3799 check_obarray (Lisp_Object obarray)
3801 /* We don't want to signal a wrong-type-argument error when we are
3802 shutting down due to a fatal error, and we don't want to hit
3803 assertions in VECTORP and ASIZE if the fatal error was during GC. */
3804 if (!fatal_error_in_progress
3805 && (!VECTORP (obarray) || ASIZE (obarray) == 0))
3807 /* If Vobarray is now invalid, force it to be valid. */
3808 if (EQ (Vobarray, obarray)) Vobarray = initial_obarray;
3809 wrong_type_argument (Qvectorp, obarray);
3811 return obarray;
3814 /* Intern symbol SYM in OBARRAY using bucket INDEX. */
3816 static Lisp_Object
3817 intern_sym (Lisp_Object sym, Lisp_Object obarray, Lisp_Object index)
3819 Lisp_Object *ptr;
3821 XSYMBOL (sym)->interned = (EQ (obarray, initial_obarray)
3822 ? SYMBOL_INTERNED_IN_INITIAL_OBARRAY
3823 : SYMBOL_INTERNED);
3825 if (SREF (SYMBOL_NAME (sym), 0) == ':' && EQ (obarray, initial_obarray))
3827 XSYMBOL (sym)->constant = 1;
3828 XSYMBOL (sym)->redirect = SYMBOL_PLAINVAL;
3829 SET_SYMBOL_VAL (XSYMBOL (sym), sym);
3832 ptr = aref_addr (obarray, XINT (index));
3833 set_symbol_next (sym, SYMBOLP (*ptr) ? XSYMBOL (*ptr) : NULL);
3834 *ptr = sym;
3835 return sym;
3838 /* Intern a symbol with name STRING in OBARRAY using bucket INDEX. */
3840 Lisp_Object
3841 intern_driver (Lisp_Object string, Lisp_Object obarray, Lisp_Object index)
3843 return intern_sym (Fmake_symbol (string), obarray, index);
3846 /* Intern the C string STR: return a symbol with that name,
3847 interned in the current obarray. */
3849 Lisp_Object
3850 intern_1 (const char *str, ptrdiff_t len)
3852 Lisp_Object obarray = check_obarray (Vobarray);
3853 Lisp_Object tem = oblookup (obarray, str, len, len);
3855 return (SYMBOLP (tem) ? tem
3856 /* The above `oblookup' was done on the basis of nchars==nbytes, so
3857 the string has to be unibyte. */
3858 : intern_driver (make_unibyte_string (str, len),
3859 obarray, tem));
3862 Lisp_Object
3863 intern_c_string_1 (const char *str, ptrdiff_t len)
3865 Lisp_Object obarray = check_obarray (Vobarray);
3866 Lisp_Object tem = oblookup (obarray, str, len, len);
3868 if (!SYMBOLP (tem))
3870 /* Creating a non-pure string from a string literal not implemented yet.
3871 We could just use make_string here and live with the extra copy. */
3872 eassert (!NILP (Vpurify_flag));
3873 tem = intern_driver (make_pure_c_string (str, len), obarray, tem);
3875 return tem;
3878 static void
3879 define_symbol (Lisp_Object sym, char const *str)
3881 ptrdiff_t len = strlen (str);
3882 Lisp_Object string = make_pure_c_string (str, len);
3883 init_symbol (sym, string);
3885 /* Qunbound is uninterned, so that it's not confused with any symbol
3886 'unbound' created by a Lisp program. */
3887 if (! EQ (sym, Qunbound))
3889 Lisp_Object bucket = oblookup (initial_obarray, str, len, len);
3890 eassert (INTEGERP (bucket));
3891 intern_sym (sym, initial_obarray, bucket);
3895 DEFUN ("intern", Fintern, Sintern, 1, 2, 0,
3896 doc: /* Return the canonical symbol whose name is STRING.
3897 If there is none, one is created by this function and returned.
3898 A second optional argument specifies the obarray to use;
3899 it defaults to the value of `obarray'. */)
3900 (Lisp_Object string, Lisp_Object obarray)
3902 Lisp_Object tem;
3904 obarray = check_obarray (NILP (obarray) ? Vobarray : obarray);
3905 CHECK_STRING (string);
3907 tem = oblookup (obarray, SSDATA (string), SCHARS (string), SBYTES (string));
3908 if (!SYMBOLP (tem))
3909 tem = intern_driver (NILP (Vpurify_flag) ? string : Fpurecopy (string),
3910 obarray, tem);
3911 return tem;
3914 DEFUN ("intern-soft", Fintern_soft, Sintern_soft, 1, 2, 0,
3915 doc: /* Return the canonical symbol named NAME, or nil if none exists.
3916 NAME may be a string or a symbol. If it is a symbol, that exact
3917 symbol is searched for.
3918 A second optional argument specifies the obarray to use;
3919 it defaults to the value of `obarray'. */)
3920 (Lisp_Object name, Lisp_Object obarray)
3922 register Lisp_Object tem, string;
3924 if (NILP (obarray)) obarray = Vobarray;
3925 obarray = check_obarray (obarray);
3927 if (!SYMBOLP (name))
3929 CHECK_STRING (name);
3930 string = name;
3932 else
3933 string = SYMBOL_NAME (name);
3935 tem = oblookup (obarray, SSDATA (string), SCHARS (string), SBYTES (string));
3936 if (INTEGERP (tem) || (SYMBOLP (name) && !EQ (name, tem)))
3937 return Qnil;
3938 else
3939 return tem;
3942 DEFUN ("unintern", Funintern, Sunintern, 1, 2, 0,
3943 doc: /* Delete the symbol named NAME, if any, from OBARRAY.
3944 The value is t if a symbol was found and deleted, nil otherwise.
3945 NAME may be a string or a symbol. If it is a symbol, that symbol
3946 is deleted, if it belongs to OBARRAY--no other symbol is deleted.
3947 OBARRAY, if nil, defaults to the value of the variable `obarray'.
3948 usage: (unintern NAME OBARRAY) */)
3949 (Lisp_Object name, Lisp_Object obarray)
3951 register Lisp_Object string, tem;
3952 size_t hash;
3954 if (NILP (obarray)) obarray = Vobarray;
3955 obarray = check_obarray (obarray);
3957 if (SYMBOLP (name))
3958 string = SYMBOL_NAME (name);
3959 else
3961 CHECK_STRING (name);
3962 string = name;
3965 tem = oblookup (obarray, SSDATA (string),
3966 SCHARS (string),
3967 SBYTES (string));
3968 if (INTEGERP (tem))
3969 return Qnil;
3970 /* If arg was a symbol, don't delete anything but that symbol itself. */
3971 if (SYMBOLP (name) && !EQ (name, tem))
3972 return Qnil;
3974 /* There are plenty of other symbols which will screw up the Emacs
3975 session if we unintern them, as well as even more ways to use
3976 `setq' or `fset' or whatnot to make the Emacs session
3977 unusable. Let's not go down this silly road. --Stef */
3978 /* if (EQ (tem, Qnil) || EQ (tem, Qt))
3979 error ("Attempt to unintern t or nil"); */
3981 XSYMBOL (tem)->interned = SYMBOL_UNINTERNED;
3983 hash = oblookup_last_bucket_number;
3985 if (EQ (AREF (obarray, hash), tem))
3987 if (XSYMBOL (tem)->next)
3989 Lisp_Object sym;
3990 XSETSYMBOL (sym, XSYMBOL (tem)->next);
3991 ASET (obarray, hash, sym);
3993 else
3994 ASET (obarray, hash, make_number (0));
3996 else
3998 Lisp_Object tail, following;
4000 for (tail = AREF (obarray, hash);
4001 XSYMBOL (tail)->next;
4002 tail = following)
4004 XSETSYMBOL (following, XSYMBOL (tail)->next);
4005 if (EQ (following, tem))
4007 set_symbol_next (tail, XSYMBOL (following)->next);
4008 break;
4013 return Qt;
4016 /* Return the symbol in OBARRAY whose names matches the string
4017 of SIZE characters (SIZE_BYTE bytes) at PTR.
4018 If there is no such symbol, return the integer bucket number of
4019 where the symbol would be if it were present.
4021 Also store the bucket number in oblookup_last_bucket_number. */
4023 Lisp_Object
4024 oblookup (Lisp_Object obarray, register const char *ptr, ptrdiff_t size, ptrdiff_t size_byte)
4026 size_t hash;
4027 size_t obsize;
4028 register Lisp_Object tail;
4029 Lisp_Object bucket, tem;
4031 obarray = check_obarray (obarray);
4032 /* This is sometimes needed in the middle of GC. */
4033 obsize = gc_asize (obarray);
4034 hash = hash_string (ptr, size_byte) % obsize;
4035 bucket = AREF (obarray, hash);
4036 oblookup_last_bucket_number = hash;
4037 if (EQ (bucket, make_number (0)))
4039 else if (!SYMBOLP (bucket))
4040 error ("Bad data in guts of obarray"); /* Like CADR error message. */
4041 else
4042 for (tail = bucket; ; XSETSYMBOL (tail, XSYMBOL (tail)->next))
4044 if (SBYTES (SYMBOL_NAME (tail)) == size_byte
4045 && SCHARS (SYMBOL_NAME (tail)) == size
4046 && !memcmp (SDATA (SYMBOL_NAME (tail)), ptr, size_byte))
4047 return tail;
4048 else if (XSYMBOL (tail)->next == 0)
4049 break;
4051 XSETINT (tem, hash);
4052 return tem;
4055 void
4056 map_obarray (Lisp_Object obarray, void (*fn) (Lisp_Object, Lisp_Object), Lisp_Object arg)
4058 ptrdiff_t i;
4059 register Lisp_Object tail;
4060 CHECK_VECTOR (obarray);
4061 for (i = ASIZE (obarray) - 1; i >= 0; i--)
4063 tail = AREF (obarray, i);
4064 if (SYMBOLP (tail))
4065 while (1)
4067 (*fn) (tail, arg);
4068 if (XSYMBOL (tail)->next == 0)
4069 break;
4070 XSETSYMBOL (tail, XSYMBOL (tail)->next);
4075 static void
4076 mapatoms_1 (Lisp_Object sym, Lisp_Object function)
4078 call1 (function, sym);
4081 DEFUN ("mapatoms", Fmapatoms, Smapatoms, 1, 2, 0,
4082 doc: /* Call FUNCTION on every symbol in OBARRAY.
4083 OBARRAY defaults to the value of `obarray'. */)
4084 (Lisp_Object function, Lisp_Object obarray)
4086 if (NILP (obarray)) obarray = Vobarray;
4087 obarray = check_obarray (obarray);
4089 map_obarray (obarray, mapatoms_1, function);
4090 return Qnil;
4093 #define OBARRAY_SIZE 1511
4095 void
4096 init_obarray (void)
4098 Lisp_Object oblength;
4099 ptrdiff_t size = 100 + MAX_MULTIBYTE_LENGTH;
4101 XSETFASTINT (oblength, OBARRAY_SIZE);
4103 Vobarray = Fmake_vector (oblength, make_number (0));
4104 initial_obarray = Vobarray;
4105 staticpro (&initial_obarray);
4107 for (int i = 0; i < ARRAYELTS (lispsym); i++)
4108 define_symbol (builtin_lisp_symbol (i), defsym_name[i]);
4110 DEFSYM (Qunbound, "unbound");
4112 DEFSYM (Qnil, "nil");
4113 SET_SYMBOL_VAL (XSYMBOL (Qnil), Qnil);
4114 XSYMBOL (Qnil)->constant = 1;
4115 XSYMBOL (Qnil)->declared_special = true;
4117 DEFSYM (Qt, "t");
4118 SET_SYMBOL_VAL (XSYMBOL (Qt), Qt);
4119 XSYMBOL (Qt)->constant = 1;
4120 XSYMBOL (Qt)->declared_special = true;
4122 /* Qt is correct even if CANNOT_DUMP. loadup.el will set to nil at end. */
4123 Vpurify_flag = Qt;
4125 DEFSYM (Qvariable_documentation, "variable-documentation");
4127 read_buffer = xmalloc (size);
4128 read_buffer_size = size;
4131 void
4132 defsubr (struct Lisp_Subr *sname)
4134 Lisp_Object sym, tem;
4135 sym = intern_c_string (sname->symbol_name);
4136 XSETPVECTYPE (sname, PVEC_SUBR);
4137 XSETSUBR (tem, sname);
4138 set_symbol_function (sym, tem);
4141 #ifdef NOTDEF /* Use fset in subr.el now! */
4142 void
4143 defalias (struct Lisp_Subr *sname, char *string)
4145 Lisp_Object sym;
4146 sym = intern (string);
4147 XSETSUBR (XSYMBOL (sym)->function, sname);
4149 #endif /* NOTDEF */
4151 /* Define an "integer variable"; a symbol whose value is forwarded to a
4152 C variable of type EMACS_INT. Sample call (with "xx" to fool make-docfile):
4153 DEFxxVAR_INT ("emacs-priority", &emacs_priority, "Documentation"); */
4154 void
4155 defvar_int (struct Lisp_Intfwd *i_fwd,
4156 const char *namestring, EMACS_INT *address)
4158 Lisp_Object sym;
4159 sym = intern_c_string (namestring);
4160 i_fwd->type = Lisp_Fwd_Int;
4161 i_fwd->intvar = address;
4162 XSYMBOL (sym)->declared_special = 1;
4163 XSYMBOL (sym)->redirect = SYMBOL_FORWARDED;
4164 SET_SYMBOL_FWD (XSYMBOL (sym), (union Lisp_Fwd *)i_fwd);
4167 /* Similar but define a variable whose value is t if address contains 1,
4168 nil if address contains 0. */
4169 void
4170 defvar_bool (struct Lisp_Boolfwd *b_fwd,
4171 const char *namestring, bool *address)
4173 Lisp_Object sym;
4174 sym = intern_c_string (namestring);
4175 b_fwd->type = Lisp_Fwd_Bool;
4176 b_fwd->boolvar = address;
4177 XSYMBOL (sym)->declared_special = 1;
4178 XSYMBOL (sym)->redirect = SYMBOL_FORWARDED;
4179 SET_SYMBOL_FWD (XSYMBOL (sym), (union Lisp_Fwd *)b_fwd);
4180 Vbyte_boolean_vars = Fcons (sym, Vbyte_boolean_vars);
4183 /* Similar but define a variable whose value is the Lisp Object stored
4184 at address. Two versions: with and without gc-marking of the C
4185 variable. The nopro version is used when that variable will be
4186 gc-marked for some other reason, since marking the same slot twice
4187 can cause trouble with strings. */
4188 void
4189 defvar_lisp_nopro (struct Lisp_Objfwd *o_fwd,
4190 const char *namestring, Lisp_Object *address)
4192 Lisp_Object sym;
4193 sym = intern_c_string (namestring);
4194 o_fwd->type = Lisp_Fwd_Obj;
4195 o_fwd->objvar = address;
4196 XSYMBOL (sym)->declared_special = 1;
4197 XSYMBOL (sym)->redirect = SYMBOL_FORWARDED;
4198 SET_SYMBOL_FWD (XSYMBOL (sym), (union Lisp_Fwd *)o_fwd);
4201 void
4202 defvar_lisp (struct Lisp_Objfwd *o_fwd,
4203 const char *namestring, Lisp_Object *address)
4205 defvar_lisp_nopro (o_fwd, namestring, address);
4206 staticpro (address);
4209 /* Similar but define a variable whose value is the Lisp Object stored
4210 at a particular offset in the current kboard object. */
4212 void
4213 defvar_kboard (struct Lisp_Kboard_Objfwd *ko_fwd,
4214 const char *namestring, int offset)
4216 Lisp_Object sym;
4217 sym = intern_c_string (namestring);
4218 ko_fwd->type = Lisp_Fwd_Kboard_Obj;
4219 ko_fwd->offset = offset;
4220 XSYMBOL (sym)->declared_special = 1;
4221 XSYMBOL (sym)->redirect = SYMBOL_FORWARDED;
4222 SET_SYMBOL_FWD (XSYMBOL (sym), (union Lisp_Fwd *)ko_fwd);
4225 /* Check that the elements of lpath exist. */
4227 static void
4228 load_path_check (Lisp_Object lpath)
4230 Lisp_Object path_tail;
4232 /* The only elements that might not exist are those from
4233 PATH_LOADSEARCH, EMACSLOADPATH. Anything else is only added if
4234 it exists. */
4235 for (path_tail = lpath; !NILP (path_tail); path_tail = XCDR (path_tail))
4237 Lisp_Object dirfile;
4238 dirfile = Fcar (path_tail);
4239 if (STRINGP (dirfile))
4241 dirfile = Fdirectory_file_name (dirfile);
4242 if (! file_accessible_directory_p (dirfile))
4243 dir_warning ("Lisp directory", XCAR (path_tail));
4248 /* Return the default load-path, to be used if EMACSLOADPATH is unset.
4249 This does not include the standard site-lisp directories
4250 under the installation prefix (i.e., PATH_SITELOADSEARCH),
4251 but it does (unless no_site_lisp is set) include site-lisp
4252 directories in the source/build directories if those exist and we
4253 are running uninstalled.
4255 Uses the following logic:
4256 If CANNOT_DUMP: Use PATH_LOADSEARCH.
4257 The remainder is what happens when dumping works:
4258 If purify-flag (ie dumping) just use PATH_DUMPLOADSEARCH.
4259 Otherwise use PATH_LOADSEARCH.
4261 If !initialized, then just return PATH_DUMPLOADSEARCH.
4262 If initialized:
4263 If Vinstallation_directory is not nil (ie, running uninstalled):
4264 If installation-dir/lisp exists and not already a member,
4265 we must be running uninstalled. Reset the load-path
4266 to just installation-dir/lisp. (The default PATH_LOADSEARCH
4267 refers to the eventual installation directories. Since we
4268 are not yet installed, we should not use them, even if they exist.)
4269 If installation-dir/lisp does not exist, just add
4270 PATH_DUMPLOADSEARCH at the end instead.
4271 Add installation-dir/site-lisp (if !no_site_lisp, and exists
4272 and not already a member) at the front.
4273 If installation-dir != source-dir (ie running an uninstalled,
4274 out-of-tree build) AND install-dir/src/Makefile exists BUT
4275 install-dir/src/Makefile.in does NOT exist (this is a sanity
4276 check), then repeat the above steps for source-dir/lisp, site-lisp. */
4278 static Lisp_Object
4279 load_path_default (void)
4281 Lisp_Object lpath = Qnil;
4282 const char *normal;
4284 #ifdef CANNOT_DUMP
4285 #ifdef HAVE_NS
4286 const char *loadpath = ns_load_path ();
4287 #endif
4289 normal = PATH_LOADSEARCH;
4290 #ifdef HAVE_NS
4291 lpath = decode_env_path (0, loadpath ? loadpath : normal, 0);
4292 #else
4293 lpath = decode_env_path (0, normal, 0);
4294 #endif
4296 #else /* !CANNOT_DUMP */
4298 normal = NILP (Vpurify_flag) ? PATH_LOADSEARCH : PATH_DUMPLOADSEARCH;
4300 if (initialized)
4302 #ifdef HAVE_NS
4303 const char *loadpath = ns_load_path ();
4304 lpath = decode_env_path (0, loadpath ? loadpath : normal, 0);
4305 #else
4306 lpath = decode_env_path (0, normal, 0);
4307 #endif
4308 if (!NILP (Vinstallation_directory))
4310 Lisp_Object tem, tem1;
4312 /* Add to the path the lisp subdir of the installation
4313 dir, if it is accessible. Note: in out-of-tree builds,
4314 this directory is empty save for Makefile. */
4315 tem = Fexpand_file_name (build_string ("lisp"),
4316 Vinstallation_directory);
4317 tem1 = Ffile_accessible_directory_p (tem);
4318 if (!NILP (tem1))
4320 if (NILP (Fmember (tem, lpath)))
4322 /* We are running uninstalled. The default load-path
4323 points to the eventual installed lisp directories.
4324 We should not use those now, even if they exist,
4325 so start over from a clean slate. */
4326 lpath = list1 (tem);
4329 else
4330 /* That dir doesn't exist, so add the build-time
4331 Lisp dirs instead. */
4333 Lisp_Object dump_path =
4334 decode_env_path (0, PATH_DUMPLOADSEARCH, 0);
4335 lpath = nconc2 (lpath, dump_path);
4338 /* Add site-lisp under the installation dir, if it exists. */
4339 if (!no_site_lisp)
4341 tem = Fexpand_file_name (build_string ("site-lisp"),
4342 Vinstallation_directory);
4343 tem1 = Ffile_accessible_directory_p (tem);
4344 if (!NILP (tem1))
4346 if (NILP (Fmember (tem, lpath)))
4347 lpath = Fcons (tem, lpath);
4351 /* If Emacs was not built in the source directory,
4352 and it is run from where it was built, add to load-path
4353 the lisp and site-lisp dirs under that directory. */
4355 if (NILP (Fequal (Vinstallation_directory, Vsource_directory)))
4357 Lisp_Object tem2;
4359 tem = Fexpand_file_name (build_string ("src/Makefile"),
4360 Vinstallation_directory);
4361 tem1 = Ffile_exists_p (tem);
4363 /* Don't be fooled if they moved the entire source tree
4364 AFTER dumping Emacs. If the build directory is indeed
4365 different from the source dir, src/Makefile.in and
4366 src/Makefile will not be found together. */
4367 tem = Fexpand_file_name (build_string ("src/Makefile.in"),
4368 Vinstallation_directory);
4369 tem2 = Ffile_exists_p (tem);
4370 if (!NILP (tem1) && NILP (tem2))
4372 tem = Fexpand_file_name (build_string ("lisp"),
4373 Vsource_directory);
4375 if (NILP (Fmember (tem, lpath)))
4376 lpath = Fcons (tem, lpath);
4378 if (!no_site_lisp)
4380 tem = Fexpand_file_name (build_string ("site-lisp"),
4381 Vsource_directory);
4382 tem1 = Ffile_accessible_directory_p (tem);
4383 if (!NILP (tem1))
4385 if (NILP (Fmember (tem, lpath)))
4386 lpath = Fcons (tem, lpath);
4390 } /* Vinstallation_directory != Vsource_directory */
4392 } /* if Vinstallation_directory */
4394 else /* !initialized */
4396 /* NORMAL refers to PATH_DUMPLOADSEARCH, ie the lisp dir in the
4397 source directory. We used to add ../lisp (ie the lisp dir in
4398 the build directory) at the front here, but that should not
4399 be necessary, since in out of tree builds lisp/ is empty, save
4400 for Makefile. */
4401 lpath = decode_env_path (0, normal, 0);
4403 #endif /* !CANNOT_DUMP */
4405 return lpath;
4408 void
4409 init_lread (void)
4411 /* First, set Vload_path. */
4413 /* Ignore EMACSLOADPATH when dumping. */
4414 #ifdef CANNOT_DUMP
4415 bool use_loadpath = true;
4416 #else
4417 bool use_loadpath = NILP (Vpurify_flag);
4418 #endif
4420 if (use_loadpath && egetenv ("EMACSLOADPATH"))
4422 Vload_path = decode_env_path ("EMACSLOADPATH", 0, 1);
4424 /* Check (non-nil) user-supplied elements. */
4425 load_path_check (Vload_path);
4427 /* If no nils in the environment variable, use as-is.
4428 Otherwise, replace any nils with the default. */
4429 if (! NILP (Fmemq (Qnil, Vload_path)))
4431 Lisp_Object elem, elpath = Vload_path;
4432 Lisp_Object default_lpath = load_path_default ();
4434 /* Check defaults, before adding site-lisp. */
4435 load_path_check (default_lpath);
4437 /* Add the site-lisp directories to the front of the default. */
4438 if (!no_site_lisp && PATH_SITELOADSEARCH[0] != '\0')
4440 Lisp_Object sitelisp;
4441 sitelisp = decode_env_path (0, PATH_SITELOADSEARCH, 0);
4442 if (! NILP (sitelisp))
4443 default_lpath = nconc2 (sitelisp, default_lpath);
4446 Vload_path = Qnil;
4448 /* Replace nils from EMACSLOADPATH by default. */
4449 while (CONSP (elpath))
4451 elem = XCAR (elpath);
4452 elpath = XCDR (elpath);
4453 Vload_path = CALLN (Fappend, Vload_path,
4454 NILP (elem) ? default_lpath : list1 (elem));
4456 } /* Fmemq (Qnil, Vload_path) */
4458 else
4460 Vload_path = load_path_default ();
4462 /* Check before adding site-lisp directories.
4463 The install should have created them, but they are not
4464 required, so no need to warn if they are absent.
4465 Or we might be running before installation. */
4466 load_path_check (Vload_path);
4468 /* Add the site-lisp directories at the front. */
4469 if (initialized && !no_site_lisp && PATH_SITELOADSEARCH[0] != '\0')
4471 Lisp_Object sitelisp;
4472 sitelisp = decode_env_path (0, PATH_SITELOADSEARCH, 0);
4473 if (! NILP (sitelisp)) Vload_path = nconc2 (sitelisp, Vload_path);
4477 Vvalues = Qnil;
4479 load_in_progress = 0;
4480 Vload_file_name = Qnil;
4481 Vstandard_input = Qt;
4482 Vloads_in_progress = Qnil;
4485 /* Print a warning that directory intended for use USE and with name
4486 DIRNAME cannot be accessed. On entry, errno should correspond to
4487 the access failure. Print the warning on stderr and put it in
4488 *Messages*. */
4490 void
4491 dir_warning (char const *use, Lisp_Object dirname)
4493 static char const format[] = "Warning: %s '%s': %s\n";
4494 char *diagnostic = emacs_strerror (errno);
4495 fprintf (stderr, format, use, SSDATA (ENCODE_SYSTEM (dirname)), diagnostic);
4497 /* Don't log the warning before we've initialized!! */
4498 if (initialized)
4500 ptrdiff_t diaglen = strlen (diagnostic);
4501 AUTO_STRING_WITH_LEN (diag, diagnostic, diaglen);
4502 if (! NILP (Vlocale_coding_system))
4504 Lisp_Object s
4505 = code_convert_string_norecord (diag, Vlocale_coding_system, false);
4506 diagnostic = SSDATA (s);
4507 diaglen = SBYTES (s);
4509 USE_SAFE_ALLOCA;
4510 char *buffer = SAFE_ALLOCA (sizeof format - 3 * (sizeof "%s" - 1)
4511 + strlen (use) + SBYTES (dirname) + diaglen);
4512 ptrdiff_t message_len = esprintf (buffer, format, use, SSDATA (dirname),
4513 diagnostic);
4514 message_dolog (buffer, message_len, 0, STRING_MULTIBYTE (dirname));
4515 SAFE_FREE ();
4519 void
4520 syms_of_lread (void)
4522 defsubr (&Sread);
4523 defsubr (&Sread_from_string);
4524 defsubr (&Sintern);
4525 defsubr (&Sintern_soft);
4526 defsubr (&Sunintern);
4527 defsubr (&Sget_load_suffixes);
4528 defsubr (&Sload);
4529 defsubr (&Seval_buffer);
4530 defsubr (&Seval_region);
4531 defsubr (&Sread_char);
4532 defsubr (&Sread_char_exclusive);
4533 defsubr (&Sread_event);
4534 defsubr (&Sget_file_char);
4535 defsubr (&Smapatoms);
4536 defsubr (&Slocate_file_internal);
4538 DEFVAR_LISP ("obarray", Vobarray,
4539 doc: /* Symbol table for use by `intern' and `read'.
4540 It is a vector whose length ought to be prime for best results.
4541 The vector's contents don't make sense if examined from Lisp programs;
4542 to find all the symbols in an obarray, use `mapatoms'. */);
4544 DEFVAR_LISP ("values", Vvalues,
4545 doc: /* List of values of all expressions which were read, evaluated and printed.
4546 Order is reverse chronological. */);
4547 XSYMBOL (intern ("values"))->declared_special = 0;
4549 DEFVAR_LISP ("standard-input", Vstandard_input,
4550 doc: /* Stream for read to get input from.
4551 See documentation of `read' for possible values. */);
4552 Vstandard_input = Qt;
4554 DEFVAR_LISP ("read-with-symbol-positions", Vread_with_symbol_positions,
4555 doc: /* If non-nil, add position of read symbols to `read-symbol-positions-list'.
4557 If this variable is a buffer, then only forms read from that buffer
4558 will be added to `read-symbol-positions-list'.
4559 If this variable is t, then all read forms will be added.
4560 The effect of all other values other than nil are not currently
4561 defined, although they may be in the future.
4563 The positions are relative to the last call to `read' or
4564 `read-from-string'. It is probably a bad idea to set this variable at
4565 the toplevel; bind it instead. */);
4566 Vread_with_symbol_positions = Qnil;
4568 DEFVAR_LISP ("read-symbol-positions-list", Vread_symbol_positions_list,
4569 doc: /* A list mapping read symbols to their positions.
4570 This variable is modified during calls to `read' or
4571 `read-from-string', but only when `read-with-symbol-positions' is
4572 non-nil.
4574 Each element of the list looks like (SYMBOL . CHAR-POSITION), where
4575 CHAR-POSITION is an integer giving the offset of that occurrence of the
4576 symbol from the position where `read' or `read-from-string' started.
4578 Note that a symbol will appear multiple times in this list, if it was
4579 read multiple times. The list is in the same order as the symbols
4580 were read in. */);
4581 Vread_symbol_positions_list = Qnil;
4583 DEFVAR_LISP ("read-circle", Vread_circle,
4584 doc: /* Non-nil means read recursive structures using #N= and #N# syntax. */);
4585 Vread_circle = Qt;
4587 DEFVAR_LISP ("load-path", Vload_path,
4588 doc: /* List of directories to search for files to load.
4589 Each element is a string (directory file name) or nil (meaning
4590 `default-directory').
4591 This list is consulted by the `require' function.
4592 Initialized during startup as described in Info node `(elisp)Library Search'.
4593 Use `directory-file-name' when adding items to this path. However, Lisp
4594 programs that process this list should tolerate directories both with
4595 and without trailing slashes. */);
4597 DEFVAR_LISP ("load-suffixes", Vload_suffixes,
4598 doc: /* List of suffixes for Emacs Lisp files and dynamic modules.
4599 This list includes suffixes for both compiled and source Emacs Lisp files.
4600 This list should not include the empty string.
4601 `load' and related functions try to append these suffixes, in order,
4602 to the specified file name if a suffix is allowed or required. */);
4603 #ifdef HAVE_MODULES
4604 Vload_suffixes = list3 (build_pure_c_string (".elc"),
4605 build_pure_c_string (".el"),
4606 build_pure_c_string (MODULES_SUFFIX));
4607 #else
4608 Vload_suffixes = list2 (build_pure_c_string (".elc"),
4609 build_pure_c_string (".el"));
4610 #endif
4611 DEFVAR_LISP ("module-file-suffix", Vmodule_file_suffix,
4612 doc: /* Suffix of loadable module file, or nil of modules are not supported. */);
4613 #ifdef HAVE_MODULES
4614 Vmodule_file_suffix = build_pure_c_string (MODULES_SUFFIX);
4615 #else
4616 Vmodule_file_suffix = Qnil;
4617 #endif
4618 DEFVAR_LISP ("load-file-rep-suffixes", Vload_file_rep_suffixes,
4619 doc: /* List of suffixes that indicate representations of \
4620 the same file.
4621 This list should normally start with the empty string.
4623 Enabling Auto Compression mode appends the suffixes in
4624 `jka-compr-load-suffixes' to this list and disabling Auto Compression
4625 mode removes them again. `load' and related functions use this list to
4626 determine whether they should look for compressed versions of a file
4627 and, if so, which suffixes they should try to append to the file name
4628 in order to do so. However, if you want to customize which suffixes
4629 the loading functions recognize as compression suffixes, you should
4630 customize `jka-compr-load-suffixes' rather than the present variable. */);
4631 Vload_file_rep_suffixes = list1 (empty_unibyte_string);
4633 DEFVAR_BOOL ("load-in-progress", load_in_progress,
4634 doc: /* Non-nil if inside of `load'. */);
4635 DEFSYM (Qload_in_progress, "load-in-progress");
4637 DEFVAR_LISP ("after-load-alist", Vafter_load_alist,
4638 doc: /* An alist of functions to be evalled when particular files are loaded.
4639 Each element looks like (REGEXP-OR-FEATURE FUNCS...).
4641 REGEXP-OR-FEATURE is either a regular expression to match file names, or
4642 a symbol (a feature name).
4644 When `load' is run and the file-name argument matches an element's
4645 REGEXP-OR-FEATURE, or when `provide' is run and provides the symbol
4646 REGEXP-OR-FEATURE, the FUNCS in the element are called.
4648 An error in FORMS does not undo the load, but does prevent execution of
4649 the rest of the FORMS. */);
4650 Vafter_load_alist = Qnil;
4652 DEFVAR_LISP ("load-history", Vload_history,
4653 doc: /* Alist mapping loaded file names to symbols and features.
4654 Each alist element should be a list (FILE-NAME ENTRIES...), where
4655 FILE-NAME is the name of a file that has been loaded into Emacs.
4656 The file name is absolute and true (i.e. it doesn't contain symlinks).
4657 As an exception, one of the alist elements may have FILE-NAME nil,
4658 for symbols and features not associated with any file.
4660 The remaining ENTRIES in the alist element describe the functions and
4661 variables defined in that file, the features provided, and the
4662 features required. Each entry has the form `(provide . FEATURE)',
4663 `(require . FEATURE)', `(defun . FUNCTION)', `(autoload . SYMBOL)',
4664 `(defface . SYMBOL)', or `(t . SYMBOL)'. Entries like `(t . SYMBOL)'
4665 may precede a `(defun . FUNCTION)' entry, and means that SYMBOL was an
4666 autoload before this file redefined it as a function. In addition,
4667 entries may also be single symbols, which means that SYMBOL was
4668 defined by `defvar' or `defconst'.
4670 During preloading, the file name recorded is relative to the main Lisp
4671 directory. These file names are converted to absolute at startup. */);
4672 Vload_history = Qnil;
4674 DEFVAR_LISP ("load-file-name", Vload_file_name,
4675 doc: /* Full name of file being loaded by `load'. */);
4676 Vload_file_name = Qnil;
4678 DEFVAR_LISP ("user-init-file", Vuser_init_file,
4679 doc: /* File name, including directory, of user's initialization file.
4680 If the file loaded had extension `.elc', and the corresponding source file
4681 exists, this variable contains the name of source file, suitable for use
4682 by functions like `custom-save-all' which edit the init file.
4683 While Emacs loads and evaluates the init file, value is the real name
4684 of the file, regardless of whether or not it has the `.elc' extension. */);
4685 Vuser_init_file = Qnil;
4687 DEFVAR_LISP ("current-load-list", Vcurrent_load_list,
4688 doc: /* Used for internal purposes by `load'. */);
4689 Vcurrent_load_list = Qnil;
4691 DEFVAR_LISP ("load-read-function", Vload_read_function,
4692 doc: /* Function used by `load' and `eval-region' for reading expressions.
4693 Called with a single argument (the stream from which to read).
4694 The default is to use the function `read'. */);
4695 DEFSYM (Qread, "read");
4696 Vload_read_function = Qread;
4698 DEFVAR_LISP ("load-source-file-function", Vload_source_file_function,
4699 doc: /* Function called in `load' to load an Emacs Lisp source file.
4700 The value should be a function for doing code conversion before
4701 reading a source file. It can also be nil, in which case loading is
4702 done without any code conversion.
4704 If the value is a function, it is called with four arguments,
4705 FULLNAME, FILE, NOERROR, NOMESSAGE. FULLNAME is the absolute name of
4706 the file to load, FILE is the non-absolute name (for messages etc.),
4707 and NOERROR and NOMESSAGE are the corresponding arguments passed to
4708 `load'. The function should return t if the file was loaded. */);
4709 Vload_source_file_function = Qnil;
4711 DEFVAR_BOOL ("load-force-doc-strings", load_force_doc_strings,
4712 doc: /* Non-nil means `load' should force-load all dynamic doc strings.
4713 This is useful when the file being loaded is a temporary copy. */);
4714 load_force_doc_strings = 0;
4716 DEFVAR_BOOL ("load-convert-to-unibyte", load_convert_to_unibyte,
4717 doc: /* Non-nil means `read' converts strings to unibyte whenever possible.
4718 This is normally bound by `load' and `eval-buffer' to control `read',
4719 and is not meant for users to change. */);
4720 load_convert_to_unibyte = 0;
4722 DEFVAR_LISP ("source-directory", Vsource_directory,
4723 doc: /* Directory in which Emacs sources were found when Emacs was built.
4724 You cannot count on them to still be there! */);
4725 Vsource_directory
4726 = Fexpand_file_name (build_string ("../"),
4727 Fcar (decode_env_path (0, PATH_DUMPLOADSEARCH, 0)));
4729 DEFVAR_LISP ("preloaded-file-list", Vpreloaded_file_list,
4730 doc: /* List of files that were preloaded (when dumping Emacs). */);
4731 Vpreloaded_file_list = Qnil;
4733 DEFVAR_LISP ("byte-boolean-vars", Vbyte_boolean_vars,
4734 doc: /* List of all DEFVAR_BOOL variables, used by the byte code optimizer. */);
4735 Vbyte_boolean_vars = Qnil;
4737 DEFVAR_BOOL ("load-dangerous-libraries", load_dangerous_libraries,
4738 doc: /* Non-nil means load dangerous compiled Lisp files.
4739 Some versions of XEmacs use different byte codes than Emacs. These
4740 incompatible byte codes can make Emacs crash when it tries to execute
4741 them. */);
4742 load_dangerous_libraries = 0;
4744 DEFVAR_BOOL ("force-load-messages", force_load_messages,
4745 doc: /* Non-nil means force printing messages when loading Lisp files.
4746 This overrides the value of the NOMESSAGE argument to `load'. */);
4747 force_load_messages = 0;
4749 DEFVAR_LISP ("bytecomp-version-regexp", Vbytecomp_version_regexp,
4750 doc: /* Regular expression matching safe to load compiled Lisp files.
4751 When Emacs loads a compiled Lisp file, it reads the first 512 bytes
4752 from the file, and matches them against this regular expression.
4753 When the regular expression matches, the file is considered to be safe
4754 to load. See also `load-dangerous-libraries'. */);
4755 Vbytecomp_version_regexp
4756 = build_pure_c_string ("^;;;.\\(in Emacs version\\|bytecomp version FSF\\)");
4758 DEFSYM (Qlexical_binding, "lexical-binding");
4759 DEFVAR_LISP ("lexical-binding", Vlexical_binding,
4760 doc: /* Whether to use lexical binding when evaluating code.
4761 Non-nil means that the code in the current buffer should be evaluated
4762 with lexical binding.
4763 This variable is automatically set from the file variables of an
4764 interpreted Lisp file read using `load'. Unlike other file local
4765 variables, this must be set in the first line of a file. */);
4766 Vlexical_binding = Qnil;
4767 Fmake_variable_buffer_local (Qlexical_binding);
4769 DEFVAR_LISP ("eval-buffer-list", Veval_buffer_list,
4770 doc: /* List of buffers being read from by calls to `eval-buffer' and `eval-region'. */);
4771 Veval_buffer_list = Qnil;
4773 DEFVAR_LISP ("old-style-backquotes", Vold_style_backquotes,
4774 doc: /* Set to non-nil when `read' encounters an old-style backquote. */);
4775 Vold_style_backquotes = Qnil;
4776 DEFSYM (Qold_style_backquotes, "old-style-backquotes");
4778 DEFVAR_BOOL ("load-prefer-newer", load_prefer_newer,
4779 doc: /* Non-nil means `load' prefers the newest version of a file.
4780 This applies when a filename suffix is not explicitly specified and
4781 `load' is trying various possible suffixes (see `load-suffixes' and
4782 `load-file-rep-suffixes'). Normally, it stops at the first file
4783 that exists unless you explicitly specify one or the other. If this
4784 option is non-nil, it checks all suffixes and uses whichever file is
4785 newest.
4786 Note that if you customize this, obviously it will not affect files
4787 that are loaded before your customizations are read! */);
4788 load_prefer_newer = 0;
4790 /* Vsource_directory was initialized in init_lread. */
4792 DEFSYM (Qcurrent_load_list, "current-load-list");
4793 DEFSYM (Qstandard_input, "standard-input");
4794 DEFSYM (Qread_char, "read-char");
4795 DEFSYM (Qget_file_char, "get-file-char");
4797 /* Used instead of Qget_file_char while loading *.elc files compiled
4798 by Emacs 21 or older. */
4799 DEFSYM (Qget_emacs_mule_file_char, "get-emacs-mule-file-char");
4801 DEFSYM (Qload_force_doc_strings, "load-force-doc-strings");
4803 DEFSYM (Qbackquote, "`");
4804 DEFSYM (Qcomma, ",");
4805 DEFSYM (Qcomma_at, ",@");
4806 DEFSYM (Qcomma_dot, ",.");
4808 DEFSYM (Qinhibit_file_name_operation, "inhibit-file-name-operation");
4809 DEFSYM (Qascii_character, "ascii-character");
4810 DEFSYM (Qfunction, "function");
4811 DEFSYM (Qload, "load");
4812 DEFSYM (Qload_file_name, "load-file-name");
4813 DEFSYM (Qeval_buffer_list, "eval-buffer-list");
4814 DEFSYM (Qfile_truename, "file-truename");
4815 DEFSYM (Qdir_ok, "dir-ok");
4816 DEFSYM (Qdo_after_load_evaluation, "do-after-load-evaluation");
4818 staticpro (&read_objects);
4819 read_objects = Qnil;
4820 staticpro (&seen_list);
4821 seen_list = Qnil;
4823 Vloads_in_progress = Qnil;
4824 staticpro (&Vloads_in_progress);
4826 DEFSYM (Qhash_table, "hash-table");
4827 DEFSYM (Qdata, "data");
4828 DEFSYM (Qtest, "test");
4829 DEFSYM (Qsize, "size");
4830 DEFSYM (Qweakness, "weakness");
4831 DEFSYM (Qrehash_size, "rehash-size");
4832 DEFSYM (Qrehash_threshold, "rehash-threshold");
4834 DEFSYM (Qchar_from_name, "char-from-name");