1 /* Lisp parsing and input streams.
3 Copyright (C) 1985-1989, 1993-1995, 1997-2017 Free Software Foundation,
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
27 #include <sys/types.h>
32 #include <stat-time.h>
34 #include "dispextern.h"
35 #include "intervals.h"
36 #include "character.h"
43 #include "termhooks.h"
44 #include "blockinput.h"
49 #if __DJGPP__ == 2 && __DJGPP_MINOR__ < 5
50 # define INFINITY __builtin_inf()
51 # define NAN __builtin_nan("")
63 #endif /* HAVE_SETLOCALE */
68 #define file_offset off_t
69 #define file_tell ftello
71 #define file_offset long
72 #define file_tell ftell
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
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
),
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
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
;
160 readchar (Lisp_Object readcharfun
, bool *multibyte
)
164 int (*readbyte
) (int, Lisp_Object
);
165 unsigned char buf
[MAX_MULTIBYTE_LENGTH
];
167 bool emacs_mule_encoding
= 0;
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
))
183 if (pt_byte
>= BUF_ZV_BYTE (inbuffer
))
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
);
197 c
= BUF_FETCH_BYTE (inbuffer
, pt_byte
);
198 if (! ASCII_CHAR_P (c
))
199 c
= BYTE8_TO_CHAR (c
);
202 SET_BUF_PT_BOTH (inbuffer
, BUF_PT (inbuffer
) + 1, pt_byte
);
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
))
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
);
226 c
= BUF_FETCH_BYTE (inbuffer
, bytepos
);
227 if (! ASCII_CHAR_P (c
))
228 c
= BYTE8_TO_CHAR (c
);
232 XMARKER (readcharfun
)->bytepos
= bytepos
;
233 XMARKER (readcharfun
)->charpos
++;
238 if (EQ (readcharfun
, Qlambda
))
240 readbyte
= readbyte_for_lambda
;
244 if (EQ (readcharfun
, Qget_file_char
))
246 readbyte
= readbyte_from_file
;
250 if (STRINGP (readcharfun
))
252 if (read_from_string_index
>= read_from_string_limit
)
254 else if (STRING_MULTIBYTE (readcharfun
))
258 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, readcharfun
,
259 read_from_string_index
,
260 read_from_string_index_byte
);
264 c
= SREF (readcharfun
, read_from_string_index_byte
);
265 read_from_string_index
++;
266 read_from_string_index_byte
++;
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
278 readbyte
= readbyte_from_string
;
279 if (EQ (XCDR (readcharfun
), Qget_emacs_mule_file_char
))
280 emacs_mule_encoding
= 1;
284 if (EQ (readcharfun
, Qget_emacs_mule_file_char
))
286 readbyte
= readbyte_from_file
;
287 emacs_mule_encoding
= 1;
291 tem
= call0 (readcharfun
);
298 if (unread_char
>= 0)
304 c
= (*readbyte
) (-1, readcharfun
);
309 if (ASCII_CHAR_P (c
))
311 if (emacs_mule_encoding
)
312 return read_emacs_mule_char (c
, readbyte
, readcharfun
);
315 len
= BYTES_BY_CHAR_HEAD (c
);
318 c
= (*readbyte
) (-1, readcharfun
);
319 if (c
< 0 || ! TRAILING_CODE_P (c
))
322 (*readbyte
) (buf
[i
], readcharfun
);
323 return BYTE8_TO_CHAR (buf
[0]);
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))
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
);
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. */
353 } while (c
>= 0 && c
!= '\037');
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
);
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. */
374 unreadchar (Lisp_Object readcharfun
, int c
)
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
);
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
);
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
)))
417 else if (EQ (readcharfun
, Qlambda
))
421 else if (FROM_FILE_P (readcharfun
))
426 call1 (readcharfun
, make_number (c
));
430 readbyte_for_lambda (int c
, Lisp_Object readcharfun
)
432 return read_bytecode_char (c
>= 0);
437 readbyte_from_file (int c
, Lisp_Object readcharfun
)
442 ungetc (c
, instream
);
450 /* Interrupted reads have been observed while reading over the network. */
451 while (c
== EOF
&& ferror (instream
) && errno
== EINTR
)
462 return (c
== EOF
? -1 : c
);
466 readbyte_from_string (int c
, Lisp_Object readcharfun
)
468 Lisp_Object string
= XCAR (readcharfun
);
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
)
480 FETCH_STRING_CHAR_ADVANCE (c
, string
,
481 read_from_string_index
,
482 read_from_string_index_byte
);
487 /* Read one non-ASCII character from INSTREAM. The character is
488 encoded in `emacs-mule' and the first byte is already read in
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
;
502 /* C is not a valid leading-code of `emacs-mule'. */
503 return BYTE8_TO_CHAR (c
);
509 c
= (*readbyte
) (-1, readcharfun
);
513 (*readbyte
) (buf
[i
], readcharfun
);
514 return BYTE8_TO_CHAR (buf
[0]);
521 charset
= CHARSET_FROM_ID (emacs_mule_charset
[buf
[0]]);
522 code
= buf
[1] & 0x7F;
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;
534 charset
= CHARSET_FROM_ID (emacs_mule_charset
[buf
[0]]);
535 code
= ((buf
[1] << 8) | buf
[2]) & 0x7F7F;
540 charset
= CHARSET_FROM_ID (emacs_mule_charset
[buf
[1]]);
541 code
= ((buf
[2] << 8) | buf
[3]) & 0x7F7F;
543 c
= DECODE_CHAR (charset
, code
);
545 Fsignal (Qinvalid_read_syntax
,
546 list1 (build_string ("invalid multibyte form")));
551 static Lisp_Object
read_internal_start (Lisp_Object
, 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
,
561 static void substitute_in_interval (INTERVAL
, Lisp_Object
);
564 /* Get a character from the tty. */
566 /* Read input events until we get one that's acceptable for our purposes.
568 If NO_SWITCH_FRAME, switch-frame events are stashed
569 until we get a character we like, and then stuffed into
572 If ASCII_REQUIRED, check function key events to see
573 if the unmodified version of the symbol has a Qascii_character
574 property, and use that character, if present.
576 If ERROR_NONASCII, signal an error if the input we
577 get isn't an ASCII character with modifiers. If it's false but
578 ASCII_REQUIRED is true, just re-read until we get an ASCII
581 If INPUT_METHOD, invoke the current input method
582 if the character warrants that.
584 If SECONDS is a number, wait that many seconds for input, and
585 return Qnil if no input arrives within that time. */
588 read_filtered_event (bool no_switch_frame
, bool ascii_required
,
589 bool error_nonascii
, bool input_method
, Lisp_Object seconds
)
591 Lisp_Object val
, delayed_switch_frame
;
592 struct timespec end_time
;
594 #ifdef HAVE_WINDOW_SYSTEM
595 if (display_hourglass_p
)
599 delayed_switch_frame
= Qnil
;
601 /* Compute timeout. */
602 if (NUMBERP (seconds
))
604 double duration
= XFLOATINT (seconds
);
605 struct timespec wait_time
= dtotimespec (duration
);
606 end_time
= timespec_add (current_timespec (), wait_time
);
609 /* Read until we get an acceptable event. */
612 val
= read_char (0, Qnil
, (input_method
? Qnil
: Qt
), 0,
613 NUMBERP (seconds
) ? &end_time
: NULL
);
614 while (INTEGERP (val
) && XINT (val
) == -2); /* wrong_kboard_jmpbuf */
619 /* `switch-frame' events are put off until after the next ASCII
620 character. This is better than signaling an error just because
621 the last characters were typed to a separate minibuffer frame,
622 for example. Eventually, some code which can deal with
623 switch-frame events will read it and process it. */
625 && EVENT_HAS_PARAMETERS (val
)
626 && EQ (EVENT_HEAD_KIND (EVENT_HEAD (val
)), Qswitch_frame
))
628 delayed_switch_frame
= val
;
632 if (ascii_required
&& !(NUMBERP (seconds
) && NILP (val
)))
634 /* Convert certain symbols to their ASCII equivalents. */
637 Lisp_Object tem
, tem1
;
638 tem
= Fget (val
, Qevent_symbol_element_mask
);
641 tem1
= Fget (Fcar (tem
), Qascii_character
);
642 /* Merge this symbol's modifier bits
643 with the ASCII equivalent of its basic code. */
645 XSETFASTINT (val
, XINT (tem1
) | XINT (Fcar (Fcdr (tem
))));
649 /* If we don't have a character now, deal with it appropriately. */
654 Vunread_command_events
= list1 (val
);
655 error ("Non-character input-event");
662 if (! NILP (delayed_switch_frame
))
663 unread_switch_frame
= delayed_switch_frame
;
667 #ifdef HAVE_WINDOW_SYSTEM
668 if (display_hourglass_p
)
677 DEFUN ("read-char", Fread_char
, Sread_char
, 0, 3, 0,
678 doc
: /* Read a character from the command input (keyboard or macro).
679 It is returned as a number.
680 If the character has modifiers, they are resolved and reflected to the
681 character code if possible (e.g. C-SPC -> 0).
683 If the user generates an event which is not a character (i.e. a mouse
684 click or function key event), `read-char' signals an error. As an
685 exception, switch-frame events are put off until non-character events
687 If you want to read non-character events, or ignore them, call
688 `read-event' or `read-char-exclusive' instead.
690 If the optional argument PROMPT is non-nil, display that as a prompt.
691 If the optional argument INHERIT-INPUT-METHOD is non-nil and some
692 input method is turned on in the current buffer, that input method
693 is used for reading a character.
694 If the optional argument SECONDS is non-nil, it should be a number
695 specifying the maximum number of seconds to wait for input. If no
696 input arrives in that time, return nil. SECONDS may be a
697 floating-point value. */)
698 (Lisp_Object prompt
, Lisp_Object inherit_input_method
, Lisp_Object seconds
)
703 message_with_string ("%s", prompt
, 0);
704 val
= read_filtered_event (1, 1, 1, ! NILP (inherit_input_method
), seconds
);
706 return (NILP (val
) ? Qnil
707 : make_number (char_resolve_modifier_mask (XINT (val
))));
710 DEFUN ("read-event", Fread_event
, Sread_event
, 0, 3, 0,
711 doc
: /* Read an event object from the input stream.
712 If the optional argument PROMPT is non-nil, display that as a prompt.
713 If the optional argument INHERIT-INPUT-METHOD is non-nil and some
714 input method is turned on in the current buffer, that input method
715 is used for reading a character.
716 If the optional argument SECONDS is non-nil, it should be a number
717 specifying the maximum number of seconds to wait for input. If no
718 input arrives in that time, return nil. SECONDS may be a
719 floating-point value. */)
720 (Lisp_Object prompt
, Lisp_Object inherit_input_method
, Lisp_Object seconds
)
723 message_with_string ("%s", prompt
, 0);
724 return read_filtered_event (0, 0, 0, ! NILP (inherit_input_method
), seconds
);
727 DEFUN ("read-char-exclusive", Fread_char_exclusive
, Sread_char_exclusive
, 0, 3, 0,
728 doc
: /* Read a character from the command input (keyboard or macro).
729 It is returned as a number. Non-character events are ignored.
730 If the character has modifiers, they are resolved and reflected to the
731 character code if possible (e.g. C-SPC -> 0).
733 If the optional argument PROMPT is non-nil, display that as a prompt.
734 If the optional argument INHERIT-INPUT-METHOD is non-nil and some
735 input method is turned on in the current buffer, that input method
736 is used for reading a character.
737 If the optional argument SECONDS is non-nil, it should be a number
738 specifying the maximum number of seconds to wait for input. If no
739 input arrives in that time, return nil. SECONDS may be a
740 floating-point value. */)
741 (Lisp_Object prompt
, Lisp_Object inherit_input_method
, Lisp_Object seconds
)
746 message_with_string ("%s", prompt
, 0);
748 val
= read_filtered_event (1, 1, 0, ! NILP (inherit_input_method
), seconds
);
750 return (NILP (val
) ? Qnil
751 : make_number (char_resolve_modifier_mask (XINT (val
))));
754 DEFUN ("get-file-char", Fget_file_char
, Sget_file_char
, 0, 0, 0,
755 doc
: /* Don't use this yourself. */)
758 register Lisp_Object val
;
760 XSETINT (val
, getc (instream
));
768 /* Return true if the lisp code read using READCHARFUN defines a non-nil
769 `lexical-binding' file variable. After returning, the stream is
770 positioned following the first line, if it is a comment or #! line,
771 otherwise nothing is read. */
774 lisp_file_lexically_bound_p (Lisp_Object readcharfun
)
787 while (ch
!= '\n' && ch
!= EOF
)
789 if (ch
== '\n') ch
= READCHAR
;
790 /* It is OK to leave the position after a #! line, since
791 that is what read1 does. */
795 /* The first line isn't a comment, just give up. */
801 /* Look for an appropriate file-variable in the first line. */
805 NOMINAL
, AFTER_FIRST_DASH
, AFTER_ASTERIX
806 } beg_end_state
= NOMINAL
;
807 bool in_file_vars
= 0;
809 #define UPDATE_BEG_END_STATE(ch) \
810 if (beg_end_state == NOMINAL) \
811 beg_end_state = (ch == '-' ? AFTER_FIRST_DASH : NOMINAL); \
812 else if (beg_end_state == AFTER_FIRST_DASH) \
813 beg_end_state = (ch == '*' ? AFTER_ASTERIX : NOMINAL); \
814 else if (beg_end_state == AFTER_ASTERIX) \
817 in_file_vars = !in_file_vars; \
818 beg_end_state = NOMINAL; \
821 /* Skip until we get to the file vars, if any. */
825 UPDATE_BEG_END_STATE (ch
);
827 while (!in_file_vars
&& ch
!= '\n' && ch
!= EOF
);
831 char var
[100], val
[100];
836 /* Read a variable name. */
837 while (ch
== ' ' || ch
== '\t')
841 while (ch
!= ':' && ch
!= '\n' && ch
!= EOF
&& in_file_vars
)
843 if (i
< sizeof var
- 1)
845 UPDATE_BEG_END_STATE (ch
);
849 /* Stop scanning if no colon was found before end marker. */
850 if (!in_file_vars
|| ch
== '\n' || ch
== EOF
)
853 while (i
> 0 && (var
[i
- 1] == ' ' || var
[i
- 1] == '\t'))
859 /* Read a variable value. */
862 while (ch
== ' ' || ch
== '\t')
866 while (ch
!= ';' && ch
!= '\n' && ch
!= EOF
&& in_file_vars
)
868 if (i
< sizeof val
- 1)
870 UPDATE_BEG_END_STATE (ch
);
874 /* The value was terminated by an end-marker, which remove. */
876 while (i
> 0 && (val
[i
- 1] == ' ' || val
[i
- 1] == '\t'))
880 if (strcmp (var
, "lexical-binding") == 0)
883 rv
= (strcmp (val
, "nil") != 0);
889 while (ch
!= '\n' && ch
!= EOF
)
896 /* Value is a version number of byte compiled code if the file
897 associated with file descriptor FD is a compiled Lisp file that's
898 safe to load. Only files compiled with Emacs are safe to load.
899 Files compiled with XEmacs can lead to a crash in Fbyte_code
900 because of an incompatible change in the byte compiler. */
903 safe_to_load_version (int fd
)
909 /* Read the first few bytes from the file, and look for a line
910 specifying the byte compiler version used. */
911 nbytes
= emacs_read_quit (fd
, buf
, sizeof buf
);
914 /* Skip to the next newline, skipping over the initial `ELC'
915 with NUL bytes following it, but note the version. */
916 for (i
= 0; i
< nbytes
&& buf
[i
] != '\n'; ++i
)
921 || fast_c_string_match_ignore_case (Vbytecomp_version_regexp
,
922 buf
+ i
, nbytes
- i
) < 0)
926 lseek (fd
, 0, SEEK_SET
);
931 /* Callback for record_unwind_protect. Restore the old load list OLD,
932 after loading a file successfully. */
935 record_load_unwind (Lisp_Object old
)
937 Vloads_in_progress
= old
;
940 /* This handler function is used via internal_condition_case_1. */
943 load_error_handler (Lisp_Object data
)
949 load_warn_old_style_backquotes (Lisp_Object file
)
951 if (!NILP (Vold_style_backquotes
))
953 AUTO_STRING (format
, "Loading `%s': old-style backquotes detected!");
954 CALLN (Fmessage
, format
, file
);
958 DEFUN ("get-load-suffixes", Fget_load_suffixes
, Sget_load_suffixes
, 0, 0, 0,
959 doc
: /* Return the suffixes that `load' should try if a suffix is \
961 This uses the variables `load-suffixes' and `load-file-rep-suffixes'. */)
964 Lisp_Object lst
= Qnil
, suffixes
= Vload_suffixes
, suffix
, ext
;
965 while (CONSP (suffixes
))
967 Lisp_Object exts
= Vload_file_rep_suffixes
;
968 suffix
= XCAR (suffixes
);
969 suffixes
= XCDR (suffixes
);
974 lst
= Fcons (concat2 (suffix
, ext
), lst
);
977 return Fnreverse (lst
);
980 /* Returns true if STRING ends with SUFFIX */
982 suffix_p (Lisp_Object string
, const char *suffix
)
984 ptrdiff_t suffix_len
= strlen (suffix
);
985 ptrdiff_t string_len
= SBYTES (string
);
987 return string_len
>= suffix_len
&& !strcmp (SSDATA (string
) + string_len
- suffix_len
, suffix
);
990 DEFUN ("load", Fload
, Sload
, 1, 5, 0,
991 doc
: /* Execute a file of Lisp code named FILE.
992 First try FILE with `.elc' appended, then try with `.el', then try
993 with a system-dependent suffix of dynamic modules (see `load-suffixes'),
994 then try FILE unmodified (the exact suffixes in the exact order are
995 determined by `load-suffixes'). Environment variable references in
996 FILE are replaced with their values by calling `substitute-in-file-name'.
997 This function searches the directories in `load-path'.
999 If optional second arg NOERROR is non-nil,
1000 report no error if FILE doesn't exist.
1001 Print messages at start and end of loading unless
1002 optional third arg NOMESSAGE is non-nil (but `force-load-messages'
1004 If optional fourth arg NOSUFFIX is non-nil, don't try adding
1005 suffixes to the specified name FILE.
1006 If optional fifth arg MUST-SUFFIX is non-nil, insist on
1007 the suffix `.elc' or `.el' or the module suffix; don't accept just
1008 FILE unless it ends in one of those suffixes or includes a directory name.
1010 If NOSUFFIX is nil, then if a file could not be found, try looking for
1011 a different representation of the file by adding non-empty suffixes to
1012 its name, before trying another file. Emacs uses this feature to find
1013 compressed versions of files when Auto Compression mode is enabled.
1014 If NOSUFFIX is non-nil, disable this feature.
1016 The suffixes that this function tries out, when NOSUFFIX is nil, are
1017 given by the return value of `get-load-suffixes' and the values listed
1018 in `load-file-rep-suffixes'. If MUST-SUFFIX is non-nil, only the
1019 return value of `get-load-suffixes' is used, i.e. the file name is
1020 required to have a non-empty suffix.
1022 When searching suffixes, this function normally stops at the first
1023 one that exists. If the option `load-prefer-newer' is non-nil,
1024 however, it tries all suffixes, and uses whichever file is the newest.
1026 Loading a file records its definitions, and its `provide' and
1027 `require' calls, in an element of `load-history' whose
1028 car is the file name loaded. See `load-history'.
1030 While the file is in the process of being loaded, the variable
1031 `load-in-progress' is non-nil and the variable `load-file-name'
1032 is bound to the file's name.
1034 Return t if the file exists and loads successfully. */)
1035 (Lisp_Object file
, Lisp_Object noerror
, Lisp_Object nomessage
,
1036 Lisp_Object nosuffix
, Lisp_Object must_suffix
)
1040 int fd_index UNINIT
;
1041 ptrdiff_t count
= SPECPDL_INDEX ();
1042 Lisp_Object found
, efound
, hist_file_name
;
1043 /* True means we printed the ".el is newer" message. */
1045 /* True means we are loading a compiled file. */
1047 Lisp_Object handler
;
1049 const char *fmode
= "r" FOPEN_TEXT
;
1052 CHECK_STRING (file
);
1054 /* If file name is magic, call the handler. */
1055 /* This shouldn't be necessary any more now that `openp' handles it right.
1056 handler = Ffind_file_name_handler (file, Qload);
1057 if (!NILP (handler))
1058 return call5 (handler, Qload, file, noerror, nomessage, nosuffix); */
1060 /* The presence of this call is the result of a historical accident:
1061 it used to be in every file-operation and when it got removed
1062 everywhere, it accidentally stayed here. Since then, enough people
1063 supposedly have things like (load "$PROJECT/foo.el") in their .emacs
1064 that it seemed risky to remove. */
1065 if (! NILP (noerror
))
1067 file
= internal_condition_case_1 (Fsubstitute_in_file_name
, file
,
1068 Qt
, load_error_handler
);
1073 file
= Fsubstitute_in_file_name (file
);
1075 /* Avoid weird lossage with null string as arg,
1076 since it would try to load a directory as a Lisp file. */
1077 if (SCHARS (file
) == 0)
1084 Lisp_Object suffixes
;
1087 if (! NILP (must_suffix
))
1089 /* Don't insist on adding a suffix if FILE already ends with one. */
1090 if (suffix_p (file
, ".el")
1091 || suffix_p (file
, ".elc")
1093 || suffix_p (file
, MODULES_SUFFIX
)
1097 /* Don't insist on adding a suffix
1098 if the argument includes a directory name. */
1099 else if (! NILP (Ffile_name_directory (file
)))
1103 if (!NILP (nosuffix
))
1107 suffixes
= Fget_load_suffixes ();
1108 if (NILP (must_suffix
))
1109 suffixes
= CALLN (Fappend
, suffixes
, Vload_file_rep_suffixes
);
1112 fd
= openp (Vload_path
, file
, suffixes
, &found
, Qnil
, load_prefer_newer
);
1118 report_file_error ("Cannot open load file", file
);
1122 /* Tell startup.el whether or not we found the user's init file. */
1123 if (EQ (Qt
, Vuser_init_file
))
1124 Vuser_init_file
= found
;
1126 /* If FD is -2, that means openp found a magic file. */
1129 if (NILP (Fequal (found
, file
)))
1130 /* If FOUND is a different file name from FILE,
1131 find its handler even if we have already inhibited
1132 the `load' operation on FILE. */
1133 handler
= Ffind_file_name_handler (found
, Qt
);
1135 handler
= Ffind_file_name_handler (found
, Qload
);
1136 if (! NILP (handler
))
1137 return call5 (handler
, Qload
, found
, noerror
, nomessage
, Qt
);
1139 /* Tramp has to deal with semi-broken packages that prepend
1140 drive letters to remote files. For that reason, Tramp
1141 catches file operations that test for file existence, which
1142 makes openp think X:/foo.elc files are remote. However,
1143 Tramp does not catch `load' operations for such files, so we
1144 end up with a nil as the `load' handler above. If we would
1145 continue with fd = -2, we will behave wrongly, and in
1146 particular try reading a .elc file in the "rt" mode instead
1147 of "rb". See bug #9311 for the results. To work around
1148 this, we try to open the file locally, and go with that if it
1150 fd
= emacs_open (SSDATA (ENCODE_FILE (found
)), O_RDONLY
, 0);
1158 fd_index
= SPECPDL_INDEX ();
1159 record_unwind_protect_int (close_file_unwind
, fd
);
1163 if (suffix_p (found
, MODULES_SUFFIX
))
1164 return unbind_to (count
, Fmodule_load (found
));
1167 /* Check if we're stuck in a recursive load cycle.
1169 2000-09-21: It's not possible to just check for the file loaded
1170 being a member of Vloads_in_progress. This fails because of the
1171 way the byte compiler currently works; `provide's are not
1172 evaluated, see font-lock.el/jit-lock.el as an example. This
1173 leads to a certain amount of ``normal'' recursion.
1175 Also, just loading a file recursively is not always an error in
1176 the general case; the second load may do something different. */
1180 for (tem
= Vloads_in_progress
; CONSP (tem
); tem
= XCDR (tem
))
1181 if (!NILP (Fequal (found
, XCAR (tem
))) && (++load_count
> 3))
1182 signal_error ("Recursive load", Fcons (found
, Vloads_in_progress
));
1183 record_unwind_protect (record_load_unwind
, Vloads_in_progress
);
1184 Vloads_in_progress
= Fcons (found
, Vloads_in_progress
);
1187 /* All loads are by default dynamic, unless the file itself specifies
1188 otherwise using a file-variable in the first line. This is bound here
1189 so that it takes effect whether or not we use
1190 Vload_source_file_function. */
1191 specbind (Qlexical_binding
, Qnil
);
1193 /* Get the name for load-history. */
1194 hist_file_name
= (! NILP (Vpurify_flag
)
1195 ? concat2 (Ffile_name_directory (file
),
1196 Ffile_name_nondirectory (found
))
1201 /* Check for the presence of old-style quotes and warn about them. */
1202 specbind (Qold_style_backquotes
, Qnil
);
1203 record_unwind_protect (load_warn_old_style_backquotes
, file
);
1206 if ((is_elc
= suffix_p (found
, ".elc")) != 0
1207 /* version = 1 means the file is empty, in which case we can
1208 treat it as not byte-compiled. */
1209 || (fd
>= 0 && (version
= safe_to_load_version (fd
)) > 1))
1210 /* Load .elc files directly, but not when they are
1211 remote and have no handler! */
1219 && ! (version
= safe_to_load_version (fd
)))
1222 if (!load_dangerous_libraries
)
1223 error ("File `%s' was not compiled in Emacs", SDATA (found
));
1224 else if (!NILP (nomessage
) && !force_load_messages
)
1225 message_with_string ("File `%s' not compiled in Emacs", found
, 1);
1230 efound
= ENCODE_FILE (found
);
1231 fmode
= "r" FOPEN_BINARY
;
1233 /* openp already checked for newness, no point doing it again.
1234 FIXME would be nice to get a message when openp
1235 ignores suffix order due to load_prefer_newer. */
1236 if (!load_prefer_newer
&& is_elc
)
1238 result
= stat (SSDATA (efound
), &s1
);
1241 SSET (efound
, SBYTES (efound
) - 1, 0);
1242 result
= stat (SSDATA (efound
), &s2
);
1243 SSET (efound
, SBYTES (efound
) - 1, 'c');
1247 && timespec_cmp (get_stat_mtime (&s1
), get_stat_mtime (&s2
)) < 0)
1249 /* Make the progress messages mention that source is newer. */
1252 /* If we won't print another message, mention this anyway. */
1253 if (!NILP (nomessage
) && !force_load_messages
)
1255 Lisp_Object msg_file
;
1256 msg_file
= Fsubstring (found
, make_number (0), make_number (-1));
1257 message_with_string ("Source file `%s' newer than byte-compiled file",
1261 } /* !load_prefer_newer */
1266 /* We are loading a source file (*.el). */
1267 if (!NILP (Vload_source_file_function
))
1274 clear_unwind_protect (fd_index
);
1276 val
= call4 (Vload_source_file_function
, found
, hist_file_name
,
1277 NILP (noerror
) ? Qnil
: Qt
,
1278 (NILP (nomessage
) || force_load_messages
) ? Qnil
: Qt
);
1279 return unbind_to (count
, val
);
1285 /* We somehow got here with fd == -2, meaning the file is deemed
1286 to be remote. Don't even try to reopen the file locally;
1287 just force a failure. */
1295 clear_unwind_protect (fd_index
);
1296 efound
= ENCODE_FILE (found
);
1297 stream
= emacs_fopen (SSDATA (efound
), fmode
);
1299 stream
= fdopen (fd
, fmode
);
1303 report_file_error ("Opening stdio stream", file
);
1304 set_unwind_protect_ptr (fd_index
, fclose_unwind
, stream
);
1306 if (! NILP (Vpurify_flag
))
1307 Vpreloaded_file_list
= Fcons (Fpurecopy (file
), Vpreloaded_file_list
);
1309 if (NILP (nomessage
) || force_load_messages
)
1312 message_with_string ("Loading %s (compiled; note unsafe, not compiled in Emacs)...",
1315 message_with_string ("Loading %s (source)...", file
, 1);
1317 message_with_string ("Loading %s (compiled; note, source file is newer)...",
1319 else /* The typical case; compiled file newer than source file. */
1320 message_with_string ("Loading %s...", file
, 1);
1323 specbind (Qload_file_name
, found
);
1324 specbind (Qinhibit_file_name_operation
, Qnil
);
1325 specbind (Qload_in_progress
, Qt
);
1328 if (lisp_file_lexically_bound_p (Qget_file_char
))
1329 Fset (Qlexical_binding
, Qt
);
1331 if (! version
|| version
>= 22)
1332 readevalloop (Qget_file_char
, stream
, hist_file_name
,
1333 0, Qnil
, Qnil
, Qnil
, Qnil
);
1336 /* We can't handle a file which was compiled with
1337 byte-compile-dynamic by older version of Emacs. */
1338 specbind (Qload_force_doc_strings
, Qt
);
1339 readevalloop (Qget_emacs_mule_file_char
, stream
, hist_file_name
,
1340 0, Qnil
, Qnil
, Qnil
, Qnil
);
1342 unbind_to (count
, Qnil
);
1344 /* Run any eval-after-load forms for this file. */
1345 if (!NILP (Ffboundp (Qdo_after_load_evaluation
)))
1346 call1 (Qdo_after_load_evaluation
, hist_file_name
) ;
1348 xfree (saved_doc_string
);
1349 saved_doc_string
= 0;
1350 saved_doc_string_size
= 0;
1352 xfree (prev_saved_doc_string
);
1353 prev_saved_doc_string
= 0;
1354 prev_saved_doc_string_size
= 0;
1356 if (!noninteractive
&& (NILP (nomessage
) || force_load_messages
))
1359 message_with_string ("Loading %s (compiled; note unsafe, not compiled in Emacs)...done",
1362 message_with_string ("Loading %s (source)...done", file
, 1);
1364 message_with_string ("Loading %s (compiled; note, source file is newer)...done",
1366 else /* The typical case; compiled file newer than source file. */
1367 message_with_string ("Loading %s...done", file
, 1);
1374 complete_filename_p (Lisp_Object pathname
)
1376 const unsigned char *s
= SDATA (pathname
);
1377 return (IS_DIRECTORY_SEP (s
[0])
1378 || (SCHARS (pathname
) > 2
1379 && IS_DEVICE_SEP (s
[1]) && IS_DIRECTORY_SEP (s
[2])));
1382 DEFUN ("locate-file-internal", Flocate_file_internal
, Slocate_file_internal
, 2, 4, 0,
1383 doc
: /* Search for FILENAME through PATH.
1384 Returns the file's name in absolute form, or nil if not found.
1385 If SUFFIXES is non-nil, it should be a list of suffixes to append to
1386 file name when searching.
1387 If non-nil, PREDICATE is used instead of `file-readable-p'.
1388 PREDICATE can also be an integer to pass to the faccessat(2) function,
1389 in which case file-name-handlers are ignored.
1390 This function will normally skip directories, so if you want it to find
1391 directories, make sure the PREDICATE function returns `dir-ok' for them. */)
1392 (Lisp_Object filename
, Lisp_Object path
, Lisp_Object suffixes
, Lisp_Object predicate
)
1395 int fd
= openp (path
, filename
, suffixes
, &file
, predicate
, false);
1396 if (NILP (predicate
) && fd
>= 0)
1401 /* Search for a file whose name is STR, looking in directories
1402 in the Lisp list PATH, and trying suffixes from SUFFIX.
1403 On success, return a file descriptor (or 1 or -2 as described below).
1404 On failure, return -1 and set errno.
1406 SUFFIXES is a list of strings containing possible suffixes.
1407 The empty suffix is automatically added if the list is empty.
1409 PREDICATE t means the files are binary.
1410 PREDICATE non-nil and non-t means don't open the files,
1411 just look for one that satisfies the predicate. In this case,
1412 return -2 on success. The predicate can be a lisp function or
1413 an integer to pass to `access' (in which case file-name-handlers
1416 If STOREPTR is nonzero, it points to a slot where the name of
1417 the file actually found should be stored as a Lisp string.
1418 nil is stored there on failure.
1420 If the file we find is remote, return -2
1421 but store the found remote file name in *STOREPTR.
1423 If NEWER is true, try all SUFFIXes and return the result for the
1424 newest file that exists. Does not apply to remote files,
1425 or if a non-nil and non-t PREDICATE is specified. */
1428 openp (Lisp_Object path
, Lisp_Object str
, Lisp_Object suffixes
,
1429 Lisp_Object
*storeptr
, Lisp_Object predicate
, bool newer
)
1431 ptrdiff_t fn_size
= 100;
1435 ptrdiff_t want_length
;
1436 Lisp_Object filename
;
1437 Lisp_Object string
, tail
, encoded_fn
, save_string
;
1438 ptrdiff_t max_suffix_len
= 0;
1439 int last_errno
= ENOENT
;
1443 /* The last-modified time of the newest matching file found.
1444 Initialize it to something less than all valid timestamps. */
1445 struct timespec save_mtime
= make_timespec (TYPE_MINIMUM (time_t), -1);
1449 for (tail
= suffixes
; CONSP (tail
); tail
= XCDR (tail
))
1451 CHECK_STRING_CAR (tail
);
1452 max_suffix_len
= max (max_suffix_len
,
1453 SBYTES (XCAR (tail
)));
1456 string
= filename
= encoded_fn
= save_string
= Qnil
;
1461 absolute
= complete_filename_p (str
);
1463 for (; CONSP (path
); path
= XCDR (path
))
1465 ptrdiff_t baselen
, prefixlen
;
1467 filename
= Fexpand_file_name (str
, XCAR (path
));
1468 if (!complete_filename_p (filename
))
1469 /* If there are non-absolute elts in PATH (eg "."). */
1470 /* Of course, this could conceivably lose if luser sets
1471 default-directory to be something non-absolute... */
1473 filename
= Fexpand_file_name (filename
, BVAR (current_buffer
, directory
));
1474 if (!complete_filename_p (filename
))
1475 /* Give up on this path element! */
1479 /* Calculate maximum length of any filename made from
1480 this path element/specified file name and any possible suffix. */
1481 want_length
= max_suffix_len
+ SBYTES (filename
);
1482 if (fn_size
<= want_length
)
1484 fn_size
= 100 + want_length
;
1485 fn
= SAFE_ALLOCA (fn_size
);
1488 /* Copy FILENAME's data to FN but remove starting /: if any. */
1489 prefixlen
= ((SCHARS (filename
) > 2
1490 && SREF (filename
, 0) == '/'
1491 && SREF (filename
, 1) == ':')
1493 baselen
= SBYTES (filename
) - prefixlen
;
1494 memcpy (fn
, SDATA (filename
) + prefixlen
, baselen
);
1496 /* Loop over suffixes. */
1497 for (tail
= NILP (suffixes
) ? list1 (empty_unibyte_string
) : suffixes
;
1498 CONSP (tail
); tail
= XCDR (tail
))
1500 Lisp_Object suffix
= XCAR (tail
);
1501 ptrdiff_t fnlen
, lsuffix
= SBYTES (suffix
);
1502 Lisp_Object handler
;
1504 /* Make complete filename by appending SUFFIX. */
1505 memcpy (fn
+ baselen
, SDATA (suffix
), lsuffix
+ 1);
1506 fnlen
= baselen
+ lsuffix
;
1508 /* Check that the file exists and is not a directory. */
1509 /* We used to only check for handlers on non-absolute file names:
1513 handler = Ffind_file_name_handler (filename, Qfile_exists_p);
1514 It's not clear why that was the case and it breaks things like
1515 (load "/bar.el") where the file is actually "/bar.el.gz". */
1516 /* make_string has its own ideas on when to return a unibyte
1517 string and when a multibyte string, but we know better.
1518 We must have a unibyte string when dumping, since
1519 file-name encoding is shaky at best at that time, and in
1520 particular default-file-name-coding-system is reset
1521 several times during loadup. We therefore don't want to
1522 encode the file before passing it to file I/O library
1524 if (!STRING_MULTIBYTE (filename
) && !STRING_MULTIBYTE (suffix
))
1525 string
= make_unibyte_string (fn
, fnlen
);
1527 string
= make_string (fn
, fnlen
);
1528 handler
= Ffind_file_name_handler (string
, Qfile_exists_p
);
1529 if ((!NILP (handler
) || (!NILP (predicate
) && !EQ (predicate
, Qt
)))
1530 && !NATNUMP (predicate
))
1533 if (NILP (predicate
) || EQ (predicate
, Qt
))
1534 exists
= !NILP (Ffile_readable_p (string
));
1537 Lisp_Object tmp
= call1 (predicate
, string
);
1540 else if (EQ (tmp
, Qdir_ok
)
1541 || NILP (Ffile_directory_p (string
)))
1546 last_errno
= EISDIR
;
1552 /* We succeeded; return this descriptor and filename. */
1565 encoded_fn
= ENCODE_FILE (string
);
1566 pfn
= SSDATA (encoded_fn
);
1568 /* Check that we can access or open it. */
1569 if (NATNUMP (predicate
))
1572 if (INT_MAX
< XFASTINT (predicate
))
1573 last_errno
= EINVAL
;
1574 else if (faccessat (AT_FDCWD
, pfn
, XFASTINT (predicate
),
1578 if (file_directory_p (pfn
))
1579 last_errno
= EISDIR
;
1586 fd
= emacs_open (pfn
, O_RDONLY
, 0);
1589 if (errno
!= ENOENT
)
1594 int err
= (fstat (fd
, &st
) != 0 ? errno
1595 : S_ISDIR (st
.st_mode
) ? EISDIR
: 0);
1607 if (newer
&& !NATNUMP (predicate
))
1609 struct timespec mtime
= get_stat_mtime (&st
);
1611 if (timespec_cmp (mtime
, save_mtime
) <= 0)
1616 emacs_close (save_fd
);
1619 save_string
= string
;
1624 /* We succeeded; return this descriptor and filename. */
1632 /* No more suffixes. Return the newest. */
1633 if (0 <= save_fd
&& ! CONSP (XCDR (tail
)))
1636 *storeptr
= save_string
;
1652 /* Merge the list we've accumulated of globals from the current input source
1653 into the load_history variable. The details depend on whether
1654 the source has an associated file name or not.
1656 FILENAME is the file name that we are loading from.
1658 ENTIRE is true if loading that entire file, false if evaluating
1662 build_load_history (Lisp_Object filename
, bool entire
)
1664 Lisp_Object tail
, prev
, newelt
;
1665 Lisp_Object tem
, tem2
;
1668 tail
= Vload_history
;
1671 while (CONSP (tail
))
1675 /* Find the feature's previous assoc list... */
1676 if (!NILP (Fequal (filename
, Fcar (tem
))))
1680 /* If we're loading the entire file, remove old data. */
1684 Vload_history
= XCDR (tail
);
1686 Fsetcdr (prev
, XCDR (tail
));
1689 /* Otherwise, cons on new symbols that are not already members. */
1692 tem2
= Vcurrent_load_list
;
1694 while (CONSP (tem2
))
1696 newelt
= XCAR (tem2
);
1698 if (NILP (Fmember (newelt
, tem
)))
1699 Fsetcar (tail
, Fcons (XCAR (tem
),
1700 Fcons (newelt
, XCDR (tem
))));
1713 /* If we're loading an entire file, cons the new assoc onto the
1714 front of load-history, the most-recently-loaded position. Also
1715 do this if we didn't find an existing member for the file. */
1716 if (entire
|| !foundit
)
1717 Vload_history
= Fcons (Fnreverse (Vcurrent_load_list
),
1722 readevalloop_1 (int old
)
1724 load_convert_to_unibyte
= old
;
1727 /* Signal an `end-of-file' error, if possible with file name
1730 static _Noreturn
void
1731 end_of_file_error (void)
1733 if (STRINGP (Vload_file_name
))
1734 xsignal1 (Qend_of_file
, Vload_file_name
);
1736 xsignal0 (Qend_of_file
);
1740 readevalloop_eager_expand_eval (Lisp_Object val
, Lisp_Object macroexpand
)
1742 /* If we macroexpand the toplevel form non-recursively and it ends
1743 up being a `progn' (or if it was a progn to start), treat each
1744 form in the progn as a top-level form. This way, if one form in
1745 the progn defines a macro, that macro is in effect when we expand
1746 the remaining forms. See similar code in bytecomp.el. */
1747 val
= call2 (macroexpand
, val
, Qnil
);
1748 if (EQ (CAR_SAFE (val
), Qprogn
))
1750 Lisp_Object subforms
= XCDR (val
);
1752 for (val
= Qnil
; CONSP (subforms
); subforms
= XCDR (subforms
))
1753 val
= readevalloop_eager_expand_eval (XCAR (subforms
),
1757 val
= eval_sub (call2 (macroexpand
, val
, Qt
));
1761 /* UNIBYTE specifies how to set load_convert_to_unibyte
1762 for this invocation.
1763 READFUN, if non-nil, is used instead of `read'.
1765 START, END specify region to read in current buffer (from eval-region).
1766 If the input is not from a buffer, they must be nil. */
1769 readevalloop (Lisp_Object readcharfun
,
1771 Lisp_Object sourcename
,
1773 Lisp_Object unibyte
, Lisp_Object readfun
,
1774 Lisp_Object start
, Lisp_Object end
)
1778 ptrdiff_t count
= SPECPDL_INDEX ();
1779 struct buffer
*b
= 0;
1780 bool continue_reading_p
;
1781 Lisp_Object lex_bound
;
1782 /* True if reading an entire buffer. */
1783 bool whole_buffer
= 0;
1784 /* True on the first time around. */
1785 bool first_sexp
= 1;
1786 Lisp_Object macroexpand
= intern ("internal-macroexpand-for-load");
1788 if (NILP (Ffboundp (macroexpand
))
1789 /* Don't macroexpand in .elc files, since it should have been done
1790 already. We actually don't know whether we're in a .elc file or not,
1791 so we use circumstantial evidence: .el files normally go through
1792 Vload_source_file_function -> load-with-code-conversion
1794 || EQ (readcharfun
, Qget_file_char
)
1795 || EQ (readcharfun
, Qget_emacs_mule_file_char
))
1798 if (MARKERP (readcharfun
))
1801 start
= readcharfun
;
1804 if (BUFFERP (readcharfun
))
1805 b
= XBUFFER (readcharfun
);
1806 else if (MARKERP (readcharfun
))
1807 b
= XMARKER (readcharfun
)->buffer
;
1809 /* We assume START is nil when input is not from a buffer. */
1810 if (! NILP (start
) && !b
)
1813 specbind (Qstandard_input
, readcharfun
);
1814 specbind (Qcurrent_load_list
, Qnil
);
1815 record_unwind_protect_int (readevalloop_1
, load_convert_to_unibyte
);
1816 load_convert_to_unibyte
= !NILP (unibyte
);
1818 /* If lexical binding is active (either because it was specified in
1819 the file's header, or via a buffer-local variable), create an empty
1820 lexical environment, otherwise, turn off lexical binding. */
1821 lex_bound
= find_symbol_value (Qlexical_binding
);
1822 specbind (Qinternal_interpreter_environment
,
1823 (NILP (lex_bound
) || EQ (lex_bound
, Qunbound
)
1824 ? Qnil
: list1 (Qt
)));
1826 /* Try to ensure sourcename is a truename, except whilst preloading. */
1827 if (NILP (Vpurify_flag
)
1828 && !NILP (sourcename
) && !NILP (Ffile_name_absolute_p (sourcename
))
1829 && !NILP (Ffboundp (Qfile_truename
)))
1830 sourcename
= call1 (Qfile_truename
, sourcename
) ;
1832 LOADHIST_ATTACH (sourcename
);
1834 continue_reading_p
= 1;
1835 while (continue_reading_p
)
1837 ptrdiff_t count1
= SPECPDL_INDEX ();
1839 if (b
!= 0 && !BUFFER_LIVE_P (b
))
1840 error ("Reading from killed buffer");
1844 /* Switch to the buffer we are reading from. */
1845 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
1846 set_buffer_internal (b
);
1848 /* Save point in it. */
1849 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
1850 /* Save ZV in it. */
1851 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
1852 /* Those get unbound after we read one expression. */
1854 /* Set point and ZV around stuff to be read. */
1857 Fnarrow_to_region (make_number (BEGV
), end
);
1859 /* Just for cleanliness, convert END to a marker
1860 if it is an integer. */
1862 end
= Fpoint_max_marker ();
1865 /* On the first cycle, we can easily test here
1866 whether we are reading the whole buffer. */
1867 if (b
&& first_sexp
)
1868 whole_buffer
= (PT
== BEG
&& ZV
== Z
);
1875 while ((c
= READCHAR
) != '\n' && c
!= -1);
1880 unbind_to (count1
, Qnil
);
1884 /* Ignore whitespace here, so we can detect eof. */
1885 if (c
== ' ' || c
== '\t' || c
== '\n' || c
== '\f' || c
== '\r'
1886 || c
== NO_BREAK_SPACE
)
1889 if (!NILP (Vpurify_flag
) && c
== '(')
1891 val
= read_list (0, readcharfun
);
1896 read_objects
= Qnil
;
1897 if (!NILP (readfun
))
1899 val
= call1 (readfun
, readcharfun
);
1901 /* If READCHARFUN has set point to ZV, we should
1902 stop reading, even if the form read sets point
1903 to a different value when evaluated. */
1904 if (BUFFERP (readcharfun
))
1906 struct buffer
*buf
= XBUFFER (readcharfun
);
1907 if (BUF_PT (buf
) == BUF_ZV (buf
))
1908 continue_reading_p
= 0;
1911 else if (! NILP (Vload_read_function
))
1912 val
= call1 (Vload_read_function
, readcharfun
);
1914 val
= read_internal_start (readcharfun
, Qnil
, Qnil
);
1917 if (!NILP (start
) && continue_reading_p
)
1918 start
= Fpoint_marker ();
1920 /* Restore saved point and BEGV. */
1921 unbind_to (count1
, Qnil
);
1923 /* Now eval what we just read. */
1924 if (!NILP (macroexpand
))
1925 val
= readevalloop_eager_expand_eval (val
, macroexpand
);
1927 val
= eval_sub (val
);
1931 Vvalues
= Fcons (val
, Vvalues
);
1932 if (EQ (Vstandard_output
, Qt
))
1941 build_load_history (sourcename
,
1942 stream
|| whole_buffer
);
1944 unbind_to (count
, Qnil
);
1947 DEFUN ("eval-buffer", Feval_buffer
, Seval_buffer
, 0, 5, "",
1948 doc
: /* Execute the accessible portion of current buffer as Lisp code.
1949 You can use \\[narrow-to-region] to limit the part of buffer to be evaluated.
1950 When called from a Lisp program (i.e., not interactively), this
1951 function accepts up to five optional arguments:
1952 BUFFER is the buffer to evaluate (nil means use current buffer),
1953 or a name of a buffer (a string).
1954 PRINTFLAG controls printing of output by any output functions in the
1955 evaluated code, such as `print', `princ', and `prin1':
1956 a value of nil means discard it; anything else is the stream to print to.
1957 See Info node `(elisp)Output Streams' for details on streams.
1958 FILENAME specifies the file name to use for `load-history'.
1959 UNIBYTE, if non-nil, specifies `load-convert-to-unibyte' for this
1961 DO-ALLOW-PRINT, if non-nil, specifies that output functions in the
1962 evaluated code should work normally even if PRINTFLAG is nil, in
1963 which case the output is displayed in the echo area.
1965 This function preserves the position of point. */)
1966 (Lisp_Object buffer
, Lisp_Object printflag
, Lisp_Object filename
, Lisp_Object unibyte
, Lisp_Object do_allow_print
)
1968 ptrdiff_t count
= SPECPDL_INDEX ();
1969 Lisp_Object tem
, buf
;
1972 buf
= Fcurrent_buffer ();
1974 buf
= Fget_buffer (buffer
);
1976 error ("No such buffer");
1978 if (NILP (printflag
) && NILP (do_allow_print
))
1983 if (NILP (filename
))
1984 filename
= BVAR (XBUFFER (buf
), filename
);
1986 specbind (Qeval_buffer_list
, Fcons (buf
, Veval_buffer_list
));
1987 specbind (Qstandard_output
, tem
);
1988 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
1989 BUF_TEMP_SET_PT (XBUFFER (buf
), BUF_BEGV (XBUFFER (buf
)));
1990 specbind (Qlexical_binding
, lisp_file_lexically_bound_p (buf
) ? Qt
: Qnil
);
1991 readevalloop (buf
, 0, filename
,
1992 !NILP (printflag
), unibyte
, Qnil
, Qnil
, Qnil
);
1993 unbind_to (count
, Qnil
);
1998 DEFUN ("eval-region", Feval_region
, Seval_region
, 2, 4, "r",
1999 doc
: /* Execute the region as Lisp code.
2000 When called from programs, expects two arguments,
2001 giving starting and ending indices in the current buffer
2002 of the text to be executed.
2003 Programs can pass third argument PRINTFLAG which controls output:
2004 a value of nil means discard it; anything else is stream for printing it.
2005 See Info node `(elisp)Output Streams' for details on streams.
2006 Also the fourth argument READ-FUNCTION, if non-nil, is used
2007 instead of `read' to read each expression. It gets one argument
2008 which is the input stream for reading characters.
2010 This function does not move point. */)
2011 (Lisp_Object start
, Lisp_Object end
, Lisp_Object printflag
, Lisp_Object read_function
)
2013 /* FIXME: Do the eval-sexp-add-defvars dance! */
2014 ptrdiff_t count
= SPECPDL_INDEX ();
2015 Lisp_Object tem
, cbuf
;
2017 cbuf
= Fcurrent_buffer ();
2019 if (NILP (printflag
))
2023 specbind (Qstandard_output
, tem
);
2024 specbind (Qeval_buffer_list
, Fcons (cbuf
, Veval_buffer_list
));
2026 /* `readevalloop' calls functions which check the type of start and end. */
2027 readevalloop (cbuf
, 0, BVAR (XBUFFER (cbuf
), filename
),
2028 !NILP (printflag
), Qnil
, read_function
,
2031 return unbind_to (count
, Qnil
);
2035 DEFUN ("read", Fread
, Sread
, 0, 1, 0,
2036 doc
: /* Read one Lisp expression as text from STREAM, return as Lisp object.
2037 If STREAM is nil, use the value of `standard-input' (which see).
2038 STREAM or the value of `standard-input' may be:
2039 a buffer (read from point and advance it)
2040 a marker (read from where it points and advance it)
2041 a function (call it with no arguments for each character,
2042 call it with a char as argument to push a char back)
2043 a string (takes text from string, starting at the beginning)
2044 t (read text line using minibuffer and use it, or read from
2045 standard input in batch mode). */)
2046 (Lisp_Object stream
)
2049 stream
= Vstandard_input
;
2050 if (EQ (stream
, Qt
))
2051 stream
= Qread_char
;
2052 if (EQ (stream
, Qread_char
))
2053 /* FIXME: ?! When is this used !? */
2054 return call1 (intern ("read-minibuffer"),
2055 build_string ("Lisp expression: "));
2057 return read_internal_start (stream
, Qnil
, Qnil
);
2060 DEFUN ("read-from-string", Fread_from_string
, Sread_from_string
, 1, 3, 0,
2061 doc
: /* Read one Lisp expression which is represented as text by STRING.
2062 Returns a cons: (OBJECT-READ . FINAL-STRING-INDEX).
2063 FINAL-STRING-INDEX is an integer giving the position of the next
2064 remaining character in STRING. START and END optionally delimit
2065 a substring of STRING from which to read; they default to 0 and
2066 \(length STRING) respectively. Negative values are counted from
2067 the end of STRING. */)
2068 (Lisp_Object string
, Lisp_Object start
, Lisp_Object end
)
2071 CHECK_STRING (string
);
2072 /* `read_internal_start' sets `read_from_string_index'. */
2073 ret
= read_internal_start (string
, start
, end
);
2074 return Fcons (ret
, make_number (read_from_string_index
));
2077 /* Function to set up the global context we need in toplevel read
2078 calls. START and END only used when STREAM is a string. */
2080 read_internal_start (Lisp_Object stream
, Lisp_Object start
, Lisp_Object end
)
2085 new_backquote_flag
= 0;
2086 read_objects
= Qnil
;
2087 if (EQ (Vread_with_symbol_positions
, Qt
)
2088 || EQ (Vread_with_symbol_positions
, stream
))
2089 Vread_symbol_positions_list
= Qnil
;
2091 if (STRINGP (stream
)
2092 || ((CONSP (stream
) && STRINGP (XCAR (stream
)))))
2094 ptrdiff_t startval
, endval
;
2097 if (STRINGP (stream
))
2100 string
= XCAR (stream
);
2102 validate_subarray (string
, start
, end
, SCHARS (string
),
2103 &startval
, &endval
);
2105 read_from_string_index
= startval
;
2106 read_from_string_index_byte
= string_char_to_byte (string
, startval
);
2107 read_from_string_limit
= endval
;
2110 retval
= read0 (stream
);
2111 if (EQ (Vread_with_symbol_positions
, Qt
)
2112 || EQ (Vread_with_symbol_positions
, stream
))
2113 Vread_symbol_positions_list
= Fnreverse (Vread_symbol_positions_list
);
2118 /* Signal Qinvalid_read_syntax error.
2119 S is error string of length N (if > 0) */
2121 static _Noreturn
void
2122 invalid_syntax (const char *s
)
2124 xsignal1 (Qinvalid_read_syntax
, build_string (s
));
2128 /* Use this for recursive reads, in contexts where internal tokens
2132 read0 (Lisp_Object readcharfun
)
2134 register Lisp_Object val
;
2137 val
= read1 (readcharfun
, &c
, 0);
2141 xsignal1 (Qinvalid_read_syntax
,
2142 Fmake_string (make_number (1), make_number (c
)));
2145 /* Grow a read buffer BUF that contains OFFSET useful bytes of data,
2146 by at least MAX_MULTIBYTE_LENGTH bytes. Update *BUF_ADDR and
2147 *BUF_SIZE accordingly; 0 <= OFFSET <= *BUF_SIZE. If *BUF_ADDR is
2148 initially null, BUF is on the stack: copy its data to the new heap
2149 buffer. Otherwise, BUF must equal *BUF_ADDR and can simply be
2150 reallocated. Either way, remember the heap allocation (which is at
2151 pdl slot COUNT) so that it can be freed when unwinding the stack.*/
2154 grow_read_buffer (char *buf
, ptrdiff_t offset
,
2155 char **buf_addr
, ptrdiff_t *buf_size
, ptrdiff_t count
)
2157 char *p
= xpalloc (*buf_addr
, buf_size
, MAX_MULTIBYTE_LENGTH
, -1, 1);
2160 memcpy (p
, buf
, offset
);
2161 record_unwind_protect_ptr (xfree
, p
);
2164 set_unwind_protect_ptr (count
, xfree
, p
);
2169 /* Return the scalar value that has the Unicode character name NAME.
2170 Raise 'invalid-read-syntax' if there is no such character. */
2172 character_name_to_code (char const *name
, ptrdiff_t name_len
)
2174 /* For "U+XXXX", pass the leading '+' to string_to_number to reject
2175 monstrosities like "U+-0000". */
2177 = (name
[0] == 'U' && name
[1] == '+'
2178 ? string_to_number (name
+ 1, 16, false)
2179 : call2 (Qchar_from_name
, make_unibyte_string (name
, name_len
), Qt
));
2181 if (! RANGED_INTEGERP (0, code
, MAX_UNICODE_CHAR
)
2182 || char_surrogate_p (XINT (code
)))
2184 AUTO_STRING (format
, "\\N{%s}");
2185 AUTO_STRING_WITH_LEN (namestr
, name
, name_len
);
2186 xsignal1 (Qinvalid_read_syntax
, CALLN (Fformat
, format
, namestr
));
2192 /* Bound on the length of a Unicode character name. As of
2193 Unicode 9.0.0 the maximum is 83, so this should be safe. */
2194 enum { UNICODE_CHARACTER_NAME_LENGTH_BOUND
= 200 };
2196 /* Read a \-escape sequence, assuming we already read the `\'.
2197 If the escape sequence forces unibyte, return eight-bit char. */
2200 read_escape (Lisp_Object readcharfun
, bool stringp
)
2203 /* \u allows up to four hex digits, \U up to eight. Default to the
2204 behavior for \u, and change this value in the case that \U is seen. */
2205 int unicode_hex_count
= 4;
2210 end_of_file_error ();
2240 error ("Invalid escape character syntax");
2243 c
= read_escape (readcharfun
, 0);
2244 return c
| meta_modifier
;
2249 error ("Invalid escape character syntax");
2252 c
= read_escape (readcharfun
, 0);
2253 return c
| shift_modifier
;
2258 error ("Invalid escape character syntax");
2261 c
= read_escape (readcharfun
, 0);
2262 return c
| hyper_modifier
;
2267 error ("Invalid escape character syntax");
2270 c
= read_escape (readcharfun
, 0);
2271 return c
| alt_modifier
;
2275 if (stringp
|| c
!= '-')
2282 c
= read_escape (readcharfun
, 0);
2283 return c
| super_modifier
;
2288 error ("Invalid escape character syntax");
2292 c
= read_escape (readcharfun
, 0);
2293 if ((c
& ~CHAR_MODIFIER_MASK
) == '?')
2294 return 0177 | (c
& CHAR_MODIFIER_MASK
);
2295 else if (! SINGLE_BYTE_CHAR_P ((c
& ~CHAR_MODIFIER_MASK
)))
2296 return c
| ctrl_modifier
;
2297 /* ASCII control chars are made from letters (both cases),
2298 as well as the non-letters within 0100...0137. */
2299 else if ((c
& 0137) >= 0101 && (c
& 0137) <= 0132)
2300 return (c
& (037 | ~0177));
2301 else if ((c
& 0177) >= 0100 && (c
& 0177) <= 0137)
2302 return (c
& (037 | ~0177));
2304 return c
| ctrl_modifier
;
2314 /* An octal escape, as in ANSI C. */
2316 register int i
= c
- '0';
2317 register int count
= 0;
2320 if ((c
= READCHAR
) >= '0' && c
<= '7')
2332 if (i
>= 0x80 && i
< 0x100)
2333 i
= BYTE8_TO_CHAR (i
);
2338 /* A hex escape, as in ANSI C. */
2345 if (c
>= '0' && c
<= '9')
2350 else if ((c
>= 'a' && c
<= 'f')
2351 || (c
>= 'A' && c
<= 'F'))
2354 if (c
>= 'a' && c
<= 'f')
2364 /* Allow hex escapes as large as ?\xfffffff, because some
2365 packages use them to denote characters with modifiers. */
2366 if ((CHAR_META
| (CHAR_META
- 1)) < i
)
2367 error ("Hex character out of range: \\x%x...", i
);
2371 if (count
< 3 && i
>= 0x80)
2372 return BYTE8_TO_CHAR (i
);
2377 /* Post-Unicode-2.0: Up to eight hex chars. */
2378 unicode_hex_count
= 8;
2381 /* A Unicode escape. We only permit them in strings and characters,
2382 not arbitrarily in the source code, as in some other languages. */
2387 while (++count
<= unicode_hex_count
)
2390 /* `isdigit' and `isalpha' may be locale-specific, which we don't
2392 if (c
>= '0' && c
<= '9') i
= (i
<< 4) + (c
- '0');
2393 else if (c
>= 'a' && c
<= 'f') i
= (i
<< 4) + (c
- 'a') + 10;
2394 else if (c
>= 'A' && c
<= 'F') i
= (i
<< 4) + (c
- 'A') + 10;
2396 error ("Non-hex digit used for Unicode escape");
2399 error ("Non-Unicode character: 0x%x", i
);
2404 /* Named character. */
2408 invalid_syntax ("Expected opening brace after \\N");
2409 char name
[UNICODE_CHARACTER_NAME_LENGTH_BOUND
+ 1];
2410 bool whitespace
= false;
2411 ptrdiff_t length
= 0;
2416 end_of_file_error ();
2419 if (! (0 < c
&& c
< 0x80))
2421 AUTO_STRING (format
,
2422 "Invalid character U+%04X in character name");
2423 xsignal1 (Qinvalid_read_syntax
,
2424 CALLN (Fformat
, format
, make_natnum (c
)));
2426 /* Treat multiple adjacent whitespace characters as a
2427 single space character. This makes it easier to use
2428 character names in e.g. multi-line strings. */
2439 if (length
>= sizeof name
)
2440 invalid_syntax ("Character name too long");
2443 invalid_syntax ("Empty character name");
2444 name
[length
] = '\0';
2446 /* character_name_to_code can invoke read1, recursively.
2447 This is why read1's buffer is not static. */
2448 return character_name_to_code (name
, length
);
2456 /* Return the digit that CHARACTER stands for in the given BASE.
2457 Return -1 if CHARACTER is out of range for BASE,
2458 and -2 if CHARACTER is not valid for any supported BASE. */
2460 digit_to_number (int character
, int base
)
2464 if ('0' <= character
&& character
<= '9')
2465 digit
= character
- '0';
2466 else if ('a' <= character
&& character
<= 'z')
2467 digit
= character
- 'a' + 10;
2468 else if ('A' <= character
&& character
<= 'Z')
2469 digit
= character
- 'A' + 10;
2473 return digit
< base
? digit
: -1;
2476 /* Read an integer in radix RADIX using READCHARFUN to read
2477 characters. RADIX must be in the interval [2..36]; if it isn't, a
2478 read error is signaled . Value is the integer read. Signals an
2479 error if encountering invalid read syntax or if RADIX is out of
2483 read_integer (Lisp_Object readcharfun
, EMACS_INT radix
)
2485 /* Room for sign, leading 0, other digits, trailing null byte.
2486 Also, room for invalid syntax diagnostic. */
2487 char buf
[max (1 + 1 + UINTMAX_WIDTH
+ 1,
2488 sizeof "integer, radix " + INT_STRLEN_BOUND (EMACS_INT
))];
2490 int valid
= -1; /* 1 if valid, 0 if not, -1 if incomplete. */
2492 if (radix
< 2 || radix
> 36)
2500 if (c
== '-' || c
== '+')
2511 /* Ignore redundant leading zeros, so the buffer doesn't
2512 fill up with them. */
2518 while ((digit
= digit_to_number (c
, radix
)) >= -1)
2525 if (p
< buf
+ sizeof buf
- 1)
2539 sprintf (buf
, "integer, radix %"pI
"d", radix
);
2540 invalid_syntax (buf
);
2543 return string_to_number (buf
, radix
, 0);
2547 /* If the next token is ')' or ']' or '.', we store that character
2548 in *PCH and the return value is not interesting. Else, we store
2549 zero in *PCH and we read and return one lisp object.
2551 FIRST_IN_LIST is true if this is the first element of a list. */
2554 read1 (Lisp_Object readcharfun
, int *pch
, bool first_in_list
)
2557 bool uninterned_symbol
= false;
2559 char stackbuf
[MAX_ALLOCA
];
2565 c
= READCHAR_REPORT_MULTIBYTE (&multibyte
);
2567 end_of_file_error ();
2572 return read_list (0, readcharfun
);
2575 return read_vector (readcharfun
, 0);
2591 /* Accept extended format for hash tables (extensible to
2593 #s(hash-table size 2 test equal data (k1 v1 k2 v2)) */
2594 Lisp_Object tmp
= read_list (0, readcharfun
);
2595 Lisp_Object head
= CAR_SAFE (tmp
);
2596 Lisp_Object data
= Qnil
;
2597 Lisp_Object val
= Qnil
;
2598 /* The size is 2 * number of allowed keywords to
2600 Lisp_Object params
[12];
2602 Lisp_Object key
= Qnil
;
2603 int param_count
= 0;
2605 if (!EQ (head
, Qhash_table
))
2606 error ("Invalid extended read marker at head of #s list "
2607 "(only hash-table allowed)");
2609 tmp
= CDR_SAFE (tmp
);
2611 /* This is repetitive but fast and simple. */
2612 params
[param_count
] = QCsize
;
2613 params
[param_count
+ 1] = Fplist_get (tmp
, Qsize
);
2614 if (!NILP (params
[param_count
+ 1]))
2617 params
[param_count
] = QCtest
;
2618 params
[param_count
+ 1] = Fplist_get (tmp
, Qtest
);
2619 if (!NILP (params
[param_count
+ 1]))
2622 params
[param_count
] = QCweakness
;
2623 params
[param_count
+ 1] = Fplist_get (tmp
, Qweakness
);
2624 if (!NILP (params
[param_count
+ 1]))
2627 params
[param_count
] = QCrehash_size
;
2628 params
[param_count
+ 1] = Fplist_get (tmp
, Qrehash_size
);
2629 if (!NILP (params
[param_count
+ 1]))
2632 params
[param_count
] = QCrehash_threshold
;
2633 params
[param_count
+ 1] = Fplist_get (tmp
, Qrehash_threshold
);
2634 if (!NILP (params
[param_count
+ 1]))
2637 params
[param_count
] = QCpurecopy
;
2638 params
[param_count
+ 1] = Fplist_get (tmp
, Qpurecopy
);
2639 if (!NILP (params
[param_count
+ 1]))
2642 /* This is the hash table data. */
2643 data
= Fplist_get (tmp
, Qdata
);
2645 /* Now use params to make a new hash table and fill it. */
2646 ht
= Fmake_hash_table (param_count
, params
);
2648 while (CONSP (data
))
2653 error ("Odd number of elements in hash table data");
2656 Fputhash (key
, val
, ht
);
2662 invalid_syntax ("#");
2670 tmp
= read_vector (readcharfun
, 0);
2671 if (ASIZE (tmp
) < CHAR_TABLE_STANDARD_SLOTS
)
2672 error ("Invalid size char-table");
2673 XSETPVECTYPE (XVECTOR (tmp
), PVEC_CHAR_TABLE
);
2681 /* Sub char-table can't be read as a regular
2682 vector because of a two C integer fields. */
2683 Lisp_Object tbl
, tmp
= read_list (1, readcharfun
);
2684 ptrdiff_t size
= XINT (Flength (tmp
));
2685 int i
, depth
, min_char
;
2686 struct Lisp_Cons
*cell
;
2689 error ("Zero-sized sub char-table");
2691 if (! RANGED_INTEGERP (1, XCAR (tmp
), 3))
2692 error ("Invalid depth in sub char-table");
2693 depth
= XINT (XCAR (tmp
));
2694 if (chartab_size
[depth
] != size
- 2)
2695 error ("Invalid size in sub char-table");
2696 cell
= XCONS (tmp
), tmp
= XCDR (tmp
), size
--;
2699 if (! RANGED_INTEGERP (0, XCAR (tmp
), MAX_CHAR
))
2700 error ("Invalid minimum character in sub-char-table");
2701 min_char
= XINT (XCAR (tmp
));
2702 cell
= XCONS (tmp
), tmp
= XCDR (tmp
), size
--;
2705 tbl
= make_uninit_sub_char_table (depth
, min_char
);
2706 for (i
= 0; i
< size
; i
++)
2708 XSUB_CHAR_TABLE (tbl
)->contents
[i
] = XCAR (tmp
);
2709 cell
= XCONS (tmp
), tmp
= XCDR (tmp
);
2714 invalid_syntax ("#^^");
2716 invalid_syntax ("#^");
2721 length
= read1 (readcharfun
, pch
, first_in_list
);
2725 Lisp_Object tmp
, val
;
2726 EMACS_INT size_in_chars
= bool_vector_bytes (XFASTINT (length
));
2727 unsigned char *data
;
2730 tmp
= read1 (readcharfun
, pch
, first_in_list
);
2731 if (STRING_MULTIBYTE (tmp
)
2732 || (size_in_chars
!= SCHARS (tmp
)
2733 /* We used to print 1 char too many
2734 when the number of bits was a multiple of 8.
2735 Accept such input in case it came from an old
2737 && ! (XFASTINT (length
)
2738 == (SCHARS (tmp
) - 1) * BOOL_VECTOR_BITS_PER_CHAR
)))
2739 invalid_syntax ("#&...");
2741 val
= make_uninit_bool_vector (XFASTINT (length
));
2742 data
= bool_vector_uchar_data (val
);
2743 memcpy (data
, SDATA (tmp
), size_in_chars
);
2744 /* Clear the extraneous bits in the last byte. */
2745 if (XINT (length
) != size_in_chars
* BOOL_VECTOR_BITS_PER_CHAR
)
2746 data
[size_in_chars
- 1]
2747 &= (1 << (XINT (length
) % BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2750 invalid_syntax ("#&...");
2754 /* Accept compiled functions at read-time so that we don't have to
2755 build them using function calls. */
2757 struct Lisp_Vector
*vec
;
2758 tmp
= read_vector (readcharfun
, 1);
2759 vec
= XVECTOR (tmp
);
2760 if (vec
->header
.size
== 0)
2761 invalid_syntax ("Empty byte-code object");
2762 make_byte_code (vec
);
2770 /* Read the string itself. */
2771 tmp
= read1 (readcharfun
, &ch
, 0);
2772 if (ch
!= 0 || !STRINGP (tmp
))
2773 invalid_syntax ("#");
2774 /* Read the intervals and their properties. */
2777 Lisp_Object beg
, end
, plist
;
2779 beg
= read1 (readcharfun
, &ch
, 0);
2784 end
= read1 (readcharfun
, &ch
, 0);
2786 plist
= read1 (readcharfun
, &ch
, 0);
2788 invalid_syntax ("Invalid string property list");
2789 Fset_text_properties (beg
, end
, plist
, tmp
);
2795 /* #@NUMBER is used to skip NUMBER following bytes.
2796 That's used in .elc files to skip over doc strings
2797 and function definitions. */
2800 enum { extra
= 100 };
2801 ptrdiff_t i
, nskip
= 0, digits
= 0;
2803 /* Read a decimal integer. */
2804 while ((c
= READCHAR
) >= 0
2805 && c
>= '0' && c
<= '9')
2807 if ((STRING_BYTES_BOUND
- extra
) / 10 <= nskip
)
2812 if (digits
== 2 && nskip
== 0)
2813 { /* We've just seen #@00, which means "skip to end". */
2814 skip_dyn_eof (readcharfun
);
2819 /* We can't use UNREAD here, because in the code below we side-step
2820 READCHAR. Instead, assume the first char after #@NNN occupies
2821 a single byte, which is the case normally since it's just
2827 if (load_force_doc_strings
2828 && (FROM_FILE_P (readcharfun
)))
2830 /* If we are supposed to force doc strings into core right now,
2831 record the last string that we skipped,
2832 and record where in the file it comes from. */
2834 /* But first exchange saved_doc_string
2835 with prev_saved_doc_string, so we save two strings. */
2837 char *temp
= saved_doc_string
;
2838 ptrdiff_t temp_size
= saved_doc_string_size
;
2839 file_offset temp_pos
= saved_doc_string_position
;
2840 ptrdiff_t temp_len
= saved_doc_string_length
;
2842 saved_doc_string
= prev_saved_doc_string
;
2843 saved_doc_string_size
= prev_saved_doc_string_size
;
2844 saved_doc_string_position
= prev_saved_doc_string_position
;
2845 saved_doc_string_length
= prev_saved_doc_string_length
;
2847 prev_saved_doc_string
= temp
;
2848 prev_saved_doc_string_size
= temp_size
;
2849 prev_saved_doc_string_position
= temp_pos
;
2850 prev_saved_doc_string_length
= temp_len
;
2853 if (saved_doc_string_size
== 0)
2855 saved_doc_string
= xmalloc (nskip
+ extra
);
2856 saved_doc_string_size
= nskip
+ extra
;
2858 if (nskip
> saved_doc_string_size
)
2860 saved_doc_string
= xrealloc (saved_doc_string
, nskip
+ extra
);
2861 saved_doc_string_size
= nskip
+ extra
;
2864 saved_doc_string_position
= file_tell (instream
);
2866 /* Copy that many characters into saved_doc_string. */
2868 for (i
= 0; i
< nskip
&& c
>= 0; i
++)
2869 saved_doc_string
[i
] = c
= getc (instream
);
2872 saved_doc_string_length
= i
;
2875 /* Skip that many bytes. */
2876 skip_dyn_bytes (readcharfun
, nskip
);
2882 /* #! appears at the beginning of an executable file.
2883 Skip the first line. */
2884 while (c
!= '\n' && c
>= 0)
2889 return Vload_file_name
;
2891 return list2 (Qfunction
, read0 (readcharfun
));
2892 /* #:foo is the uninterned symbol named foo. */
2895 uninterned_symbol
= true;
2898 && c
!= NO_BREAK_SPACE
2900 || strchr ("\"';()[]#`,", c
) == NULL
)))
2902 /* No symbol character follows, this is the empty
2905 return Fmake_symbol (empty_unibyte_string
);
2909 /* ## is the empty symbol. */
2911 return Fintern (empty_unibyte_string
, Qnil
);
2912 /* Reader forms that can reuse previously read objects. */
2913 if (c
>= '0' && c
<= '9')
2917 bool overflow
= false;
2919 /* Read a non-negative integer. */
2920 while (c
>= '0' && c
<= '9')
2922 overflow
|= INT_MULTIPLY_WRAPV (n
, 10, &n
);
2923 overflow
|= INT_ADD_WRAPV (n
, c
- '0', &n
);
2927 if (!overflow
&& n
<= MOST_POSITIVE_FIXNUM
)
2929 if (c
== 'r' || c
== 'R')
2930 return read_integer (readcharfun
, n
);
2932 if (! NILP (Vread_circle
))
2934 /* #n=object returns object, but associates it with
2938 /* Make a placeholder for #n# to use temporarily. */
2939 /* Note: We used to use AUTO_CONS to allocate
2940 placeholder, but that is a bad idea, since it
2941 will place a stack-allocated cons cell into
2942 the list in read_objects, which is a
2943 staticpro'd global variable, and thus each of
2944 its elements is marked during each GC. A
2945 stack-allocated object will become garbled
2946 when its stack slot goes out of scope, and
2947 some other function reuses it for entirely
2948 different purposes, which will cause crashes
2950 Lisp_Object placeholder
= Fcons (Qnil
, Qnil
);
2951 Lisp_Object cell
= Fcons (make_number (n
), placeholder
);
2952 read_objects
= Fcons (cell
, read_objects
);
2954 /* Read the object itself. */
2955 tem
= read0 (readcharfun
);
2957 /* Now put it everywhere the placeholder was... */
2958 Fsubstitute_object_in_subtree (tem
, placeholder
);
2960 /* ...and #n# will use the real value from now on. */
2961 Fsetcdr (cell
, tem
);
2966 /* #n# returns a previously read object. */
2969 tem
= Fassq (make_number (n
), read_objects
);
2975 /* Fall through to error message. */
2977 else if (c
== 'x' || c
== 'X')
2978 return read_integer (readcharfun
, 16);
2979 else if (c
== 'o' || c
== 'O')
2980 return read_integer (readcharfun
, 8);
2981 else if (c
== 'b' || c
== 'B')
2982 return read_integer (readcharfun
, 2);
2985 invalid_syntax ("#");
2988 while ((c
= READCHAR
) >= 0 && c
!= '\n');
2992 return list2 (Qquote
, read0 (readcharfun
));
2996 int next_char
= READCHAR
;
2998 /* Transition from old-style to new-style:
2999 If we see "(`" it used to mean old-style, which usually works
3000 fine because ` should almost never appear in such a position
3001 for new-style. But occasionally we need "(`" to mean new
3002 style, so we try to distinguish the two by the fact that we
3003 can either write "( `foo" or "(` foo", where the first
3004 intends to use new-style whereas the second intends to use
3005 old-style. For Emacs-25, we should completely remove this
3006 first_in_list exception (old-style can still be obtained via
3008 if (!new_backquote_flag
&& first_in_list
&& next_char
== ' ')
3010 Vold_style_backquotes
= Qt
;
3016 bool saved_new_backquote_flag
= new_backquote_flag
;
3018 new_backquote_flag
= 1;
3019 value
= read0 (readcharfun
);
3020 new_backquote_flag
= saved_new_backquote_flag
;
3022 return list2 (Qbackquote
, value
);
3027 int next_char
= READCHAR
;
3029 /* Transition from old-style to new-style:
3030 It used to be impossible to have a new-style , other than within
3031 a new-style `. This is sufficient when ` and , are used in the
3032 normal way, but ` and , can also appear in args to macros that
3033 will not interpret them in the usual way, in which case , may be
3034 used without any ` anywhere near.
3035 So we now use the same heuristic as for backquote: old-style
3036 unquotes are only recognized when first on a list, and when
3037 followed by a space.
3038 Because it's more difficult to peek 2 chars ahead, a new-style
3039 ,@ can still not be used outside of a `, unless it's in the middle
3041 if (new_backquote_flag
3043 || (next_char
!= ' ' && next_char
!= '@'))
3045 Lisp_Object comma_type
= Qnil
;
3050 comma_type
= Qcomma_at
;
3052 comma_type
= Qcomma_dot
;
3055 if (ch
>= 0) UNREAD (ch
);
3056 comma_type
= Qcomma
;
3059 value
= read0 (readcharfun
);
3060 return list2 (comma_type
, value
);
3064 Vold_style_backquotes
= Qt
;
3076 end_of_file_error ();
3078 /* Accept `single space' syntax like (list ? x) where the
3079 whitespace character is SPC or TAB.
3080 Other literal whitespace like NL, CR, and FF are not accepted,
3081 as there are well-established escape sequences for these. */
3082 if (c
== ' ' || c
== '\t')
3083 return make_number (c
);
3086 c
= read_escape (readcharfun
, 0);
3087 modifiers
= c
& CHAR_MODIFIER_MASK
;
3088 c
&= ~CHAR_MODIFIER_MASK
;
3089 if (CHAR_BYTE8_P (c
))
3090 c
= CHAR_TO_BYTE8 (c
);
3093 next_char
= READCHAR
;
3094 ok
= (next_char
<= 040
3095 || (next_char
< 0200
3096 && strchr ("\"';()[]#?`,.", next_char
) != NULL
));
3099 return make_number (c
);
3101 invalid_syntax ("?");
3106 ptrdiff_t count
= SPECPDL_INDEX ();
3107 char *read_buffer
= stackbuf
;
3108 ptrdiff_t read_buffer_size
= sizeof stackbuf
;
3109 char *heapbuf
= NULL
;
3110 char *p
= read_buffer
;
3111 char *end
= read_buffer
+ read_buffer_size
;
3113 /* True if we saw an escape sequence specifying
3114 a multibyte character. */
3115 bool force_multibyte
= false;
3116 /* True if we saw an escape sequence specifying
3117 a single-byte character. */
3118 bool force_singlebyte
= false;
3119 bool cancel
= false;
3120 ptrdiff_t nchars
= 0;
3122 while ((ch
= READCHAR
) >= 0
3125 if (end
- p
< MAX_MULTIBYTE_LENGTH
)
3127 ptrdiff_t offset
= p
- read_buffer
;
3128 read_buffer
= grow_read_buffer (read_buffer
, offset
,
3129 &heapbuf
, &read_buffer_size
,
3131 p
= read_buffer
+ offset
;
3132 end
= read_buffer
+ read_buffer_size
;
3139 ch
= read_escape (readcharfun
, 1);
3141 /* CH is -1 if \ newline or \ space has just been seen. */
3144 if (p
== read_buffer
)
3149 modifiers
= ch
& CHAR_MODIFIER_MASK
;
3150 ch
= ch
& ~CHAR_MODIFIER_MASK
;
3152 if (CHAR_BYTE8_P (ch
))
3153 force_singlebyte
= true;
3154 else if (! ASCII_CHAR_P (ch
))
3155 force_multibyte
= true;
3156 else /* I.e. ASCII_CHAR_P (ch). */
3158 /* Allow `\C- ' and `\C-?'. */
3159 if (modifiers
== CHAR_CTL
)
3162 ch
= 0, modifiers
= 0;
3164 ch
= 127, modifiers
= 0;
3166 if (modifiers
& CHAR_SHIFT
)
3168 /* Shift modifier is valid only with [A-Za-z]. */
3169 if (ch
>= 'A' && ch
<= 'Z')
3170 modifiers
&= ~CHAR_SHIFT
;
3171 else if (ch
>= 'a' && ch
<= 'z')
3172 ch
-= ('a' - 'A'), modifiers
&= ~CHAR_SHIFT
;
3175 if (modifiers
& CHAR_META
)
3177 /* Move the meta bit to the right place for a
3179 modifiers
&= ~CHAR_META
;
3180 ch
= BYTE8_TO_CHAR (ch
| 0x80);
3181 force_singlebyte
= true;
3185 /* Any modifiers remaining are invalid. */
3187 error ("Invalid modifier in string");
3188 p
+= CHAR_STRING (ch
, (unsigned char *) p
);
3192 p
+= CHAR_STRING (ch
, (unsigned char *) p
);
3193 if (CHAR_BYTE8_P (ch
))
3194 force_singlebyte
= true;
3195 else if (! ASCII_CHAR_P (ch
))
3196 force_multibyte
= true;
3202 end_of_file_error ();
3204 /* If purifying, and string starts with \ newline,
3205 return zero instead. This is for doc strings
3206 that we are really going to find in etc/DOC.nn.nn. */
3207 if (!NILP (Vpurify_flag
) && NILP (Vdoc_file_name
) && cancel
)
3208 return unbind_to (count
, make_number (0));
3210 if (! force_multibyte
&& force_singlebyte
)
3212 /* READ_BUFFER contains raw 8-bit bytes and no multibyte
3213 forms. Convert it to unibyte. */
3214 nchars
= str_as_unibyte ((unsigned char *) read_buffer
,
3216 p
= read_buffer
+ nchars
;
3220 = make_specified_string (read_buffer
, nchars
, p
- read_buffer
,
3222 || (p
- read_buffer
!= nchars
)));
3223 return unbind_to (count
, result
);
3228 int next_char
= READCHAR
;
3231 if (next_char
<= 040
3232 || (next_char
< 0200
3233 && strchr ("\"';([#?`,", next_char
) != NULL
))
3239 /* Otherwise, we fall through! Note that the atom-reading loop
3240 below will now loop at least once, assuring that we will not
3241 try to UNREAD two characters in a row. */
3245 if (c
<= 040) goto retry
;
3246 if (c
== NO_BREAK_SPACE
)
3251 ptrdiff_t count
= SPECPDL_INDEX ();
3252 char *read_buffer
= stackbuf
;
3253 ptrdiff_t read_buffer_size
= sizeof stackbuf
;
3254 char *heapbuf
= NULL
;
3255 char *p
= read_buffer
;
3256 char *end
= read_buffer
+ read_buffer_size
;
3257 bool quoted
= false;
3258 EMACS_INT start_position
= readchar_count
- 1;
3262 if (end
- p
< MAX_MULTIBYTE_LENGTH
+ 1)
3264 ptrdiff_t offset
= p
- read_buffer
;
3265 read_buffer
= grow_read_buffer (read_buffer
, offset
,
3266 &heapbuf
, &read_buffer_size
,
3268 p
= read_buffer
+ offset
;
3269 end
= read_buffer
+ read_buffer_size
;
3276 end_of_file_error ();
3281 p
+= CHAR_STRING (c
, (unsigned char *) p
);
3287 && c
!= NO_BREAK_SPACE
3289 || strchr ("\"';()[]#`,", c
) == NULL
));
3294 if (!quoted
&& !uninterned_symbol
)
3296 Lisp_Object result
= string_to_number (read_buffer
, 10, 0);
3297 if (! NILP (result
))
3298 return unbind_to (count
, result
);
3301 ptrdiff_t nbytes
= p
- read_buffer
;
3304 ? multibyte_chars_in_text ((unsigned char *) read_buffer
,
3307 Lisp_Object name
= ((uninterned_symbol
&& ! NILP (Vpurify_flag
)
3308 ? make_pure_string
: make_specified_string
)
3309 (read_buffer
, nchars
, nbytes
, multibyte
));
3310 Lisp_Object result
= (uninterned_symbol
? Fmake_symbol (name
)
3311 : Fintern (name
, Qnil
));
3313 if (EQ (Vread_with_symbol_positions
, Qt
)
3314 || EQ (Vread_with_symbol_positions
, readcharfun
))
3315 Vread_symbol_positions_list
3316 = Fcons (Fcons (result
, make_number (start_position
)),
3317 Vread_symbol_positions_list
);
3318 return unbind_to (count
, result
);
3324 /* List of nodes we've seen during substitute_object_in_subtree. */
3325 static Lisp_Object seen_list
;
3327 DEFUN ("substitute-object-in-subtree", Fsubstitute_object_in_subtree
,
3328 Ssubstitute_object_in_subtree
, 2, 2, 0,
3329 doc
: /* Replace every reference to PLACEHOLDER in OBJECT with OBJECT. */)
3330 (Lisp_Object object
, Lisp_Object placeholder
)
3332 Lisp_Object check_object
;
3334 /* We haven't seen any objects when we start. */
3337 /* Make all the substitutions. */
3339 = substitute_object_recurse (object
, placeholder
, object
);
3341 /* Clear seen_list because we're done with it. */
3344 /* The returned object here is expected to always eq the
3346 if (!EQ (check_object
, object
))
3347 error ("Unexpected mutation error in reader");
3351 /* Feval doesn't get called from here, so no gc protection is needed. */
3352 #define SUBSTITUTE(get_val, set_val) \
3354 Lisp_Object old_value = get_val; \
3355 Lisp_Object true_value \
3356 = substitute_object_recurse (object, placeholder, \
3359 if (!EQ (old_value, true_value)) \
3366 substitute_object_recurse (Lisp_Object object
, Lisp_Object placeholder
, Lisp_Object subtree
)
3368 /* If we find the placeholder, return the target object. */
3369 if (EQ (placeholder
, subtree
))
3372 /* If we've been to this node before, don't explore it again. */
3373 if (!EQ (Qnil
, Fmemq (subtree
, seen_list
)))
3376 /* If this node can be the entry point to a cycle, remember that
3377 we've seen it. It can only be such an entry point if it was made
3378 by #n=, which means that we can find it as a value in
3380 if (!EQ (Qnil
, Frassq (subtree
, read_objects
)))
3381 seen_list
= Fcons (subtree
, seen_list
);
3383 /* Recurse according to subtree's type.
3384 Every branch must return a Lisp_Object. */
3385 switch (XTYPE (subtree
))
3387 case Lisp_Vectorlike
:
3389 ptrdiff_t i
= 0, length
= 0;
3390 if (BOOL_VECTOR_P (subtree
))
3391 return subtree
; /* No sub-objects anyway. */
3392 else if (CHAR_TABLE_P (subtree
) || SUB_CHAR_TABLE_P (subtree
)
3393 || COMPILEDP (subtree
) || HASH_TABLE_P (subtree
))
3394 length
= ASIZE (subtree
) & PSEUDOVECTOR_SIZE_MASK
;
3395 else if (VECTORP (subtree
))
3396 length
= ASIZE (subtree
);
3398 /* An unknown pseudovector may contain non-Lisp fields, so we
3399 can't just blindly traverse all its fields. We used to call
3400 `Flength' which signaled `sequencep', so I just preserved this
3402 wrong_type_argument (Qsequencep
, subtree
);
3404 if (SUB_CHAR_TABLE_P (subtree
))
3406 for ( ; i
< length
; i
++)
3407 SUBSTITUTE (AREF (subtree
, i
),
3408 ASET (subtree
, i
, true_value
));
3414 SUBSTITUTE (XCAR (subtree
),
3415 XSETCAR (subtree
, true_value
));
3416 SUBSTITUTE (XCDR (subtree
),
3417 XSETCDR (subtree
, true_value
));
3423 /* Check for text properties in each interval.
3424 substitute_in_interval contains part of the logic. */
3426 INTERVAL root_interval
= string_intervals (subtree
);
3427 AUTO_CONS (arg
, object
, placeholder
);
3429 traverse_intervals_noorder (root_interval
,
3430 &substitute_in_interval
, arg
);
3435 /* Other types don't recurse any further. */
3441 /* Helper function for substitute_object_recurse. */
3443 substitute_in_interval (INTERVAL interval
, Lisp_Object arg
)
3445 Lisp_Object object
= Fcar (arg
);
3446 Lisp_Object placeholder
= Fcdr (arg
);
3448 SUBSTITUTE (interval
->plist
, set_interval_plist (interval
, true_value
));
3458 /* Convert STRING to a number, assuming base BASE. Return a fixnum if CP has
3459 integer syntax and fits in a fixnum, else return the nearest float if CP has
3460 either floating point or integer syntax and BASE is 10, else return nil. If
3461 IGNORE_TRAILING, consider just the longest prefix of CP that has
3462 valid floating point syntax. Signal an overflow if BASE is not 10 and the
3463 number has integer syntax but does not fit. */
3466 string_to_number (char const *string
, int base
, bool ignore_trailing
)
3469 char const *cp
= string
;
3471 bool float_syntax
= 0;
3474 /* Negate the value ourselves. This treats 0, NaNs, and infinity properly on
3475 IEEE floating point hosts, and works around a formerly-common bug where
3476 atof ("-0.0") drops the sign. */
3477 bool negative
= *cp
== '-';
3479 bool signedp
= negative
|| *cp
== '+';
3484 leading_digit
= digit_to_number (*cp
, base
);
3485 if (leading_digit
>= 0)
3490 while (digit_to_number (*cp
, base
) >= 0);
3500 if ('0' <= *cp
&& *cp
<= '9')
3505 while ('0' <= *cp
&& *cp
<= '9');
3507 if (*cp
== 'e' || *cp
== 'E')
3509 char const *ecp
= cp
;
3511 if (*cp
== '+' || *cp
== '-')
3513 if ('0' <= *cp
&& *cp
<= '9')
3518 while ('0' <= *cp
&& *cp
<= '9');
3520 else if (cp
[-1] == '+'
3521 && cp
[0] == 'I' && cp
[1] == 'N' && cp
[2] == 'F')
3527 else if (cp
[-1] == '+'
3528 && cp
[0] == 'N' && cp
[1] == 'a' && cp
[2] == 'N')
3532 /* NAN is a "positive" NaN on all known Emacs hosts. */
3539 float_syntax
= ((state
& (DOT_CHAR
|TRAIL_INT
)) == (DOT_CHAR
|TRAIL_INT
)
3540 || state
== (LEAD_INT
|E_EXP
));
3543 /* Return nil if the number uses invalid syntax. If IGNORE_TRAILING, accept
3544 any prefix that matches. Otherwise, the entire string must match. */
3545 if (! (ignore_trailing
3546 ? ((state
& LEAD_INT
) != 0 || float_syntax
)
3547 : (!*cp
&& ((state
& ~DOT_CHAR
) == LEAD_INT
|| float_syntax
))))
3550 /* If the number uses integer and not float syntax, and is in C-language
3551 range, use its value, preferably as a fixnum. */
3552 if (leading_digit
>= 0 && ! float_syntax
)
3556 /* Fast special case for single-digit integers. This also avoids a
3557 glitch when BASE is 16 and IGNORE_TRAILING, because in that
3558 case some versions of strtoumax accept numbers like "0x1" that Emacs
3560 if (digit_to_number (string
[signedp
+ 1], base
) < 0)
3561 return make_number (negative
? -leading_digit
: leading_digit
);
3564 n
= strtoumax (string
+ signedp
, NULL
, base
);
3565 if (errno
== ERANGE
)
3567 /* Unfortunately there's no simple and accurate way to convert
3568 non-base-10 numbers that are out of C-language range. */
3570 xsignal1 (Qoverflow_error
, build_string (string
));
3572 else if (n
<= (negative
? -MOST_NEGATIVE_FIXNUM
: MOST_POSITIVE_FIXNUM
))
3574 EMACS_INT signed_n
= n
;
3575 return make_number (negative
? -signed_n
: signed_n
);
3581 /* Either the number uses float syntax, or it does not fit into a fixnum.
3582 Convert it from string to floating point, unless the value is already
3583 known because it is an infinity, a NAN, or its absolute value fits in
3586 value
= atof (string
+ signedp
);
3588 return make_float (negative
? -value
: value
);
3593 read_vector (Lisp_Object readcharfun
, bool bytecodeflag
)
3597 Lisp_Object tem
, item
, vector
;
3598 struct Lisp_Cons
*otem
;
3601 tem
= read_list (1, readcharfun
);
3602 len
= Flength (tem
);
3603 vector
= Fmake_vector (len
, Qnil
);
3605 size
= ASIZE (vector
);
3606 ptr
= XVECTOR (vector
)->contents
;
3607 for (i
= 0; i
< size
; i
++)
3610 /* If `load-force-doc-strings' is t when reading a lazily-loaded
3611 bytecode object, the docstring containing the bytecode and
3612 constants values must be treated as unibyte and passed to
3613 Fread, to get the actual bytecode string and constants vector. */
3614 if (bytecodeflag
&& load_force_doc_strings
)
3616 if (i
== COMPILED_BYTECODE
)
3618 if (!STRINGP (item
))
3619 error ("Invalid byte code");
3621 /* Delay handling the bytecode slot until we know whether
3622 it is lazily-loaded (we can tell by whether the
3623 constants slot is nil). */
3624 ASET (vector
, COMPILED_CONSTANTS
, item
);
3627 else if (i
== COMPILED_CONSTANTS
)
3629 Lisp_Object bytestr
= ptr
[COMPILED_CONSTANTS
];
3633 /* Coerce string to unibyte (like string-as-unibyte,
3634 but without generating extra garbage and
3635 guaranteeing no change in the contents). */
3636 STRING_SET_CHARS (bytestr
, SBYTES (bytestr
));
3637 STRING_SET_UNIBYTE (bytestr
);
3639 item
= Fread (Fcons (bytestr
, readcharfun
));
3641 error ("Invalid byte code");
3643 otem
= XCONS (item
);
3644 bytestr
= XCAR (item
);
3649 /* Now handle the bytecode slot. */
3650 ASET (vector
, COMPILED_BYTECODE
, bytestr
);
3652 else if (i
== COMPILED_DOC_STRING
3654 && ! STRING_MULTIBYTE (item
))
3656 if (EQ (readcharfun
, Qget_emacs_mule_file_char
))
3657 item
= Fdecode_coding_string (item
, Qemacs_mule
, Qnil
, Qnil
);
3659 item
= Fstring_as_multibyte (item
);
3662 ASET (vector
, i
, item
);
3670 /* FLAG means check for ']' to terminate rather than ')' and '.'. */
3673 read_list (bool flag
, Lisp_Object readcharfun
)
3675 Lisp_Object val
, tail
;
3676 Lisp_Object elt
, tem
;
3677 /* 0 is the normal case.
3678 1 means this list is a doc reference; replace it with the number 0.
3679 2 means this list is a doc reference; replace it with the doc string. */
3680 int doc_reference
= 0;
3682 /* Initialize this to 1 if we are reading a list. */
3683 bool first_in_list
= flag
<= 0;
3691 elt
= read1 (readcharfun
, &ch
, first_in_list
);
3695 /* While building, if the list starts with #$, treat it specially. */
3696 if (EQ (elt
, Vload_file_name
)
3698 && !NILP (Vpurify_flag
))
3700 if (NILP (Vdoc_file_name
))
3701 /* We have not yet called Snarf-documentation, so assume
3702 this file is described in the DOC file
3703 and Snarf-documentation will fill in the right value later.
3704 For now, replace the whole list with 0. */
3707 /* We have already called Snarf-documentation, so make a relative
3708 file name for this file, so it can be found properly
3709 in the installed Lisp directory.
3710 We don't use Fexpand_file_name because that would make
3711 the directory absolute now. */
3713 AUTO_STRING (dot_dot_lisp
, "../lisp/");
3714 elt
= concat2 (dot_dot_lisp
, Ffile_name_nondirectory (elt
));
3717 else if (EQ (elt
, Vload_file_name
)
3719 && load_force_doc_strings
)
3728 invalid_syntax (") or . in a vector");
3735 XSETCDR (tail
, read0 (readcharfun
));
3737 val
= read0 (readcharfun
);
3738 read1 (readcharfun
, &ch
, 0);
3742 if (doc_reference
== 1)
3743 return make_number (0);
3744 if (doc_reference
== 2 && INTEGERP (XCDR (val
)))
3747 file_offset saved_position
;
3748 /* Get a doc string from the file we are loading.
3749 If it's in saved_doc_string, get it from there.
3751 Here, we don't know if the string is a
3752 bytecode string or a doc string. As a
3753 bytecode string must be unibyte, we always
3754 return a unibyte string. If it is actually a
3755 doc string, caller must make it
3758 /* Position is negative for user variables. */
3759 EMACS_INT pos
= eabs (XINT (XCDR (val
)));
3760 if (pos
>= saved_doc_string_position
3761 && pos
< (saved_doc_string_position
3762 + saved_doc_string_length
))
3764 saved
= saved_doc_string
;
3765 saved_position
= saved_doc_string_position
;
3767 /* Look in prev_saved_doc_string the same way. */
3768 else if (pos
>= prev_saved_doc_string_position
3769 && pos
< (prev_saved_doc_string_position
3770 + prev_saved_doc_string_length
))
3772 saved
= prev_saved_doc_string
;
3773 saved_position
= prev_saved_doc_string_position
;
3777 ptrdiff_t start
= pos
- saved_position
;
3780 /* Process quoting with ^A,
3781 and find the end of the string,
3782 which is marked with ^_ (037). */
3783 for (from
= start
, to
= start
;
3784 saved
[from
] != 037;)
3786 int c
= saved
[from
++];
3790 saved
[to
++] = (c
== 1 ? c
3799 return make_unibyte_string (saved
+ start
,
3803 return get_doc_string (val
, 1, 0);
3808 invalid_syntax (". in wrong context");
3810 invalid_syntax ("] in a list");
3814 XSETCDR (tail
, tem
);
3821 static Lisp_Object initial_obarray
;
3823 /* `oblookup' stores the bucket number here, for the sake of Funintern. */
3825 static size_t oblookup_last_bucket_number
;
3827 /* Get an error if OBARRAY is not an obarray.
3828 If it is one, return it. */
3831 check_obarray (Lisp_Object obarray
)
3833 /* We don't want to signal a wrong-type-argument error when we are
3834 shutting down due to a fatal error, and we don't want to hit
3835 assertions in VECTORP and ASIZE if the fatal error was during GC. */
3836 if (!fatal_error_in_progress
3837 && (!VECTORP (obarray
) || ASIZE (obarray
) == 0))
3839 /* If Vobarray is now invalid, force it to be valid. */
3840 if (EQ (Vobarray
, obarray
)) Vobarray
= initial_obarray
;
3841 wrong_type_argument (Qvectorp
, obarray
);
3846 /* Intern symbol SYM in OBARRAY using bucket INDEX. */
3849 intern_sym (Lisp_Object sym
, Lisp_Object obarray
, Lisp_Object index
)
3853 XSYMBOL (sym
)->interned
= (EQ (obarray
, initial_obarray
)
3854 ? SYMBOL_INTERNED_IN_INITIAL_OBARRAY
3857 if (SREF (SYMBOL_NAME (sym
), 0) == ':' && EQ (obarray
, initial_obarray
))
3859 make_symbol_constant (sym
);
3860 XSYMBOL (sym
)->redirect
= SYMBOL_PLAINVAL
;
3861 SET_SYMBOL_VAL (XSYMBOL (sym
), sym
);
3864 ptr
= aref_addr (obarray
, XINT (index
));
3865 set_symbol_next (sym
, SYMBOLP (*ptr
) ? XSYMBOL (*ptr
) : NULL
);
3870 /* Intern a symbol with name STRING in OBARRAY using bucket INDEX. */
3873 intern_driver (Lisp_Object string
, Lisp_Object obarray
, Lisp_Object index
)
3875 return intern_sym (Fmake_symbol (string
), obarray
, index
);
3878 /* Intern the C string STR: return a symbol with that name,
3879 interned in the current obarray. */
3882 intern_1 (const char *str
, ptrdiff_t len
)
3884 Lisp_Object obarray
= check_obarray (Vobarray
);
3885 Lisp_Object tem
= oblookup (obarray
, str
, len
, len
);
3887 return (SYMBOLP (tem
) ? tem
3888 /* The above `oblookup' was done on the basis of nchars==nbytes, so
3889 the string has to be unibyte. */
3890 : intern_driver (make_unibyte_string (str
, len
),
3895 intern_c_string_1 (const char *str
, ptrdiff_t len
)
3897 Lisp_Object obarray
= check_obarray (Vobarray
);
3898 Lisp_Object tem
= oblookup (obarray
, str
, len
, len
);
3902 /* Creating a non-pure string from a string literal not implemented yet.
3903 We could just use make_string here and live with the extra copy. */
3904 eassert (!NILP (Vpurify_flag
));
3905 tem
= intern_driver (make_pure_c_string (str
, len
), obarray
, tem
);
3911 define_symbol (Lisp_Object sym
, char const *str
)
3913 ptrdiff_t len
= strlen (str
);
3914 Lisp_Object string
= make_pure_c_string (str
, len
);
3915 init_symbol (sym
, string
);
3917 /* Qunbound is uninterned, so that it's not confused with any symbol
3918 'unbound' created by a Lisp program. */
3919 if (! EQ (sym
, Qunbound
))
3921 Lisp_Object bucket
= oblookup (initial_obarray
, str
, len
, len
);
3922 eassert (INTEGERP (bucket
));
3923 intern_sym (sym
, initial_obarray
, bucket
);
3927 DEFUN ("intern", Fintern
, Sintern
, 1, 2, 0,
3928 doc
: /* Return the canonical symbol whose name is STRING.
3929 If there is none, one is created by this function and returned.
3930 A second optional argument specifies the obarray to use;
3931 it defaults to the value of `obarray'. */)
3932 (Lisp_Object string
, Lisp_Object obarray
)
3936 obarray
= check_obarray (NILP (obarray
) ? Vobarray
: obarray
);
3937 CHECK_STRING (string
);
3939 tem
= oblookup (obarray
, SSDATA (string
), SCHARS (string
), SBYTES (string
));
3941 tem
= intern_driver (NILP (Vpurify_flag
) ? string
: Fpurecopy (string
),
3946 DEFUN ("intern-soft", Fintern_soft
, Sintern_soft
, 1, 2, 0,
3947 doc
: /* Return the canonical symbol named NAME, or nil if none exists.
3948 NAME may be a string or a symbol. If it is a symbol, that exact
3949 symbol is searched for.
3950 A second optional argument specifies the obarray to use;
3951 it defaults to the value of `obarray'. */)
3952 (Lisp_Object name
, Lisp_Object obarray
)
3954 register Lisp_Object tem
, string
;
3956 if (NILP (obarray
)) obarray
= Vobarray
;
3957 obarray
= check_obarray (obarray
);
3959 if (!SYMBOLP (name
))
3961 CHECK_STRING (name
);
3965 string
= SYMBOL_NAME (name
);
3967 tem
= oblookup (obarray
, SSDATA (string
), SCHARS (string
), SBYTES (string
));
3968 if (INTEGERP (tem
) || (SYMBOLP (name
) && !EQ (name
, tem
)))
3974 DEFUN ("unintern", Funintern
, Sunintern
, 1, 2, 0,
3975 doc
: /* Delete the symbol named NAME, if any, from OBARRAY.
3976 The value is t if a symbol was found and deleted, nil otherwise.
3977 NAME may be a string or a symbol. If it is a symbol, that symbol
3978 is deleted, if it belongs to OBARRAY--no other symbol is deleted.
3979 OBARRAY, if nil, defaults to the value of the variable `obarray'.
3980 usage: (unintern NAME OBARRAY) */)
3981 (Lisp_Object name
, Lisp_Object obarray
)
3983 register Lisp_Object string
, tem
;
3986 if (NILP (obarray
)) obarray
= Vobarray
;
3987 obarray
= check_obarray (obarray
);
3990 string
= SYMBOL_NAME (name
);
3993 CHECK_STRING (name
);
3997 tem
= oblookup (obarray
, SSDATA (string
),
4002 /* If arg was a symbol, don't delete anything but that symbol itself. */
4003 if (SYMBOLP (name
) && !EQ (name
, tem
))
4006 /* There are plenty of other symbols which will screw up the Emacs
4007 session if we unintern them, as well as even more ways to use
4008 `setq' or `fset' or whatnot to make the Emacs session
4009 unusable. Let's not go down this silly road. --Stef */
4010 /* if (EQ (tem, Qnil) || EQ (tem, Qt))
4011 error ("Attempt to unintern t or nil"); */
4013 XSYMBOL (tem
)->interned
= SYMBOL_UNINTERNED
;
4015 hash
= oblookup_last_bucket_number
;
4017 if (EQ (AREF (obarray
, hash
), tem
))
4019 if (XSYMBOL (tem
)->next
)
4022 XSETSYMBOL (sym
, XSYMBOL (tem
)->next
);
4023 ASET (obarray
, hash
, sym
);
4026 ASET (obarray
, hash
, make_number (0));
4030 Lisp_Object tail
, following
;
4032 for (tail
= AREF (obarray
, hash
);
4033 XSYMBOL (tail
)->next
;
4036 XSETSYMBOL (following
, XSYMBOL (tail
)->next
);
4037 if (EQ (following
, tem
))
4039 set_symbol_next (tail
, XSYMBOL (following
)->next
);
4048 /* Return the symbol in OBARRAY whose names matches the string
4049 of SIZE characters (SIZE_BYTE bytes) at PTR.
4050 If there is no such symbol, return the integer bucket number of
4051 where the symbol would be if it were present.
4053 Also store the bucket number in oblookup_last_bucket_number. */
4056 oblookup (Lisp_Object obarray
, register const char *ptr
, ptrdiff_t size
, ptrdiff_t size_byte
)
4060 register Lisp_Object tail
;
4061 Lisp_Object bucket
, tem
;
4063 obarray
= check_obarray (obarray
);
4064 /* This is sometimes needed in the middle of GC. */
4065 obsize
= gc_asize (obarray
);
4066 hash
= hash_string (ptr
, size_byte
) % obsize
;
4067 bucket
= AREF (obarray
, hash
);
4068 oblookup_last_bucket_number
= hash
;
4069 if (EQ (bucket
, make_number (0)))
4071 else if (!SYMBOLP (bucket
))
4072 error ("Bad data in guts of obarray"); /* Like CADR error message. */
4074 for (tail
= bucket
; ; XSETSYMBOL (tail
, XSYMBOL (tail
)->next
))
4076 if (SBYTES (SYMBOL_NAME (tail
)) == size_byte
4077 && SCHARS (SYMBOL_NAME (tail
)) == size
4078 && !memcmp (SDATA (SYMBOL_NAME (tail
)), ptr
, size_byte
))
4080 else if (XSYMBOL (tail
)->next
== 0)
4083 XSETINT (tem
, hash
);
4088 map_obarray (Lisp_Object obarray
, void (*fn
) (Lisp_Object
, Lisp_Object
), Lisp_Object arg
)
4091 register Lisp_Object tail
;
4092 CHECK_VECTOR (obarray
);
4093 for (i
= ASIZE (obarray
) - 1; i
>= 0; i
--)
4095 tail
= AREF (obarray
, i
);
4100 if (XSYMBOL (tail
)->next
== 0)
4102 XSETSYMBOL (tail
, XSYMBOL (tail
)->next
);
4108 mapatoms_1 (Lisp_Object sym
, Lisp_Object function
)
4110 call1 (function
, sym
);
4113 DEFUN ("mapatoms", Fmapatoms
, Smapatoms
, 1, 2, 0,
4114 doc
: /* Call FUNCTION on every symbol in OBARRAY.
4115 OBARRAY defaults to the value of `obarray'. */)
4116 (Lisp_Object function
, Lisp_Object obarray
)
4118 if (NILP (obarray
)) obarray
= Vobarray
;
4119 obarray
= check_obarray (obarray
);
4121 map_obarray (obarray
, mapatoms_1
, function
);
4125 #define OBARRAY_SIZE 15121
4130 Vobarray
= Fmake_vector (make_number (OBARRAY_SIZE
), make_number (0));
4131 initial_obarray
= Vobarray
;
4132 staticpro (&initial_obarray
);
4134 for (int i
= 0; i
< ARRAYELTS (lispsym
); i
++)
4135 define_symbol (builtin_lisp_symbol (i
), defsym_name
[i
]);
4137 DEFSYM (Qunbound
, "unbound");
4139 DEFSYM (Qnil
, "nil");
4140 SET_SYMBOL_VAL (XSYMBOL (Qnil
), Qnil
);
4141 make_symbol_constant (Qnil
);
4142 XSYMBOL (Qnil
)->declared_special
= true;
4145 SET_SYMBOL_VAL (XSYMBOL (Qt
), Qt
);
4146 make_symbol_constant (Qt
);
4147 XSYMBOL (Qt
)->declared_special
= true;
4149 /* Qt is correct even if CANNOT_DUMP. loadup.el will set to nil at end. */
4152 DEFSYM (Qvariable_documentation
, "variable-documentation");
4156 defsubr (struct Lisp_Subr
*sname
)
4158 Lisp_Object sym
, tem
;
4159 sym
= intern_c_string (sname
->symbol_name
);
4160 XSETPVECTYPE (sname
, PVEC_SUBR
);
4161 XSETSUBR (tem
, sname
);
4162 set_symbol_function (sym
, tem
);
4165 #ifdef NOTDEF /* Use fset in subr.el now! */
4167 defalias (struct Lisp_Subr
*sname
, char *string
)
4170 sym
= intern (string
);
4171 XSETSUBR (XSYMBOL (sym
)->function
, sname
);
4175 /* Define an "integer variable"; a symbol whose value is forwarded to a
4176 C variable of type EMACS_INT. Sample call (with "xx" to fool make-docfile):
4177 DEFxxVAR_INT ("emacs-priority", &emacs_priority, "Documentation"); */
4179 defvar_int (struct Lisp_Intfwd
*i_fwd
,
4180 const char *namestring
, EMACS_INT
*address
)
4183 sym
= intern_c_string (namestring
);
4184 i_fwd
->type
= Lisp_Fwd_Int
;
4185 i_fwd
->intvar
= address
;
4186 XSYMBOL (sym
)->declared_special
= 1;
4187 XSYMBOL (sym
)->redirect
= SYMBOL_FORWARDED
;
4188 SET_SYMBOL_FWD (XSYMBOL (sym
), (union Lisp_Fwd
*)i_fwd
);
4191 /* Similar but define a variable whose value is t if address contains 1,
4192 nil if address contains 0. */
4194 defvar_bool (struct Lisp_Boolfwd
*b_fwd
,
4195 const char *namestring
, bool *address
)
4198 sym
= intern_c_string (namestring
);
4199 b_fwd
->type
= Lisp_Fwd_Bool
;
4200 b_fwd
->boolvar
= address
;
4201 XSYMBOL (sym
)->declared_special
= 1;
4202 XSYMBOL (sym
)->redirect
= SYMBOL_FORWARDED
;
4203 SET_SYMBOL_FWD (XSYMBOL (sym
), (union Lisp_Fwd
*)b_fwd
);
4204 Vbyte_boolean_vars
= Fcons (sym
, Vbyte_boolean_vars
);
4207 /* Similar but define a variable whose value is the Lisp Object stored
4208 at address. Two versions: with and without gc-marking of the C
4209 variable. The nopro version is used when that variable will be
4210 gc-marked for some other reason, since marking the same slot twice
4211 can cause trouble with strings. */
4213 defvar_lisp_nopro (struct Lisp_Objfwd
*o_fwd
,
4214 const char *namestring
, Lisp_Object
*address
)
4217 sym
= intern_c_string (namestring
);
4218 o_fwd
->type
= Lisp_Fwd_Obj
;
4219 o_fwd
->objvar
= address
;
4220 XSYMBOL (sym
)->declared_special
= 1;
4221 XSYMBOL (sym
)->redirect
= SYMBOL_FORWARDED
;
4222 SET_SYMBOL_FWD (XSYMBOL (sym
), (union Lisp_Fwd
*)o_fwd
);
4226 defvar_lisp (struct Lisp_Objfwd
*o_fwd
,
4227 const char *namestring
, Lisp_Object
*address
)
4229 defvar_lisp_nopro (o_fwd
, namestring
, address
);
4230 staticpro (address
);
4233 /* Similar but define a variable whose value is the Lisp Object stored
4234 at a particular offset in the current kboard object. */
4237 defvar_kboard (struct Lisp_Kboard_Objfwd
*ko_fwd
,
4238 const char *namestring
, int offset
)
4241 sym
= intern_c_string (namestring
);
4242 ko_fwd
->type
= Lisp_Fwd_Kboard_Obj
;
4243 ko_fwd
->offset
= offset
;
4244 XSYMBOL (sym
)->declared_special
= 1;
4245 XSYMBOL (sym
)->redirect
= SYMBOL_FORWARDED
;
4246 SET_SYMBOL_FWD (XSYMBOL (sym
), (union Lisp_Fwd
*)ko_fwd
);
4249 /* Check that the elements of lpath exist. */
4252 load_path_check (Lisp_Object lpath
)
4254 Lisp_Object path_tail
;
4256 /* The only elements that might not exist are those from
4257 PATH_LOADSEARCH, EMACSLOADPATH. Anything else is only added if
4259 for (path_tail
= lpath
; !NILP (path_tail
); path_tail
= XCDR (path_tail
))
4261 Lisp_Object dirfile
;
4262 dirfile
= Fcar (path_tail
);
4263 if (STRINGP (dirfile
))
4265 dirfile
= Fdirectory_file_name (dirfile
);
4266 if (! file_accessible_directory_p (dirfile
))
4267 dir_warning ("Lisp directory", XCAR (path_tail
));
4272 /* Return the default load-path, to be used if EMACSLOADPATH is unset.
4273 This does not include the standard site-lisp directories
4274 under the installation prefix (i.e., PATH_SITELOADSEARCH),
4275 but it does (unless no_site_lisp is set) include site-lisp
4276 directories in the source/build directories if those exist and we
4277 are running uninstalled.
4279 Uses the following logic:
4281 If Vinstallation_directory is not nil (ie, running uninstalled),
4282 use PATH_DUMPLOADSEARCH (ie, build path). Else use PATH_LOADSEARCH.
4283 The remainder is what happens when dumping works:
4284 If purify-flag (ie dumping) just use PATH_DUMPLOADSEARCH.
4285 Otherwise use PATH_LOADSEARCH.
4287 If !initialized, then just return PATH_DUMPLOADSEARCH.
4289 If Vinstallation_directory is not nil (ie, running uninstalled):
4290 If installation-dir/lisp exists and not already a member,
4291 we must be running uninstalled. Reset the load-path
4292 to just installation-dir/lisp. (The default PATH_LOADSEARCH
4293 refers to the eventual installation directories. Since we
4294 are not yet installed, we should not use them, even if they exist.)
4295 If installation-dir/lisp does not exist, just add
4296 PATH_DUMPLOADSEARCH at the end instead.
4297 Add installation-dir/site-lisp (if !no_site_lisp, and exists
4298 and not already a member) at the front.
4299 If installation-dir != source-dir (ie running an uninstalled,
4300 out-of-tree build) AND install-dir/src/Makefile exists BUT
4301 install-dir/src/Makefile.in does NOT exist (this is a sanity
4302 check), then repeat the above steps for source-dir/lisp, site-lisp. */
4305 load_path_default (void)
4307 Lisp_Object lpath
= Qnil
;
4312 const char *loadpath
= ns_load_path ();
4315 normal
= PATH_LOADSEARCH
;
4316 if (!NILP (Vinstallation_directory
)) normal
= PATH_DUMPLOADSEARCH
;
4319 lpath
= decode_env_path (0, loadpath
? loadpath
: normal
, 0);
4321 lpath
= decode_env_path (0, normal
, 0);
4324 #else /* !CANNOT_DUMP */
4326 normal
= NILP (Vpurify_flag
) ? PATH_LOADSEARCH
: PATH_DUMPLOADSEARCH
;
4331 const char *loadpath
= ns_load_path ();
4332 lpath
= decode_env_path (0, loadpath
? loadpath
: normal
, 0);
4334 lpath
= decode_env_path (0, normal
, 0);
4336 if (!NILP (Vinstallation_directory
))
4338 Lisp_Object tem
, tem1
;
4340 /* Add to the path the lisp subdir of the installation
4341 dir, if it is accessible. Note: in out-of-tree builds,
4342 this directory is empty save for Makefile. */
4343 tem
= Fexpand_file_name (build_string ("lisp"),
4344 Vinstallation_directory
);
4345 tem1
= Ffile_accessible_directory_p (tem
);
4348 if (NILP (Fmember (tem
, lpath
)))
4350 /* We are running uninstalled. The default load-path
4351 points to the eventual installed lisp directories.
4352 We should not use those now, even if they exist,
4353 so start over from a clean slate. */
4354 lpath
= list1 (tem
);
4358 /* That dir doesn't exist, so add the build-time
4359 Lisp dirs instead. */
4361 Lisp_Object dump_path
=
4362 decode_env_path (0, PATH_DUMPLOADSEARCH
, 0);
4363 lpath
= nconc2 (lpath
, dump_path
);
4366 /* Add site-lisp under the installation dir, if it exists. */
4369 tem
= Fexpand_file_name (build_string ("site-lisp"),
4370 Vinstallation_directory
);
4371 tem1
= Ffile_accessible_directory_p (tem
);
4374 if (NILP (Fmember (tem
, lpath
)))
4375 lpath
= Fcons (tem
, lpath
);
4379 /* If Emacs was not built in the source directory,
4380 and it is run from where it was built, add to load-path
4381 the lisp and site-lisp dirs under that directory. */
4383 if (NILP (Fequal (Vinstallation_directory
, Vsource_directory
)))
4387 tem
= Fexpand_file_name (build_string ("src/Makefile"),
4388 Vinstallation_directory
);
4389 tem1
= Ffile_exists_p (tem
);
4391 /* Don't be fooled if they moved the entire source tree
4392 AFTER dumping Emacs. If the build directory is indeed
4393 different from the source dir, src/Makefile.in and
4394 src/Makefile will not be found together. */
4395 tem
= Fexpand_file_name (build_string ("src/Makefile.in"),
4396 Vinstallation_directory
);
4397 tem2
= Ffile_exists_p (tem
);
4398 if (!NILP (tem1
) && NILP (tem2
))
4400 tem
= Fexpand_file_name (build_string ("lisp"),
4403 if (NILP (Fmember (tem
, lpath
)))
4404 lpath
= Fcons (tem
, lpath
);
4408 tem
= Fexpand_file_name (build_string ("site-lisp"),
4410 tem1
= Ffile_accessible_directory_p (tem
);
4413 if (NILP (Fmember (tem
, lpath
)))
4414 lpath
= Fcons (tem
, lpath
);
4418 } /* Vinstallation_directory != Vsource_directory */
4420 } /* if Vinstallation_directory */
4422 else /* !initialized */
4424 /* NORMAL refers to PATH_DUMPLOADSEARCH, ie the lisp dir in the
4425 source directory. We used to add ../lisp (ie the lisp dir in
4426 the build directory) at the front here, but that should not
4427 be necessary, since in out of tree builds lisp/ is empty, save
4429 lpath
= decode_env_path (0, normal
, 0);
4431 #endif /* !CANNOT_DUMP */
4439 /* First, set Vload_path. */
4441 /* Ignore EMACSLOADPATH when dumping. */
4443 bool use_loadpath
= true;
4445 bool use_loadpath
= NILP (Vpurify_flag
);
4448 if (use_loadpath
&& egetenv ("EMACSLOADPATH"))
4450 Vload_path
= decode_env_path ("EMACSLOADPATH", 0, 1);
4452 /* Check (non-nil) user-supplied elements. */
4453 load_path_check (Vload_path
);
4455 /* If no nils in the environment variable, use as-is.
4456 Otherwise, replace any nils with the default. */
4457 if (! NILP (Fmemq (Qnil
, Vload_path
)))
4459 Lisp_Object elem
, elpath
= Vload_path
;
4460 Lisp_Object default_lpath
= load_path_default ();
4462 /* Check defaults, before adding site-lisp. */
4463 load_path_check (default_lpath
);
4465 /* Add the site-lisp directories to the front of the default. */
4466 if (!no_site_lisp
&& PATH_SITELOADSEARCH
[0] != '\0')
4468 Lisp_Object sitelisp
;
4469 sitelisp
= decode_env_path (0, PATH_SITELOADSEARCH
, 0);
4470 if (! NILP (sitelisp
))
4471 default_lpath
= nconc2 (sitelisp
, default_lpath
);
4476 /* Replace nils from EMACSLOADPATH by default. */
4477 while (CONSP (elpath
))
4479 elem
= XCAR (elpath
);
4480 elpath
= XCDR (elpath
);
4481 Vload_path
= CALLN (Fappend
, Vload_path
,
4482 NILP (elem
) ? default_lpath
: list1 (elem
));
4484 } /* Fmemq (Qnil, Vload_path) */
4488 Vload_path
= load_path_default ();
4490 /* Check before adding site-lisp directories.
4491 The install should have created them, but they are not
4492 required, so no need to warn if they are absent.
4493 Or we might be running before installation. */
4494 load_path_check (Vload_path
);
4496 /* Add the site-lisp directories at the front. */
4497 if (initialized
&& !no_site_lisp
&& PATH_SITELOADSEARCH
[0] != '\0')
4499 Lisp_Object sitelisp
;
4500 sitelisp
= decode_env_path (0, PATH_SITELOADSEARCH
, 0);
4501 if (! NILP (sitelisp
)) Vload_path
= nconc2 (sitelisp
, Vload_path
);
4507 load_in_progress
= 0;
4508 Vload_file_name
= Qnil
;
4509 Vstandard_input
= Qt
;
4510 Vloads_in_progress
= Qnil
;
4513 /* Print a warning that directory intended for use USE and with name
4514 DIRNAME cannot be accessed. On entry, errno should correspond to
4515 the access failure. Print the warning on stderr and put it in
4519 dir_warning (char const *use
, Lisp_Object dirname
)
4521 static char const format
[] = "Warning: %s '%s': %s\n";
4522 char *diagnostic
= emacs_strerror (errno
);
4523 fprintf (stderr
, format
, use
, SSDATA (ENCODE_SYSTEM (dirname
)), diagnostic
);
4525 /* Don't log the warning before we've initialized!! */
4528 ptrdiff_t diaglen
= strlen (diagnostic
);
4529 AUTO_STRING_WITH_LEN (diag
, diagnostic
, diaglen
);
4530 if (! NILP (Vlocale_coding_system
))
4533 = code_convert_string_norecord (diag
, Vlocale_coding_system
, false);
4534 diagnostic
= SSDATA (s
);
4535 diaglen
= SBYTES (s
);
4538 char *buffer
= SAFE_ALLOCA (sizeof format
- 3 * (sizeof "%s" - 1)
4539 + strlen (use
) + SBYTES (dirname
) + diaglen
);
4540 ptrdiff_t message_len
= esprintf (buffer
, format
, use
, SSDATA (dirname
),
4542 message_dolog (buffer
, message_len
, 0, STRING_MULTIBYTE (dirname
));
4548 syms_of_lread (void)
4551 defsubr (&Sread_from_string
);
4552 defsubr (&Ssubstitute_object_in_subtree
);
4554 defsubr (&Sintern_soft
);
4555 defsubr (&Sunintern
);
4556 defsubr (&Sget_load_suffixes
);
4558 defsubr (&Seval_buffer
);
4559 defsubr (&Seval_region
);
4560 defsubr (&Sread_char
);
4561 defsubr (&Sread_char_exclusive
);
4562 defsubr (&Sread_event
);
4563 defsubr (&Sget_file_char
);
4564 defsubr (&Smapatoms
);
4565 defsubr (&Slocate_file_internal
);
4567 DEFVAR_LISP ("obarray", Vobarray
,
4568 doc
: /* Symbol table for use by `intern' and `read'.
4569 It is a vector whose length ought to be prime for best results.
4570 The vector's contents don't make sense if examined from Lisp programs;
4571 to find all the symbols in an obarray, use `mapatoms'. */);
4573 DEFVAR_LISP ("values", Vvalues
,
4574 doc
: /* List of values of all expressions which were read, evaluated and printed.
4575 Order is reverse chronological. */);
4576 XSYMBOL (intern ("values"))->declared_special
= 0;
4578 DEFVAR_LISP ("standard-input", Vstandard_input
,
4579 doc
: /* Stream for read to get input from.
4580 See documentation of `read' for possible values. */);
4581 Vstandard_input
= Qt
;
4583 DEFVAR_LISP ("read-with-symbol-positions", Vread_with_symbol_positions
,
4584 doc
: /* If non-nil, add position of read symbols to `read-symbol-positions-list'.
4586 If this variable is a buffer, then only forms read from that buffer
4587 will be added to `read-symbol-positions-list'.
4588 If this variable is t, then all read forms will be added.
4589 The effect of all other values other than nil are not currently
4590 defined, although they may be in the future.
4592 The positions are relative to the last call to `read' or
4593 `read-from-string'. It is probably a bad idea to set this variable at
4594 the toplevel; bind it instead. */);
4595 Vread_with_symbol_positions
= Qnil
;
4597 DEFVAR_LISP ("read-symbol-positions-list", Vread_symbol_positions_list
,
4598 doc
: /* A list mapping read symbols to their positions.
4599 This variable is modified during calls to `read' or
4600 `read-from-string', but only when `read-with-symbol-positions' is
4603 Each element of the list looks like (SYMBOL . CHAR-POSITION), where
4604 CHAR-POSITION is an integer giving the offset of that occurrence of the
4605 symbol from the position where `read' or `read-from-string' started.
4607 Note that a symbol will appear multiple times in this list, if it was
4608 read multiple times. The list is in the same order as the symbols
4610 Vread_symbol_positions_list
= Qnil
;
4612 DEFVAR_LISP ("read-circle", Vread_circle
,
4613 doc
: /* Non-nil means read recursive structures using #N= and #N# syntax. */);
4616 DEFVAR_LISP ("load-path", Vload_path
,
4617 doc
: /* List of directories to search for files to load.
4618 Each element is a string (directory file name) or nil (meaning
4619 `default-directory').
4620 This list is consulted by the `require' function.
4621 Initialized during startup as described in Info node `(elisp)Library Search'.
4622 Use `directory-file-name' when adding items to this path. However, Lisp
4623 programs that process this list should tolerate directories both with
4624 and without trailing slashes. */);
4626 DEFVAR_LISP ("load-suffixes", Vload_suffixes
,
4627 doc
: /* List of suffixes for Emacs Lisp files and dynamic modules.
4628 This list includes suffixes for both compiled and source Emacs Lisp files.
4629 This list should not include the empty string.
4630 `load' and related functions try to append these suffixes, in order,
4631 to the specified file name if a suffix is allowed or required. */);
4633 Vload_suffixes
= list3 (build_pure_c_string (".elc"),
4634 build_pure_c_string (".el"),
4635 build_pure_c_string (MODULES_SUFFIX
));
4637 Vload_suffixes
= list2 (build_pure_c_string (".elc"),
4638 build_pure_c_string (".el"));
4640 DEFVAR_LISP ("module-file-suffix", Vmodule_file_suffix
,
4641 doc
: /* Suffix of loadable module file, or nil of modules are not supported. */);
4643 Vmodule_file_suffix
= build_pure_c_string (MODULES_SUFFIX
);
4645 Vmodule_file_suffix
= Qnil
;
4647 DEFVAR_LISP ("load-file-rep-suffixes", Vload_file_rep_suffixes
,
4648 doc
: /* List of suffixes that indicate representations of \
4650 This list should normally start with the empty string.
4652 Enabling Auto Compression mode appends the suffixes in
4653 `jka-compr-load-suffixes' to this list and disabling Auto Compression
4654 mode removes them again. `load' and related functions use this list to
4655 determine whether they should look for compressed versions of a file
4656 and, if so, which suffixes they should try to append to the file name
4657 in order to do so. However, if you want to customize which suffixes
4658 the loading functions recognize as compression suffixes, you should
4659 customize `jka-compr-load-suffixes' rather than the present variable. */);
4660 Vload_file_rep_suffixes
= list1 (empty_unibyte_string
);
4662 DEFVAR_BOOL ("load-in-progress", load_in_progress
,
4663 doc
: /* Non-nil if inside of `load'. */);
4664 DEFSYM (Qload_in_progress
, "load-in-progress");
4666 DEFVAR_LISP ("after-load-alist", Vafter_load_alist
,
4667 doc
: /* An alist of functions to be evalled when particular files are loaded.
4668 Each element looks like (REGEXP-OR-FEATURE FUNCS...).
4670 REGEXP-OR-FEATURE is either a regular expression to match file names, or
4671 a symbol (a feature name).
4673 When `load' is run and the file-name argument matches an element's
4674 REGEXP-OR-FEATURE, or when `provide' is run and provides the symbol
4675 REGEXP-OR-FEATURE, the FUNCS in the element are called.
4677 An error in FORMS does not undo the load, but does prevent execution of
4678 the rest of the FORMS. */);
4679 Vafter_load_alist
= Qnil
;
4681 DEFVAR_LISP ("load-history", Vload_history
,
4682 doc
: /* Alist mapping loaded file names to symbols and features.
4683 Each alist element should be a list (FILE-NAME ENTRIES...), where
4684 FILE-NAME is the name of a file that has been loaded into Emacs.
4685 The file name is absolute and true (i.e. it doesn't contain symlinks).
4686 As an exception, one of the alist elements may have FILE-NAME nil,
4687 for symbols and features not associated with any file.
4689 The remaining ENTRIES in the alist element describe the functions and
4690 variables defined in that file, the features provided, and the
4691 features required. Each entry has the form `(provide . FEATURE)',
4692 `(require . FEATURE)', `(defun . FUNCTION)', `(autoload . SYMBOL)',
4693 `(defface . SYMBOL)', or `(t . SYMBOL)'. Entries like `(t . SYMBOL)'
4694 may precede a `(defun . FUNCTION)' entry, and means that SYMBOL was an
4695 autoload before this file redefined it as a function. In addition,
4696 entries may also be single symbols, which means that SYMBOL was
4697 defined by `defvar' or `defconst'.
4699 During preloading, the file name recorded is relative to the main Lisp
4700 directory. These file names are converted to absolute at startup. */);
4701 Vload_history
= Qnil
;
4703 DEFVAR_LISP ("load-file-name", Vload_file_name
,
4704 doc
: /* Full name of file being loaded by `load'. */);
4705 Vload_file_name
= Qnil
;
4707 DEFVAR_LISP ("user-init-file", Vuser_init_file
,
4708 doc
: /* File name, including directory, of user's initialization file.
4709 If the file loaded had extension `.elc', and the corresponding source file
4710 exists, this variable contains the name of source file, suitable for use
4711 by functions like `custom-save-all' which edit the init file.
4712 While Emacs loads and evaluates the init file, value is the real name
4713 of the file, regardless of whether or not it has the `.elc' extension. */);
4714 Vuser_init_file
= Qnil
;
4716 DEFVAR_LISP ("current-load-list", Vcurrent_load_list
,
4717 doc
: /* Used for internal purposes by `load'. */);
4718 Vcurrent_load_list
= Qnil
;
4720 DEFVAR_LISP ("load-read-function", Vload_read_function
,
4721 doc
: /* Function used by `load' and `eval-region' for reading expressions.
4722 Called with a single argument (the stream from which to read).
4723 The default is to use the function `read'. */);
4724 DEFSYM (Qread
, "read");
4725 Vload_read_function
= Qread
;
4727 DEFVAR_LISP ("load-source-file-function", Vload_source_file_function
,
4728 doc
: /* Function called in `load' to load an Emacs Lisp source file.
4729 The value should be a function for doing code conversion before
4730 reading a source file. It can also be nil, in which case loading is
4731 done without any code conversion.
4733 If the value is a function, it is called with four arguments,
4734 FULLNAME, FILE, NOERROR, NOMESSAGE. FULLNAME is the absolute name of
4735 the file to load, FILE is the non-absolute name (for messages etc.),
4736 and NOERROR and NOMESSAGE are the corresponding arguments passed to
4737 `load'. The function should return t if the file was loaded. */);
4738 Vload_source_file_function
= Qnil
;
4740 DEFVAR_BOOL ("load-force-doc-strings", load_force_doc_strings
,
4741 doc
: /* Non-nil means `load' should force-load all dynamic doc strings.
4742 This is useful when the file being loaded is a temporary copy. */);
4743 load_force_doc_strings
= 0;
4745 DEFVAR_BOOL ("load-convert-to-unibyte", load_convert_to_unibyte
,
4746 doc
: /* Non-nil means `read' converts strings to unibyte whenever possible.
4747 This is normally bound by `load' and `eval-buffer' to control `read',
4748 and is not meant for users to change. */);
4749 load_convert_to_unibyte
= 0;
4751 DEFVAR_LISP ("source-directory", Vsource_directory
,
4752 doc
: /* Directory in which Emacs sources were found when Emacs was built.
4753 You cannot count on them to still be there! */);
4755 = Fexpand_file_name (build_string ("../"),
4756 Fcar (decode_env_path (0, PATH_DUMPLOADSEARCH
, 0)));
4758 DEFVAR_LISP ("preloaded-file-list", Vpreloaded_file_list
,
4759 doc
: /* List of files that were preloaded (when dumping Emacs). */);
4760 Vpreloaded_file_list
= Qnil
;
4762 DEFVAR_LISP ("byte-boolean-vars", Vbyte_boolean_vars
,
4763 doc
: /* List of all DEFVAR_BOOL variables, used by the byte code optimizer. */);
4764 Vbyte_boolean_vars
= Qnil
;
4766 DEFVAR_BOOL ("load-dangerous-libraries", load_dangerous_libraries
,
4767 doc
: /* Non-nil means load dangerous compiled Lisp files.
4768 Some versions of XEmacs use different byte codes than Emacs. These
4769 incompatible byte codes can make Emacs crash when it tries to execute
4771 load_dangerous_libraries
= 0;
4773 DEFVAR_BOOL ("force-load-messages", force_load_messages
,
4774 doc
: /* Non-nil means force printing messages when loading Lisp files.
4775 This overrides the value of the NOMESSAGE argument to `load'. */);
4776 force_load_messages
= 0;
4778 DEFVAR_LISP ("bytecomp-version-regexp", Vbytecomp_version_regexp
,
4779 doc
: /* Regular expression matching safe to load compiled Lisp files.
4780 When Emacs loads a compiled Lisp file, it reads the first 512 bytes
4781 from the file, and matches them against this regular expression.
4782 When the regular expression matches, the file is considered to be safe
4783 to load. See also `load-dangerous-libraries'. */);
4784 Vbytecomp_version_regexp
4785 = build_pure_c_string ("^;;;.\\(in Emacs version\\|bytecomp version FSF\\)");
4787 DEFSYM (Qlexical_binding
, "lexical-binding");
4788 DEFVAR_LISP ("lexical-binding", Vlexical_binding
,
4789 doc
: /* Whether to use lexical binding when evaluating code.
4790 Non-nil means that the code in the current buffer should be evaluated
4791 with lexical binding.
4792 This variable is automatically set from the file variables of an
4793 interpreted Lisp file read using `load'. Unlike other file local
4794 variables, this must be set in the first line of a file. */);
4795 Vlexical_binding
= Qnil
;
4796 Fmake_variable_buffer_local (Qlexical_binding
);
4798 DEFVAR_LISP ("eval-buffer-list", Veval_buffer_list
,
4799 doc
: /* List of buffers being read from by calls to `eval-buffer' and `eval-region'. */);
4800 Veval_buffer_list
= Qnil
;
4802 DEFVAR_LISP ("old-style-backquotes", Vold_style_backquotes
,
4803 doc
: /* Set to non-nil when `read' encounters an old-style backquote. */);
4804 Vold_style_backquotes
= Qnil
;
4805 DEFSYM (Qold_style_backquotes
, "old-style-backquotes");
4807 DEFVAR_BOOL ("load-prefer-newer", load_prefer_newer
,
4808 doc
: /* Non-nil means `load' prefers the newest version of a file.
4809 This applies when a filename suffix is not explicitly specified and
4810 `load' is trying various possible suffixes (see `load-suffixes' and
4811 `load-file-rep-suffixes'). Normally, it stops at the first file
4812 that exists unless you explicitly specify one or the other. If this
4813 option is non-nil, it checks all suffixes and uses whichever file is
4815 Note that if you customize this, obviously it will not affect files
4816 that are loaded before your customizations are read! */);
4817 load_prefer_newer
= 0;
4819 /* Vsource_directory was initialized in init_lread. */
4821 DEFSYM (Qcurrent_load_list
, "current-load-list");
4822 DEFSYM (Qstandard_input
, "standard-input");
4823 DEFSYM (Qread_char
, "read-char");
4824 DEFSYM (Qget_file_char
, "get-file-char");
4826 /* Used instead of Qget_file_char while loading *.elc files compiled
4827 by Emacs 21 or older. */
4828 DEFSYM (Qget_emacs_mule_file_char
, "get-emacs-mule-file-char");
4830 DEFSYM (Qload_force_doc_strings
, "load-force-doc-strings");
4832 DEFSYM (Qbackquote
, "`");
4833 DEFSYM (Qcomma
, ",");
4834 DEFSYM (Qcomma_at
, ",@");
4835 DEFSYM (Qcomma_dot
, ",.");
4837 DEFSYM (Qinhibit_file_name_operation
, "inhibit-file-name-operation");
4838 DEFSYM (Qascii_character
, "ascii-character");
4839 DEFSYM (Qfunction
, "function");
4840 DEFSYM (Qload
, "load");
4841 DEFSYM (Qload_file_name
, "load-file-name");
4842 DEFSYM (Qeval_buffer_list
, "eval-buffer-list");
4843 DEFSYM (Qfile_truename
, "file-truename");
4844 DEFSYM (Qdir_ok
, "dir-ok");
4845 DEFSYM (Qdo_after_load_evaluation
, "do-after-load-evaluation");
4847 staticpro (&read_objects
);
4848 read_objects
= Qnil
;
4849 staticpro (&seen_list
);
4852 Vloads_in_progress
= Qnil
;
4853 staticpro (&Vloads_in_progress
);
4855 DEFSYM (Qhash_table
, "hash-table");
4856 DEFSYM (Qdata
, "data");
4857 DEFSYM (Qtest
, "test");
4858 DEFSYM (Qsize
, "size");
4859 DEFSYM (Qpurecopy
, "purecopy");
4860 DEFSYM (Qweakness
, "weakness");
4861 DEFSYM (Qrehash_size
, "rehash-size");
4862 DEFSYM (Qrehash_threshold
, "rehash-threshold");
4864 DEFSYM (Qchar_from_name
, "char-from-name");