1 /* Lisp parsing and input streams.
2
3 Copyright (C) 1985-1989, 1993-1995, 1997-2021 Free Software Foundation,
4 Inc.
5
6 This file is part of GNU Emacs.
7
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.
12
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.
17
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
20
21 /* Tell globals.h to define tables needed by init_obarray. */
22 #define DEFINE_SYMBOLS
23
24 #include <config.h>
25 #include "sysstdio.h"
26 #include <stdlib.h>
27 #include <sys/types.h>
28 #include <sys/stat.h>
29 #include <sys/file.h>
30 #include <errno.h>
31 #include <math.h>
32 #include <stat-time.h>
33 #include "lisp.h"
34 #include "dispextern.h"
35 #include "intervals.h"
36 #include "character.h"
37 #include "buffer.h"
38 #include "charset.h"
39 #include <epaths.h>
40 #include "commands.h"
41 #include "keyboard.h"
42 #include "systime.h"
43 #include "termhooks.h"
44 #include "blockinput.h"
45 #include "pdumper.h"
46 #include <c-ctype.h>
47 #include <vla.h>
48
49 #ifdef MSDOS
50 #include "msdos.h"
51 #endif
52
53 #ifdef HAVE_NS
54 #include "nsterm.h"
55 #endif
56
57 #include <unistd.h>
58
59 #ifdef HAVE_SETLOCALE
60 #include <locale.h>
61 #endif /* HAVE_SETLOCALE */
62
63 #include <fcntl.h>
64
65 #ifdef HAVE_FSEEKO
66 #define file_offset off_t
67 #define file_tell ftello
68 #else
69 #define file_offset long
70 #define file_tell ftell
71 #endif
72
73 #if IEEE_FLOATING_POINT
74 # include <ieee754.h>
75 # ifndef INFINITY
76 # define INFINITY ((union ieee754_double) {.ieee = {.exponent = -1}}.d)
77 # endif
78 #endif
79
80 /* The objects or placeholders read with the #n=object form.
81
82 A hash table maps a number to either a placeholder (while the
83 object is still being parsed, in case it's referenced within its
84 own definition) or to the completed object. With small integers
85 for keys, it's effectively little more than a vector, but it'll
86 manage any needed resizing for us.
87
88 The variable must be reset to an empty hash table before all
89 top-level calls to read0. In between calls, it may be an empty
90 hash table left unused from the previous call (to reduce
91 allocations), or nil. */
92 static Lisp_Object read_objects_map;
93
94 /* The recursive objects read with the #n=object form.
95
96 Objects that might have circular references are stored here, so
97 that recursive substitution knows not to keep processing them
98 multiple times.
99
100 Only objects that are completely processed, including substituting
101 references to themselves (but not necessarily replacing
102 placeholders for other objects still being read), are stored.
103
104 A hash table is used for efficient lookups of keys. We don't care
105 what the value slots hold. The variable must be set to an empty
106 hash table before all top-level calls to read0. In between calls,
107 it may be an empty hash table left unused from the previous call
108 (to reduce allocations), or nil. */
109 static Lisp_Object read_objects_completed;
110
111 /* File and lookahead for get-file-char and get-emacs-mule-file-char
112 to read from. Used by Fload. */
113 static struct infile
114 {
115 /* The input stream. */
116 FILE *stream;
117
118 /* Lookahead byte count. */
119 signed char lookahead;
120
121 /* Lookahead bytes, in reverse order. Keep these here because it is
122 not portable to ungetc more than one byte at a time. */
123 unsigned char buf[MAX_MULTIBYTE_LENGTH - 1];
124 } *infile;
125
126 /* For use within read-from-string (this reader is non-reentrant!!) */
127 static ptrdiff_t read_from_string_index;
128 static ptrdiff_t read_from_string_index_byte;
129 static ptrdiff_t read_from_string_limit;
130
131 /* Number of characters read in the current call to Fread or
132 Fread_from_string. */
133 static EMACS_INT readchar_count;
134
135 /* This contains the last string skipped with #@. */
136 static char *saved_doc_string;
137 /* Length of buffer allocated in saved_doc_string. */
138 static ptrdiff_t saved_doc_string_size;
139 /* Length of actual data in saved_doc_string. */
140 static ptrdiff_t saved_doc_string_length;
141 /* This is the file position that string came from. */
142 static file_offset saved_doc_string_position;
143
144 /* This contains the previous string skipped with #@.
145 We copy it from saved_doc_string when a new string
146 is put in saved_doc_string. */
147 static char *prev_saved_doc_string;
148 /* Length of buffer allocated in prev_saved_doc_string. */
149 static ptrdiff_t prev_saved_doc_string_size;
150 /* Length of actual data in prev_saved_doc_string. */
151 static ptrdiff_t prev_saved_doc_string_length;
152 /* This is the file position that string came from. */
153 static file_offset prev_saved_doc_string_position;
154
155 /* True means inside a new-style backquote with no surrounding
156 parentheses. Fread initializes this to the value of
157 `force_new_style_backquotes', so we need not specbind it or worry
158 about what happens to it when there is an error. */
159 static bool new_backquote_flag;
160
161 /* A list of file names for files being loaded in Fload. Used to
162 check for recursive loads. */
163
164 static Lisp_Object Vloads_in_progress;
165
166 static int read_emacs_mule_char (int, int (*) (int, Lisp_Object),
167 Lisp_Object);
168
169 static void readevalloop (Lisp_Object, struct infile *, Lisp_Object, bool,
170 Lisp_Object, Lisp_Object,
171 Lisp_Object, Lisp_Object);
172
173 static void build_load_history (Lisp_Object, bool);
174
175 /* Functions that read one byte from the current source READCHARFUN
176 or unreads one byte. If the integer argument C is -1, it returns
177 one read byte, or -1 when there's no more byte in the source. If C
178 is 0 or positive, it unreads C, and the return value is not
179 interesting. */
180
181 static int readbyte_for_lambda (int, Lisp_Object);
182 static int readbyte_from_file (int, Lisp_Object);
183 static int readbyte_from_string (int, Lisp_Object);
184
185 /* Handle unreading and rereading of characters.
186 Write READCHAR to read a character,
187 UNREAD(c) to unread c to be read again.
188
189 These macros correctly read/unread multibyte characters. */
190
191 #define READCHAR readchar (readcharfun, NULL)
192 #define UNREAD(c) unreadchar (readcharfun, c)
193
194 /* Same as READCHAR but set *MULTIBYTE to the multibyteness of the source. */
195 #define READCHAR_REPORT_MULTIBYTE(multibyte) readchar (readcharfun, multibyte)
196
197 /* When READCHARFUN is Qget_file_char, Qget_emacs_mule_file_char,
198 Qlambda, or a cons, we use this to keep an unread character because
199 a file stream can't handle multibyte-char unreading. The value -1
200 means that there's no unread character. */
201 static int unread_char;
202
203 static int
readchar(Lisp_Object readcharfun,bool * multibyte)204 readchar (Lisp_Object readcharfun, bool *multibyte)
205 {
206 Lisp_Object tem;
207 register int c;
208 int (*readbyte) (int, Lisp_Object);
209 unsigned char buf[MAX_MULTIBYTE_LENGTH];
210 int i, len;
211 bool emacs_mule_encoding = 0;
212
213 if (multibyte)
214 *multibyte = 0;
215
216 readchar_count++;
217
218 if (BUFFERP (readcharfun))
219 {
220 register struct buffer *inbuffer = XBUFFER (readcharfun);
221
222 ptrdiff_t pt_byte = BUF_PT_BYTE (inbuffer);
223
224 if (! BUFFER_LIVE_P (inbuffer))
225 return -1;
226
227 if (pt_byte >= BUF_ZV_BYTE (inbuffer))
228 return -1;
229
230 if (! NILP (BVAR (inbuffer, enable_multibyte_characters)))
231 {
232 /* Fetch the character code from the buffer. */
233 unsigned char *p = BUF_BYTE_ADDRESS (inbuffer, pt_byte);
234 BUF_INC_POS (inbuffer, pt_byte);
235 c = STRING_CHAR (p);
236 if (multibyte)
237 *multibyte = 1;
238 }
239 else
240 {
241 c = BUF_FETCH_BYTE (inbuffer, pt_byte);
242 if (! ASCII_CHAR_P (c))
243 c = BYTE8_TO_CHAR (c);
244 pt_byte++;
245 }
246 SET_BUF_PT_BOTH (inbuffer, BUF_PT (inbuffer) + 1, pt_byte);
247
248 return c;
249 }
250 if (MARKERP (readcharfun))
251 {
252 register struct buffer *inbuffer = XMARKER (readcharfun)->buffer;
253
254 ptrdiff_t bytepos = marker_byte_position (readcharfun);
255
256 if (bytepos >= BUF_ZV_BYTE (inbuffer))
257 return -1;
258
259 if (! NILP (BVAR (inbuffer, enable_multibyte_characters)))
260 {
261 /* Fetch the character code from the buffer. */
262 unsigned char *p = BUF_BYTE_ADDRESS (inbuffer, bytepos);
263 BUF_INC_POS (inbuffer, bytepos);
264 c = STRING_CHAR (p);
265 if (multibyte)
266 *multibyte = 1;
267 }
268 else
269 {
270 c = BUF_FETCH_BYTE (inbuffer, bytepos);
271 if (! ASCII_CHAR_P (c))
272 c = BYTE8_TO_CHAR (c);
273 bytepos++;
274 }
275
276 XMARKER (readcharfun)->bytepos = bytepos;
277 XMARKER (readcharfun)->charpos++;
278
279 return c;
280 }
281
282 if (EQ (readcharfun, Qlambda))
283 {
284 readbyte = readbyte_for_lambda;
285 goto read_multibyte;
286 }
287
288 if (EQ (readcharfun, Qget_file_char))
289 {
290 eassert (infile);
291 readbyte = readbyte_from_file;
292 goto read_multibyte;
293 }
294
295 if (STRINGP (readcharfun))
296 {
297 if (read_from_string_index >= read_from_string_limit)
298 c = -1;
299 else if (STRING_MULTIBYTE (readcharfun))
300 {
301 if (multibyte)
302 *multibyte = 1;
303 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c, readcharfun,
304 read_from_string_index,
305 read_from_string_index_byte);
306 }
307 else
308 {
309 c = SREF (readcharfun, read_from_string_index_byte);
310 read_from_string_index++;
311 read_from_string_index_byte++;
312 }
313 return c;
314 }
315
316 if (CONSP (readcharfun) && STRINGP (XCAR (readcharfun)))
317 {
318 /* This is the case that read_vector is reading from a unibyte
319 string that contains a byte sequence previously skipped
320 because of #@NUMBER. The car part of readcharfun is that
321 string, and the cdr part is a value of readcharfun given to
322 read_vector. */
323 readbyte = readbyte_from_string;
324 eassert (infile);
325 if (EQ (XCDR (readcharfun), Qget_emacs_mule_file_char))
326 emacs_mule_encoding = 1;
327 goto read_multibyte;
328 }
329
330 if (EQ (readcharfun, Qget_emacs_mule_file_char))
331 {
332 readbyte = readbyte_from_file;
333 eassert (infile);
334 emacs_mule_encoding = 1;
335 goto read_multibyte;
336 }
337
338 tem = call0 (readcharfun);
339
340 if (NILP (tem))
341 return -1;
342 return XFIXNUM (tem);
343
344 read_multibyte:
345 if (unread_char >= 0)
346 {
347 c = unread_char;
348 unread_char = -1;
349 return c;
350 }
351 c = (*readbyte) (-1, readcharfun);
352 if (c < 0)
353 return c;
354 if (multibyte)
355 *multibyte = 1;
356 if (ASCII_CHAR_P (c))
357 return c;
358 if (emacs_mule_encoding)
359 return read_emacs_mule_char (c, readbyte, readcharfun);
360 i = 0;
361 buf[i++] = c;
362 len = BYTES_BY_CHAR_HEAD (c);
363 while (i < len)
364 {
365 buf[i++] = c = (*readbyte) (-1, readcharfun);
366 if (c < 0 || ! TRAILING_CODE_P (c))
367 {
368 for (i -= c < 0; 0 < --i; )
369 (*readbyte) (buf[i], readcharfun);
370 return BYTE8_TO_CHAR (buf[0]);
371 }
372 }
373 return STRING_CHAR (buf);
374 }
375
376 #define FROM_FILE_P(readcharfun) \
377 (EQ (readcharfun, Qget_file_char) \
378 || EQ (readcharfun, Qget_emacs_mule_file_char))
379
380 static void
skip_dyn_bytes(Lisp_Object readcharfun,ptrdiff_t n)381 skip_dyn_bytes (Lisp_Object readcharfun, ptrdiff_t n)
382 {
383 if (FROM_FILE_P (readcharfun))
384 {
385 block_input (); /* FIXME: Not sure if it's needed. */
386 fseek (infile->stream, n - infile->lookahead, SEEK_CUR);
387 unblock_input ();
388 infile->lookahead = 0;
389 }
390 else
391 { /* We're not reading directly from a file. In that case, it's difficult
392 to reliably count bytes, since these are usually meant for the file's
393 encoding, whereas we're now typically in the internal encoding.
394 But luckily, skip_dyn_bytes is used to skip over a single
395 dynamic-docstring (or dynamic byte-code) which is always quoted such
396 that \037 is the final char. */
397 int c;
398 do {
399 c = READCHAR;
400 } while (c >= 0 && c != '\037');
401 }
402 }
403
404 static void
skip_dyn_eof(Lisp_Object readcharfun)405 skip_dyn_eof (Lisp_Object readcharfun)
406 {
407 if (FROM_FILE_P (readcharfun))
408 {
409 block_input (); /* FIXME: Not sure if it's needed. */
410 fseek (infile->stream, 0, SEEK_END);
411 unblock_input ();
412 infile->lookahead = 0;
413 }
414 else
415 while (READCHAR >= 0);
416 }
417
418 /* Unread the character C in the way appropriate for the stream READCHARFUN.
419 If the stream is a user function, call it with the char as argument. */
420
421 static void
unreadchar(Lisp_Object readcharfun,int c)422 unreadchar (Lisp_Object readcharfun, int c)
423 {
424 readchar_count--;
425 if (c == -1)
426 /* Don't back up the pointer if we're unreading the end-of-input mark,
427 since readchar didn't advance it when we read it. */
428 ;
429 else if (BUFFERP (readcharfun))
430 {
431 struct buffer *b = XBUFFER (readcharfun);
432 ptrdiff_t charpos = BUF_PT (b);
433 ptrdiff_t bytepos = BUF_PT_BYTE (b);
434
435 if (! NILP (BVAR (b, enable_multibyte_characters)))
436 BUF_DEC_POS (b, bytepos);
437 else
438 bytepos--;
439
440 SET_BUF_PT_BOTH (b, charpos - 1, bytepos);
441 }
442 else if (MARKERP (readcharfun))
443 {
444 struct buffer *b = XMARKER (readcharfun)->buffer;
445 ptrdiff_t bytepos = XMARKER (readcharfun)->bytepos;
446
447 XMARKER (readcharfun)->charpos--;
448 if (! NILP (BVAR (b, enable_multibyte_characters)))
449 BUF_DEC_POS (b, bytepos);
450 else
451 bytepos--;
452
453 XMARKER (readcharfun)->bytepos = bytepos;
454 }
455 else if (STRINGP (readcharfun))
456 {
457 read_from_string_index--;
458 read_from_string_index_byte
459 = string_char_to_byte (readcharfun, read_from_string_index);
460 }
461 else if (CONSP (readcharfun) && STRINGP (XCAR (readcharfun)))
462 {
463 unread_char = c;
464 }
465 else if (EQ (readcharfun, Qlambda))
466 {
467 unread_char = c;
468 }
469 else if (FROM_FILE_P (readcharfun))
470 {
471 unread_char = c;
472 }
473 else
474 call1 (readcharfun, make_fixnum (c));
475 }
476
477 static int
readbyte_for_lambda(int c,Lisp_Object readcharfun)478 readbyte_for_lambda (int c, Lisp_Object readcharfun)
479 {
480 return read_bytecode_char (c >= 0);
481 }
482
483
484 static int
readbyte_from_stdio(void)485 readbyte_from_stdio (void)
486 {
487 if (infile->lookahead)
488 return infile->buf[--infile->lookahead];
489
490 int c;
491 FILE *instream = infile->stream;
492
493 block_input ();
494
495 /* Interrupted reads have been observed while reading over the network. */
496 while ((c = getc (instream)) == EOF && errno == EINTR && ferror (instream))
497 {
498 unblock_input ();
499 maybe_quit ();
500 block_input ();
501 clearerr (instream);
502 }
503
504 unblock_input ();
505
506 return (c == EOF ? -1 : c);
507 }
508
509 static int
readbyte_from_file(int c,Lisp_Object readcharfun)510 readbyte_from_file (int c, Lisp_Object readcharfun)
511 {
512 eassert (infile);
513 if (c >= 0)
514 {
515 eassert (infile->lookahead < sizeof infile->buf);
516 infile->buf[infile->lookahead++] = c;
517 return 0;
518 }
519
520 return readbyte_from_stdio ();
521 }
522
523 static int
readbyte_from_string(int c,Lisp_Object readcharfun)524 readbyte_from_string (int c, Lisp_Object readcharfun)
525 {
526 Lisp_Object string = XCAR (readcharfun);
527
528 if (c >= 0)
529 {
530 read_from_string_index--;
531 read_from_string_index_byte
532 = string_char_to_byte (string, read_from_string_index);
533 }
534
535 if (read_from_string_index >= read_from_string_limit)
536 c = -1;
537 else
538 FETCH_STRING_CHAR_ADVANCE (c, string,
539 read_from_string_index,
540 read_from_string_index_byte);
541 return c;
542 }
543
544
545 /* Read one non-ASCII character from INFILE. The character is
546 encoded in `emacs-mule' and the first byte is already read in
547 C. */
548
549 static int
read_emacs_mule_char(int c,int (* readbyte)(int,Lisp_Object),Lisp_Object readcharfun)550 read_emacs_mule_char (int c, int (*readbyte) (int, Lisp_Object), Lisp_Object readcharfun)
551 {
552 /* Emacs-mule coding uses at most 4-byte for one character. */
553 unsigned char buf[4];
554 int len = emacs_mule_bytes[c];
555 struct charset *charset;
556 int i;
557 unsigned code;
558
559 if (len == 1)
560 /* C is not a valid leading-code of `emacs-mule'. */
561 return BYTE8_TO_CHAR (c);
562
563 i = 0;
564 buf[i++] = c;
565 while (i < len)
566 {
567 buf[i++] = c = (*readbyte) (-1, readcharfun);
568 if (c < 0xA0)
569 {
570 for (i -= c < 0; 0 < --i; )
571 (*readbyte) (buf[i], readcharfun);
572 return BYTE8_TO_CHAR (buf[0]);
573 }
574 }
575
576 if (len == 2)
577 {
578 charset = CHARSET_FROM_ID (emacs_mule_charset[buf[0]]);
579 code = buf[1] & 0x7F;
580 }
581 else if (len == 3)
582 {
583 if (buf[0] == EMACS_MULE_LEADING_CODE_PRIVATE_11
584 || buf[0] == EMACS_MULE_LEADING_CODE_PRIVATE_12)
585 {
586 charset = CHARSET_FROM_ID (emacs_mule_charset[buf[1]]);
587 code = buf[2] & 0x7F;
588 }
589 else
590 {
591 charset = CHARSET_FROM_ID (emacs_mule_charset[buf[0]]);
592 code = ((buf[1] << 8) | buf[2]) & 0x7F7F;
593 }
594 }
595 else
596 {
597 charset = CHARSET_FROM_ID (emacs_mule_charset[buf[1]]);
598 code = ((buf[2] << 8) | buf[3]) & 0x7F7F;
599 }
600 c = DECODE_CHAR (charset, code);
601 if (c < 0)
602 Fsignal (Qinvalid_read_syntax,
603 list1 (build_string ("invalid multibyte form")));
604 return c;
605 }
606
607
608 /* An in-progress substitution of OBJECT for PLACEHOLDER. */
609 struct subst
610 {
611 Lisp_Object object;
612 Lisp_Object placeholder;
613
614 /* Hash table of subobjects of OBJECT that might be circular. If
615 Qt, all such objects might be circular. */
616 Lisp_Object completed;
617
618 /* List of subobjects of OBJECT that have already been visited. */
619 Lisp_Object seen;
620 };
621
622 static Lisp_Object read_internal_start (Lisp_Object, Lisp_Object,
623 Lisp_Object);
624 static Lisp_Object read0 (Lisp_Object);
625 static Lisp_Object read1 (Lisp_Object, int *, bool);
626
627 static Lisp_Object read_list (bool, Lisp_Object);
628 static Lisp_Object read_vector (Lisp_Object, bool);
629
630 static Lisp_Object substitute_object_recurse (struct subst *, Lisp_Object);
631 static void substitute_in_interval (INTERVAL, void *);
632
633
634 /* Get a character from the tty. */
635
636 /* Read input events until we get one that's acceptable for our purposes.
637
638 If NO_SWITCH_FRAME, switch-frame events are stashed
639 until we get a character we like, and then stuffed into
640 unread_switch_frame.
641
642 If ASCII_REQUIRED, check function key events to see
643 if the unmodified version of the symbol has a Qascii_character
644 property, and use that character, if present.
645
646 If ERROR_NONASCII, signal an error if the input we
647 get isn't an ASCII character with modifiers. If it's false but
648 ASCII_REQUIRED is true, just re-read until we get an ASCII
649 character.
650
651 If INPUT_METHOD, invoke the current input method
652 if the character warrants that.
653
654 If SECONDS is a number, wait that many seconds for input, and
655 return Qnil if no input arrives within that time. */
656
657 static Lisp_Object
read_filtered_event(bool no_switch_frame,bool ascii_required,bool error_nonascii,bool input_method,Lisp_Object seconds)658 read_filtered_event (bool no_switch_frame, bool ascii_required,
659 bool error_nonascii, bool input_method, Lisp_Object seconds)
660 {
661 Lisp_Object val, delayed_switch_frame;
662 struct timespec end_time;
663
664 #ifdef HAVE_WINDOW_SYSTEM
665 if (display_hourglass_p)
666 cancel_hourglass ();
667 #endif
668
669 delayed_switch_frame = Qnil;
670
671 /* Compute timeout. */
672 if (NUMBERP (seconds))
673 {
674 double duration = XFLOATINT (seconds);
675 struct timespec wait_time = dtotimespec (duration);
676 end_time = timespec_add (current_timespec (), wait_time);
677 }
678
679 /* Read until we get an acceptable event. */
680 retry:
681 do
682 val = read_char (0, Qnil, (input_method ? Qnil : Qt), 0,
683 NUMBERP (seconds) ? &end_time : NULL);
684 while (FIXNUMP (val) && XFIXNUM (val) == -2); /* wrong_kboard_jmpbuf */
685
686 if (BUFFERP (val))
687 goto retry;
688
689 /* `switch-frame' events are put off until after the next ASCII
690 character. This is better than signaling an error just because
691 the last characters were typed to a separate minibuffer frame,
692 for example. Eventually, some code which can deal with
693 switch-frame events will read it and process it. */
694 if (no_switch_frame
695 && EVENT_HAS_PARAMETERS (val)
696 && EQ (EVENT_HEAD_KIND (EVENT_HEAD (val)), Qswitch_frame))
697 {
698 delayed_switch_frame = val;
699 goto retry;
700 }
701
702 if (ascii_required && !(NUMBERP (seconds) && NILP (val)))
703 {
704 /* Convert certain symbols to their ASCII equivalents. */
705 if (SYMBOLP (val))
706 {
707 Lisp_Object tem, tem1;
708 tem = Fget (val, Qevent_symbol_element_mask);
709 if (!NILP (tem))
710 {
711 tem1 = Fget (Fcar (tem), Qascii_character);
712 /* Merge this symbol's modifier bits
713 with the ASCII equivalent of its basic code. */
714 if (!NILP (tem1))
715 XSETFASTINT (val, XFIXNUM (tem1) | XFIXNUM (Fcar (Fcdr (tem))));
716 }
717 }
718
719 /* If we don't have a character now, deal with it appropriately. */
720 if (!FIXNUMP (val))
721 {
722 if (error_nonascii)
723 {
724 Vunread_command_events = list1 (val);
725 error ("Non-character input-event");
726 }
727 else
728 goto retry;
729 }
730 }
731
732 if (! NILP (delayed_switch_frame))
733 unread_switch_frame = delayed_switch_frame;
734
735 #if 0
736
737 #ifdef HAVE_WINDOW_SYSTEM
738 if (display_hourglass_p)
739 start_hourglass ();
740 #endif
741
742 #endif
743
744 return val;
745 }
746
747 DEFUN ("read-char", Fread_char, Sread_char, 0, 3, 0,
748 doc: /* Read a character event from the command input (keyboard or macro).
749 It is returned as a number.
750 If the event has modifiers, they are resolved and reflected in the
751 returned character code if possible (e.g. C-SPC yields 0 and C-a yields 97).
752 If some of the modifiers cannot be reflected in the character code, the
753 returned value will include those modifiers, and will not be a valid
754 character code: it will fail the `characterp' test. Use `event-basic-type'
755 to recover the character code with the modifiers removed.
756
757 If the user generates an event which is not a character (i.e. a mouse
758 click or function key event), `read-char' signals an error. As an
759 exception, switch-frame events are put off until non-character events
760 can be read.
761 If you want to read non-character events, or ignore them, call
762 `read-event' or `read-char-exclusive' instead.
763
764 If the optional argument PROMPT is non-nil, display that as a prompt.
765 If PROMPT is nil or the string \"\", the key sequence/events that led
766 to the current command is used as the prompt.
767
768 If the optional argument INHERIT-INPUT-METHOD is non-nil and some
769 input method is turned on in the current buffer, that input method
770 is used for reading a character.
771
772 If the optional argument SECONDS is non-nil, it should be a number
773 specifying the maximum number of seconds to wait for input. If no
774 input arrives in that time, return nil. SECONDS may be a
775 floating-point value. */)
776 (Lisp_Object prompt, Lisp_Object inherit_input_method, Lisp_Object seconds)
777 {
778 Lisp_Object val;
779
780 if (! NILP (prompt))
781 message_with_string ("%s", prompt, 0);
782 val = read_filtered_event (1, 1, 1, ! NILP (inherit_input_method), seconds);
783
784 return (NILP (val) ? Qnil
785 : make_fixnum (char_resolve_modifier_mask (XFIXNUM (val))));
786 }
787
788 DEFUN ("read-event", Fread_event, Sread_event, 0, 3, 0,
789 doc: /* Read an event object from the input stream.
790 If the optional argument PROMPT is non-nil, display that as a prompt.
791 If PROMPT is nil or the string \"\", the key sequence/events that led
792 to the current command is used as the prompt.
793
794 If the optional argument INHERIT-INPUT-METHOD is non-nil and some
795 input method is turned on in the current buffer, that input method
796 is used for reading a character.
797
798 If the optional argument SECONDS is non-nil, it should be a number
799 specifying the maximum number of seconds to wait for input. If no
800 input arrives in that time, return nil. SECONDS may be a
801 floating-point value. */)
802 (Lisp_Object prompt, Lisp_Object inherit_input_method, Lisp_Object seconds)
803 {
804 if (! NILP (prompt))
805 message_with_string ("%s", prompt, 0);
806 return read_filtered_event (0, 0, 0, ! NILP (inherit_input_method), seconds);
807 }
808
809 DEFUN ("read-char-exclusive", Fread_char_exclusive, Sread_char_exclusive, 0, 3, 0,
810 doc: /* Read a character event from the command input (keyboard or macro).
811 It is returned as a number. Non-character events are ignored.
812 If the event has modifiers, they are resolved and reflected in the
813 returned character code if possible (e.g. C-SPC yields 0 and C-a yields 97).
814 If some of the modifiers cannot be reflected in the character code, the
815 returned value will include those modifiers, and will not be a valid
816 character code: it will fail the `characterp' test. Use `event-basic-type'
817 to recover the character code with the modifiers removed.
818
819 If the optional argument PROMPT is non-nil, display that as a prompt.
820 If PROMPT is nil or the string \"\", the key sequence/events that led
821 to the current command is used as the prompt.
822
823 If the optional argument INHERIT-INPUT-METHOD is non-nil and some
824 input method is turned on in the current buffer, that input method
825 is used for reading a character.
826
827 If the optional argument SECONDS is non-nil, it should be a number
828 specifying the maximum number of seconds to wait for input. If no
829 input arrives in that time, return nil. SECONDS may be a
830 floating-point value. */)
831 (Lisp_Object prompt, Lisp_Object inherit_input_method, Lisp_Object seconds)
832 {
833 Lisp_Object val;
834
835 if (! NILP (prompt))
836 message_with_string ("%s", prompt, 0);
837
838 val = read_filtered_event (1, 1, 0, ! NILP (inherit_input_method), seconds);
839
840 return (NILP (val) ? Qnil
841 : make_fixnum (char_resolve_modifier_mask (XFIXNUM (val))));
842 }
843
844 DEFUN ("get-file-char", Fget_file_char, Sget_file_char, 0, 0, 0,
845 doc: /* Don't use this yourself. */)
846 (void)
847 {
848 if (!infile)
849 error ("get-file-char misused");
850 return make_fixnum (readbyte_from_stdio ());
851 }
852
853
854
855
856 /* Return true if the lisp code read using READCHARFUN defines a non-nil
857 `lexical-binding' file variable. After returning, the stream is
858 positioned following the first line, if it is a comment or #! line,
859 otherwise nothing is read. */
860
861 static bool
lisp_file_lexically_bound_p(Lisp_Object readcharfun)862 lisp_file_lexically_bound_p (Lisp_Object readcharfun)
863 {
864 int ch = READCHAR;
865
866 if (ch == '#')
867 {
868 ch = READCHAR;
869 if (ch != '!')
870 {
871 UNREAD (ch);
872 UNREAD ('#');
873 return 0;
874 }
875 while (ch != '\n' && ch != EOF)
876 ch = READCHAR;
877 if (ch == '\n') ch = READCHAR;
878 /* It is OK to leave the position after a #! line, since
879 that is what read1 does. */
880 }
881
882 if (ch != ';')
883 /* The first line isn't a comment, just give up. */
884 {
885 UNREAD (ch);
886 return 0;
887 }
888 else
889 /* Look for an appropriate file-variable in the first line. */
890 {
891 bool rv = 0;
892 enum {
893 NOMINAL, AFTER_FIRST_DASH, AFTER_ASTERIX
894 } beg_end_state = NOMINAL;
895 bool in_file_vars = 0;
896
897 #define UPDATE_BEG_END_STATE(ch) \
898 if (beg_end_state == NOMINAL) \
899 beg_end_state = (ch == '-' ? AFTER_FIRST_DASH : NOMINAL); \
900 else if (beg_end_state == AFTER_FIRST_DASH) \
901 beg_end_state = (ch == '*' ? AFTER_ASTERIX : NOMINAL); \
902 else if (beg_end_state == AFTER_ASTERIX) \
903 { \
904 if (ch == '-') \
905 in_file_vars = !in_file_vars; \
906 beg_end_state = NOMINAL; \
907 }
908
909 /* Skip until we get to the file vars, if any. */
910 do
911 {
912 ch = READCHAR;
913 UPDATE_BEG_END_STATE (ch);
914 }
915 while (!in_file_vars && ch != '\n' && ch != EOF);
916
917 while (in_file_vars)
918 {
919 char var[100], val[100];
920 unsigned i;
921
922 ch = READCHAR;
923
924 /* Read a variable name. */
925 while (ch == ' ' || ch == '\t')
926 ch = READCHAR;
927
928 i = 0;
929 beg_end_state = NOMINAL;
930 while (ch != ':' && ch != '\n' && ch != EOF && in_file_vars)
931 {
932 if (i < sizeof var - 1)
933 var[i++] = ch;
934 UPDATE_BEG_END_STATE (ch);
935 ch = READCHAR;
936 }
937
938 /* Stop scanning if no colon was found before end marker. */
939 if (!in_file_vars || ch == '\n' || ch == EOF)
940 break;
941
942 while (i > 0 && (var[i - 1] == ' ' || var[i - 1] == '\t'))
943 i--;
944 var[i] = '\0';
945
946 if (ch == ':')
947 {
948 /* Read a variable value. */
949 ch = READCHAR;
950
951 while (ch == ' ' || ch == '\t')
952 ch = READCHAR;
953
954 i = 0;
955 beg_end_state = NOMINAL;
956 while (ch != ';' && ch != '\n' && ch != EOF && in_file_vars)
957 {
958 if (i < sizeof val - 1)
959 val[i++] = ch;
960 UPDATE_BEG_END_STATE (ch);
961 ch = READCHAR;
962 }
963 if (! in_file_vars)
964 /* The value was terminated by an end-marker, which remove. */
965 i -= 3;
966 while (i > 0 && (val[i - 1] == ' ' || val[i - 1] == '\t'))
967 i--;
968 val[i] = '\0';
969
970 if (strcmp (var, "lexical-binding") == 0)
971 /* This is it... */
972 {
973 rv = (strcmp (val, "nil") != 0);
974 break;
975 }
976 }
977 }
978
979 while (ch != '\n' && ch != EOF)
980 ch = READCHAR;
981
982 return rv;
983 }
984 }
985
986 /* Value is a version number of byte compiled code if the file
987 associated with file descriptor FD is a compiled Lisp file that's
988 safe to load. Only files compiled with Emacs are safe to load.
989 Files compiled with XEmacs can lead to a crash in Fbyte_code
990 because of an incompatible change in the byte compiler. */
991
992 static int
safe_to_load_version(int fd)993 safe_to_load_version (int fd)
994 {
995 char buf[512];
996 int nbytes, i;
997 int version = 1;
998
999 /* Read the first few bytes from the file, and look for a line
1000 specifying the byte compiler version used. */
1001 nbytes = emacs_read_quit (fd, buf, sizeof buf);
1002 if (nbytes > 0)
1003 {
1004 /* Skip to the next newline, skipping over the initial `ELC'
1005 with NUL bytes following it, but note the version. */
1006 for (i = 0; i < nbytes && buf[i] != '\n'; ++i)
1007 if (i == 4)
1008 version = buf[i];
1009
1010 if (i >= nbytes
1011 || fast_c_string_match_ignore_case (Vbytecomp_version_regexp,
1012 buf + i, nbytes - i) < 0)
1013 version = 0;
1014 }
1015
1016 lseek (fd, 0, SEEK_SET);
1017 return version;
1018 }
1019
1020
1021 /* Callback for record_unwind_protect. Restore the old load list OLD,
1022 after loading a file successfully. */
1023
1024 static void
record_load_unwind(Lisp_Object old)1025 record_load_unwind (Lisp_Object old)
1026 {
1027 Vloads_in_progress = old;
1028 }
1029
1030 /* This handler function is used via internal_condition_case_1. */
1031
1032 static Lisp_Object
load_error_handler(Lisp_Object data)1033 load_error_handler (Lisp_Object data)
1034 {
1035 return Qnil;
1036 }
1037
1038 static AVOID
load_error_old_style_backquotes(void)1039 load_error_old_style_backquotes (void)
1040 {
1041 if (NILP (Vload_file_name))
1042 xsignal1 (Qerror, build_string ("Old-style backquotes detected!"));
1043 else
1044 {
1045 AUTO_STRING (format, "Loading `%s': old-style backquotes detected!");
1046 xsignal1 (Qerror, CALLN (Fformat_message, format, Vload_file_name));
1047 }
1048 }
1049
1050 static void
load_warn_unescaped_character_literals(Lisp_Object file)1051 load_warn_unescaped_character_literals (Lisp_Object file)
1052 {
1053 Lisp_Object warning = call0 (Qbyte_run_unescaped_character_literals_warning);
1054 if (!NILP (warning))
1055 {
1056 AUTO_STRING (format, "Loading `%s': %s");
1057 CALLN (Fmessage, format, file, warning);
1058 }
1059 }
1060
1061 DEFUN ("get-load-suffixes", Fget_load_suffixes, Sget_load_suffixes, 0, 0, 0,
1062 doc: /* Return the suffixes that `load' should try if a suffix is \
1063 required.
1064 This uses the variables `load-suffixes' and `load-file-rep-suffixes'. */)
1065 (void)
1066 {
1067 Lisp_Object lst = Qnil, suffixes = Vload_suffixes;
FOR_EACH_TAIL(suffixes)1068 FOR_EACH_TAIL (suffixes)
1069 {
1070 Lisp_Object exts = Vload_file_rep_suffixes;
1071 Lisp_Object suffix = XCAR (suffixes);
1072 FOR_EACH_TAIL (exts)
1073 lst = Fcons (concat2 (suffix, XCAR (exts)), lst);
1074 }
1075 return Fnreverse (lst);
1076 }
1077
1078 /* Return true if STRING ends with SUFFIX. */
1079 static bool
suffix_p(Lisp_Object string,const char * suffix)1080 suffix_p (Lisp_Object string, const char *suffix)
1081 {
1082 ptrdiff_t suffix_len = strlen (suffix);
1083 ptrdiff_t string_len = SBYTES (string);
1084
1085 return (suffix_len <= string_len
1086 && strcmp (SSDATA (string) + string_len - suffix_len, suffix) == 0);
1087 }
1088
1089 static void
close_infile_unwind(void * arg)1090 close_infile_unwind (void *arg)
1091 {
1092 struct infile *prev_infile = arg;
1093 eassert (infile && infile != prev_infile);
1094 fclose (infile->stream);
1095 infile = prev_infile;
1096 }
1097
1098 DEFUN ("load", Fload, Sload, 1, 5, 0,
1099 doc: /* Execute a file of Lisp code named FILE.
1100 First try FILE with `.elc' appended, then try with `.el', then try
1101 with a system-dependent suffix of dynamic modules (see `load-suffixes'),
1102 then try FILE unmodified (the exact suffixes in the exact order are
1103 determined by `load-suffixes'). Environment variable references in
1104 FILE are replaced with their values by calling `substitute-in-file-name'.
1105 This function searches the directories in `load-path'.
1106
1107 If optional second arg NOERROR is non-nil,
1108 report no error if FILE doesn't exist.
1109 Print messages at start and end of loading unless
1110 optional third arg NOMESSAGE is non-nil (but `force-load-messages'
1111 overrides that).
1112 If optional fourth arg NOSUFFIX is non-nil, don't try adding
1113 suffixes to the specified name FILE.
1114 If optional fifth arg MUST-SUFFIX is non-nil, insist on
1115 the suffix `.elc' or `.el' or the module suffix; don't accept just
1116 FILE unless it ends in one of those suffixes or includes a directory name.
1117
1118 If NOSUFFIX is nil, then if a file could not be found, try looking for
1119 a different representation of the file by adding non-empty suffixes to
1120 its name, before trying another file. Emacs uses this feature to find
1121 compressed versions of files when Auto Compression mode is enabled.
1122 If NOSUFFIX is non-nil, disable this feature.
1123
1124 The suffixes that this function tries out, when NOSUFFIX is nil, are
1125 given by the return value of `get-load-suffixes' and the values listed
1126 in `load-file-rep-suffixes'. If MUST-SUFFIX is non-nil, only the
1127 return value of `get-load-suffixes' is used, i.e. the file name is
1128 required to have a non-empty suffix.
1129
1130 When searching suffixes, this function normally stops at the first
1131 one that exists. If the option `load-prefer-newer' is non-nil,
1132 however, it tries all suffixes, and uses whichever file is the newest.
1133
1134 Loading a file records its definitions, and its `provide' and
1135 `require' calls, in an element of `load-history' whose
1136 car is the file name loaded. See `load-history'.
1137
1138 While the file is in the process of being loaded, the variable
1139 `load-in-progress' is non-nil and the variable `load-file-name'
1140 is bound to the file's name.
1141
1142 Return t if the file exists and loads successfully. */)
1143 (Lisp_Object file, Lisp_Object noerror, Lisp_Object nomessage,
1144 Lisp_Object nosuffix, Lisp_Object must_suffix)
1145 {
1146 FILE *stream UNINIT;
1147 int fd;
1148 int fd_index UNINIT;
1149 ptrdiff_t count = SPECPDL_INDEX ();
1150 Lisp_Object found, efound, hist_file_name;
1151 /* True means we printed the ".el is newer" message. */
1152 bool newer = 0;
1153 /* True means we are loading a compiled file. */
1154 bool compiled = 0;
1155 Lisp_Object handler;
1156 bool safe_p = 1;
1157 const char *fmode = "r" FOPEN_TEXT;
1158 int version;
1159
1160 CHECK_STRING (file);
1161
1162 /* If file name is magic, call the handler. */
1163 /* This shouldn't be necessary any more now that `openp' handles it right.
1164 handler = Ffind_file_name_handler (file, Qload);
1165 if (!NILP (handler))
1166 return call5 (handler, Qload, file, noerror, nomessage, nosuffix); */
1167
1168 /* The presence of this call is the result of a historical accident:
1169 it used to be in every file-operation and when it got removed
1170 everywhere, it accidentally stayed here. Since then, enough people
1171 supposedly have things like (load "$PROJECT/foo.el") in their .emacs
1172 that it seemed risky to remove. */
1173 if (! NILP (noerror))
1174 {
1175 file = internal_condition_case_1 (Fsubstitute_in_file_name, file,
1176 Qt, load_error_handler);
1177 if (NILP (file))
1178 return Qnil;
1179 }
1180 else
1181 file = Fsubstitute_in_file_name (file);
1182
1183 /* Avoid weird lossage with null string as arg,
1184 since it would try to load a directory as a Lisp file. */
1185 if (SCHARS (file) == 0)
1186 {
1187 fd = -1;
1188 errno = ENOENT;
1189 }
1190 else
1191 {
1192 Lisp_Object suffixes;
1193 found = Qnil;
1194
1195 if (! NILP (must_suffix))
1196 {
1197 /* Don't insist on adding a suffix if FILE already ends with one. */
1198 if (suffix_p (file, ".el")
1199 || suffix_p (file, ".elc")
1200 #ifdef HAVE_MODULES
1201 || suffix_p (file, MODULES_SUFFIX)
1202 #endif
1203 )
1204 must_suffix = Qnil;
1205 /* Don't insist on adding a suffix
1206 if the argument includes a directory name. */
1207 else if (! NILP (Ffile_name_directory (file)))
1208 must_suffix = Qnil;
1209 }
1210
1211 if (!NILP (nosuffix))
1212 suffixes = Qnil;
1213 else
1214 {
1215 suffixes = Fget_load_suffixes ();
1216 if (NILP (must_suffix))
1217 suffixes = CALLN (Fappend, suffixes, Vload_file_rep_suffixes);
1218 }
1219
1220 fd = openp (Vload_path, file, suffixes, &found, Qnil, load_prefer_newer);
1221 }
1222
1223 if (fd == -1)
1224 {
1225 if (NILP (noerror))
1226 report_file_error ("Cannot open load file", file);
1227 return Qnil;
1228 }
1229
1230 /* Tell startup.el whether or not we found the user's init file. */
1231 if (EQ (Qt, Vuser_init_file))
1232 Vuser_init_file = found;
1233
1234 /* If FD is -2, that means openp found a magic file. */
1235 if (fd == -2)
1236 {
1237 if (NILP (Fequal (found, file)))
1238 /* If FOUND is a different file name from FILE,
1239 find its handler even if we have already inhibited
1240 the `load' operation on FILE. */
1241 handler = Ffind_file_name_handler (found, Qt);
1242 else
1243 handler = Ffind_file_name_handler (found, Qload);
1244 if (! NILP (handler))
1245 return call5 (handler, Qload, found, noerror, nomessage, Qt);
1246 #ifdef DOS_NT
1247 /* Tramp has to deal with semi-broken packages that prepend
1248 drive letters to remote files. For that reason, Tramp
1249 catches file operations that test for file existence, which
1250 makes openp think X:/foo.elc files are remote. However,
1251 Tramp does not catch `load' operations for such files, so we
1252 end up with a nil as the `load' handler above. If we would
1253 continue with fd = -2, we will behave wrongly, and in
1254 particular try reading a .elc file in the "rt" mode instead
1255 of "rb". See bug #9311 for the results. To work around
1256 this, we try to open the file locally, and go with that if it
1257 succeeds. */
1258 fd = emacs_open (SSDATA (ENCODE_FILE (found)), O_RDONLY, 0);
1259 if (fd == -1)
1260 fd = -2;
1261 #endif
1262 }
1263
1264 if (0 <= fd)
1265 {
1266 fd_index = SPECPDL_INDEX ();
1267 record_unwind_protect_int (close_file_unwind, fd);
1268 }
1269
1270 #ifdef HAVE_MODULES
1271 bool is_module = suffix_p (found, MODULES_SUFFIX);
1272 #else
1273 bool is_module = false;
1274 #endif
1275
1276 /* Check if we're stuck in a recursive load cycle.
1277
1278 2000-09-21: It's not possible to just check for the file loaded
1279 being a member of Vloads_in_progress. This fails because of the
1280 way the byte compiler currently works; `provide's are not
1281 evaluated, see font-lock.el/jit-lock.el as an example. This
1282 leads to a certain amount of ``normal'' recursion.
1283
1284 Also, just loading a file recursively is not always an error in
1285 the general case; the second load may do something different. */
1286 {
1287 int load_count = 0;
1288 Lisp_Object tem = Vloads_in_progress;
1289 FOR_EACH_TAIL_SAFE (tem)
1290 if (!NILP (Fequal (found, XCAR (tem))) && (++load_count > 3))
1291 signal_error ("Recursive load", Fcons (found, Vloads_in_progress));
1292 record_unwind_protect (record_load_unwind, Vloads_in_progress);
1293 Vloads_in_progress = Fcons (found, Vloads_in_progress);
1294 }
1295
1296 /* All loads are by default dynamic, unless the file itself specifies
1297 otherwise using a file-variable in the first line. This is bound here
1298 so that it takes effect whether or not we use
1299 Vload_source_file_function. */
1300 specbind (Qlexical_binding, Qnil);
1301
1302 /* Get the name for load-history. */
1303 hist_file_name = (! NILP (Vpurify_flag)
1304 ? concat2 (Ffile_name_directory (file),
1305 Ffile_name_nondirectory (found))
1306 : found) ;
1307
1308 version = -1;
1309
1310 /* Check for the presence of unescaped character literals and warn
1311 about them. */
1312 specbind (Qlread_unescaped_character_literals, Qnil);
1313 record_unwind_protect (load_warn_unescaped_character_literals, file);
1314
1315 bool is_elc = suffix_p (found, ".elc");
1316 if (is_elc
1317 /* version = 1 means the file is empty, in which case we can
1318 treat it as not byte-compiled. */
1319 || (fd >= 0 && (version = safe_to_load_version (fd)) > 1))
1320 /* Load .elc files directly, but not when they are
1321 remote and have no handler! */
1322 {
1323 if (fd != -2)
1324 {
1325 struct stat s1, s2;
1326 int result;
1327
1328 if (version < 0
1329 && ! (version = safe_to_load_version (fd)))
1330 {
1331 safe_p = 0;
1332 if (!load_dangerous_libraries)
1333 error ("File `%s' was not compiled in Emacs", SDATA (found));
1334 else if (!NILP (nomessage) && !force_load_messages)
1335 message_with_string ("File `%s' not compiled in Emacs", found, 1);
1336 }
1337
1338 compiled = 1;
1339
1340 efound = ENCODE_FILE (found);
1341 fmode = "r" FOPEN_BINARY;
1342
1343 /* openp already checked for newness, no point doing it again.
1344 FIXME would be nice to get a message when openp
1345 ignores suffix order due to load_prefer_newer. */
1346 if (!load_prefer_newer && is_elc)
1347 {
1348 result = stat (SSDATA (efound), &s1);
1349 if (result == 0)
1350 {
1351 SSET (efound, SBYTES (efound) - 1, 0);
1352 result = stat (SSDATA (efound), &s2);
1353 SSET (efound, SBYTES (efound) - 1, 'c');
1354 }
1355
1356 if (result == 0
1357 && timespec_cmp (get_stat_mtime (&s1), get_stat_mtime (&s2)) < 0)
1358 {
1359 /* Make the progress messages mention that source is newer. */
1360 newer = 1;
1361
1362 /* If we won't print another message, mention this anyway. */
1363 if (!NILP (nomessage) && !force_load_messages)
1364 {
1365 Lisp_Object msg_file;
1366 msg_file = Fsubstring (found, make_fixnum (0), make_fixnum (-1));
1367 message_with_string ("Source file `%s' newer than byte-compiled file; using older file",
1368 msg_file, 1);
1369 }
1370 }
1371 } /* !load_prefer_newer */
1372 }
1373 }
1374 else if (!is_module)
1375 {
1376 /* We are loading a source file (*.el). */
1377 if (!NILP (Vload_source_file_function))
1378 {
1379 Lisp_Object val;
1380
1381 if (fd >= 0)
1382 {
1383 emacs_close (fd);
1384 clear_unwind_protect (fd_index);
1385 }
1386 val = call4 (Vload_source_file_function, found, hist_file_name,
1387 NILP (noerror) ? Qnil : Qt,
1388 (NILP (nomessage) || force_load_messages) ? Qnil : Qt);
1389 return unbind_to (count, val);
1390 }
1391 }
1392
1393 if (fd < 0)
1394 {
1395 /* We somehow got here with fd == -2, meaning the file is deemed
1396 to be remote. Don't even try to reopen the file locally;
1397 just force a failure. */
1398 stream = NULL;
1399 errno = EINVAL;
1400 }
1401 else if (!is_module)
1402 {
1403 #ifdef WINDOWSNT
1404 emacs_close (fd);
1405 clear_unwind_protect (fd_index);
1406 efound = ENCODE_FILE (found);
1407 stream = emacs_fopen (SSDATA (efound), fmode);
1408 #else
1409 stream = fdopen (fd, fmode);
1410 #endif
1411 }
1412
1413 /* Declare here rather than inside the else-part because the storage
1414 might be accessed by the unbind_to call below. */
1415 struct infile input;
1416
1417 if (is_module)
1418 {
1419 /* `module-load' uses the file name, so we can close the stream
1420 now. */
1421 if (fd >= 0)
1422 {
1423 emacs_close (fd);
1424 clear_unwind_protect (fd_index);
1425 }
1426 }
1427 else
1428 {
1429 if (! stream)
1430 report_file_error ("Opening stdio stream", file);
1431 set_unwind_protect_ptr (fd_index, close_infile_unwind, infile);
1432 input.stream = stream;
1433 input.lookahead = 0;
1434 infile = &input;
1435 }
1436
1437 if (! NILP (Vpurify_flag))
1438 Vpreloaded_file_list = Fcons (Fpurecopy (file), Vpreloaded_file_list);
1439
1440 if (NILP (nomessage) || force_load_messages)
1441 {
1442 if (!safe_p)
1443 message_with_string ("Loading %s (compiled; note unsafe, not compiled in Emacs)...",
1444 file, 1);
1445 else if (is_module)
1446 message_with_string ("Loading %s (module)...", file, 1);
1447 else if (!compiled)
1448 message_with_string ("Loading %s (source)...", file, 1);
1449 else if (newer)
1450 message_with_string ("Loading %s (compiled; note, source file is newer)...",
1451 file, 1);
1452 else /* The typical case; compiled file newer than source file. */
1453 message_with_string ("Loading %s...", file, 1);
1454 }
1455
1456 specbind (Qload_file_name, found);
1457 specbind (Qinhibit_file_name_operation, Qnil);
1458 specbind (Qload_in_progress, Qt);
1459
1460 if (is_module)
1461 {
1462 #ifdef HAVE_MODULES
1463 specbind (Qcurrent_load_list, Qnil);
1464 LOADHIST_ATTACH (found);
1465 Fmodule_load (found);
1466 build_load_history (found, true);
1467 #else
1468 /* This cannot happen. */
1469 emacs_abort ();
1470 #endif
1471 }
1472 else
1473 {
1474 if (lisp_file_lexically_bound_p (Qget_file_char))
1475 Fset (Qlexical_binding, Qt);
1476
1477 if (! version || version >= 22)
1478 readevalloop (Qget_file_char, &input, hist_file_name,
1479 0, Qnil, Qnil, Qnil, Qnil);
1480 else
1481 {
1482 /* We can't handle a file which was compiled with
1483 byte-compile-dynamic by older version of Emacs. */
1484 specbind (Qload_force_doc_strings, Qt);
1485 readevalloop (Qget_emacs_mule_file_char, &input, hist_file_name,
1486 0, Qnil, Qnil, Qnil, Qnil);
1487 }
1488 }
1489 unbind_to (count, Qnil);
1490
1491 /* Run any eval-after-load forms for this file. */
1492 if (!NILP (Ffboundp (Qdo_after_load_evaluation)))
1493 call1 (Qdo_after_load_evaluation, hist_file_name) ;
1494
1495 xfree (saved_doc_string);
1496 saved_doc_string = 0;
1497 saved_doc_string_size = 0;
1498
1499 xfree (prev_saved_doc_string);
1500 prev_saved_doc_string = 0;
1501 prev_saved_doc_string_size = 0;
1502
1503 if (!noninteractive && (NILP (nomessage) || force_load_messages))
1504 {
1505 if (!safe_p)
1506 message_with_string ("Loading %s (compiled; note unsafe, not compiled in Emacs)...done",
1507 file, 1);
1508 else if (is_module)
1509 message_with_string ("Loading %s (module)...done", file, 1);
1510 else if (!compiled)
1511 message_with_string ("Loading %s (source)...done", file, 1);
1512 else if (newer)
1513 message_with_string ("Loading %s (compiled; note, source file is newer)...done",
1514 file, 1);
1515 else /* The typical case; compiled file newer than source file. */
1516 message_with_string ("Loading %s...done", file, 1);
1517 }
1518
1519 return Qt;
1520 }
1521
1522 Lisp_Object
save_match_data_load(Lisp_Object file,Lisp_Object noerror,Lisp_Object nomessage,Lisp_Object nosuffix,Lisp_Object must_suffix)1523 save_match_data_load (Lisp_Object file, Lisp_Object noerror,
1524 Lisp_Object nomessage, Lisp_Object nosuffix,
1525 Lisp_Object must_suffix)
1526 {
1527 ptrdiff_t count = SPECPDL_INDEX ();
1528 record_unwind_save_match_data ();
1529 Lisp_Object result = Fload (file, noerror, nomessage, nosuffix, must_suffix);
1530 return unbind_to (count, result);
1531 }
1532
1533 static bool
complete_filename_p(Lisp_Object pathname)1534 complete_filename_p (Lisp_Object pathname)
1535 {
1536 const unsigned char *s = SDATA (pathname);
1537 return (IS_DIRECTORY_SEP (s[0])
1538 || (SCHARS (pathname) > 2
1539 && IS_DEVICE_SEP (s[1]) && IS_DIRECTORY_SEP (s[2])));
1540 }
1541
1542 DEFUN ("locate-file-internal", Flocate_file_internal, Slocate_file_internal, 2, 4, 0,
1543 doc: /* Search for FILENAME through PATH.
1544 Returns the file's name in absolute form, or nil if not found.
1545 If SUFFIXES is non-nil, it should be a list of suffixes to append to
1546 file name when searching.
1547 If non-nil, PREDICATE is used instead of `file-readable-p'.
1548 PREDICATE can also be an integer to pass to the faccessat(2) function,
1549 in which case file-name-handlers are ignored.
1550 This function will normally skip directories, so if you want it to find
1551 directories, make sure the PREDICATE function returns `dir-ok' for them. */)
1552 (Lisp_Object filename, Lisp_Object path, Lisp_Object suffixes, Lisp_Object predicate)
1553 {
1554 Lisp_Object file;
1555 int fd = openp (path, filename, suffixes, &file, predicate, false);
1556 if (NILP (predicate) && fd >= 0)
1557 emacs_close (fd);
1558 return file;
1559 }
1560
1561 /* Search for a file whose name is STR, looking in directories
1562 in the Lisp list PATH, and trying suffixes from SUFFIX.
1563 On success, return a file descriptor (or 1 or -2 as described below).
1564 On failure, return -1 and set errno.
1565
1566 SUFFIXES is a list of strings containing possible suffixes.
1567 The empty suffix is automatically added if the list is empty.
1568
1569 PREDICATE t means the files are binary.
1570 PREDICATE non-nil and non-t means don't open the files,
1571 just look for one that satisfies the predicate. In this case,
1572 return -2 on success. The predicate can be a lisp function or
1573 an integer to pass to `access' (in which case file-name-handlers
1574 are ignored).
1575
1576 If STOREPTR is nonzero, it points to a slot where the name of
1577 the file actually found should be stored as a Lisp string.
1578 nil is stored there on failure.
1579
1580 If the file we find is remote, return -2
1581 but store the found remote file name in *STOREPTR.
1582
1583 If NEWER is true, try all SUFFIXes and return the result for the
1584 newest file that exists. Does not apply to remote files,
1585 or if a non-nil and non-t PREDICATE is specified. */
1586
1587 int
openp(Lisp_Object path,Lisp_Object str,Lisp_Object suffixes,Lisp_Object * storeptr,Lisp_Object predicate,bool newer)1588 openp (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes,
1589 Lisp_Object *storeptr, Lisp_Object predicate, bool newer)
1590 {
1591 ptrdiff_t fn_size = 100;
1592 char buf[100];
1593 char *fn = buf;
1594 bool absolute;
1595 ptrdiff_t want_length;
1596 Lisp_Object filename;
1597 Lisp_Object string, tail, encoded_fn, save_string;
1598 ptrdiff_t max_suffix_len = 0;
1599 int last_errno = ENOENT;
1600 int save_fd = -1;
1601 USE_SAFE_ALLOCA;
1602
1603 /* The last-modified time of the newest matching file found.
1604 Initialize it to something less than all valid timestamps. */
1605 struct timespec save_mtime = make_timespec (TYPE_MINIMUM (time_t), -1);
1606
1607 CHECK_STRING (str);
1608
1609 tail = suffixes;
1610 FOR_EACH_TAIL_SAFE (tail)
1611 {
1612 CHECK_STRING_CAR (tail);
1613 max_suffix_len = max (max_suffix_len,
1614 SBYTES (XCAR (tail)));
1615 }
1616
1617 string = filename = encoded_fn = save_string = Qnil;
1618
1619 if (storeptr)
1620 *storeptr = Qnil;
1621
1622 absolute = complete_filename_p (str);
1623
1624 AUTO_LIST1 (just_use_str, Qnil);
1625 if (NILP (path))
1626 path = just_use_str;
1627
1628 /* Go through all entries in the path and see whether we find the
1629 executable. */
1630 FOR_EACH_TAIL_SAFE (path)
1631 {
1632 ptrdiff_t baselen, prefixlen;
1633
1634 if (EQ (path, just_use_str))
1635 filename = str;
1636 else
1637 filename = Fexpand_file_name (str, XCAR (path));
1638 if (!complete_filename_p (filename))
1639 /* If there are non-absolute elts in PATH (eg "."). */
1640 /* Of course, this could conceivably lose if luser sets
1641 default-directory to be something non-absolute... */
1642 {
1643 filename = Fexpand_file_name (filename, BVAR (current_buffer, directory));
1644 if (!complete_filename_p (filename))
1645 /* Give up on this path element! */
1646 continue;
1647 }
1648
1649 /* Calculate maximum length of any filename made from
1650 this path element/specified file name and any possible suffix. */
1651 want_length = max_suffix_len + SBYTES (filename);
1652 if (fn_size <= want_length)
1653 {
1654 fn_size = 100 + want_length;
1655 fn = SAFE_ALLOCA (fn_size);
1656 }
1657
1658 /* Copy FILENAME's data to FN but remove starting /: if any. */
1659 prefixlen = ((SCHARS (filename) > 2
1660 && SREF (filename, 0) == '/'
1661 && SREF (filename, 1) == ':')
1662 ? 2 : 0);
1663 baselen = SBYTES (filename) - prefixlen;
1664 memcpy (fn, SDATA (filename) + prefixlen, baselen);
1665
1666 /* Loop over suffixes. */
1667 AUTO_LIST1 (empty_string_only, empty_unibyte_string);
1668 tail = NILP (suffixes) ? empty_string_only : suffixes;
1669 FOR_EACH_TAIL_SAFE (tail)
1670 {
1671 Lisp_Object suffix = XCAR (tail);
1672 ptrdiff_t fnlen, lsuffix = SBYTES (suffix);
1673 Lisp_Object handler;
1674
1675 /* Make complete filename by appending SUFFIX. */
1676 memcpy (fn + baselen, SDATA (suffix), lsuffix + 1);
1677 fnlen = baselen + lsuffix;
1678
1679 /* Check that the file exists and is not a directory. */
1680 /* We used to only check for handlers on non-absolute file names:
1681 if (absolute)
1682 handler = Qnil;
1683 else
1684 handler = Ffind_file_name_handler (filename, Qfile_exists_p);
1685 It's not clear why that was the case and it breaks things like
1686 (load "/bar.el") where the file is actually "/bar.el.gz". */
1687 /* make_string has its own ideas on when to return a unibyte
1688 string and when a multibyte string, but we know better.
1689 We must have a unibyte string when dumping, since
1690 file-name encoding is shaky at best at that time, and in
1691 particular default-file-name-coding-system is reset
1692 several times during loadup. We therefore don't want to
1693 encode the file before passing it to file I/O library
1694 functions. */
1695 if (!STRING_MULTIBYTE (filename) && !STRING_MULTIBYTE (suffix))
1696 string = make_unibyte_string (fn, fnlen);
1697 else
1698 string = make_string (fn, fnlen);
1699 handler = Ffind_file_name_handler (string, Qfile_exists_p);
1700 if ((!NILP (handler) || (!NILP (predicate) && !EQ (predicate, Qt)))
1701 && !FIXNATP (predicate))
1702 {
1703 bool exists;
1704 if (NILP (predicate) || EQ (predicate, Qt))
1705 exists = !NILP (Ffile_readable_p (string));
1706 else
1707 {
1708 Lisp_Object tmp = call1 (predicate, string);
1709 if (NILP (tmp))
1710 exists = false;
1711 else if (EQ (tmp, Qdir_ok)
1712 || NILP (Ffile_directory_p (string)))
1713 exists = true;
1714 else
1715 {
1716 exists = false;
1717 last_errno = EISDIR;
1718 }
1719 }
1720
1721 if (exists)
1722 {
1723 /* We succeeded; return this descriptor and filename. */
1724 if (storeptr)
1725 *storeptr = string;
1726 SAFE_FREE ();
1727 return -2;
1728 }
1729 }
1730 else
1731 {
1732 int fd;
1733 const char *pfn;
1734 struct stat st;
1735
1736 encoded_fn = ENCODE_FILE (string);
1737 pfn = SSDATA (encoded_fn);
1738
1739 /* Check that we can access or open it. */
1740 if (FIXNATP (predicate))
1741 {
1742 fd = -1;
1743 if (INT_MAX < XFIXNAT (predicate))
1744 last_errno = EINVAL;
1745 else if (faccessat (AT_FDCWD, pfn, XFIXNAT (predicate),
1746 AT_EACCESS)
1747 == 0)
1748 {
1749 if (file_directory_p (encoded_fn))
1750 last_errno = EISDIR;
1751 else if (errno == ENOENT || errno == ENOTDIR)
1752 fd = 1;
1753 else
1754 last_errno = errno;
1755 }
1756 else if (! (errno == ENOENT || errno == ENOTDIR))
1757 last_errno = errno;
1758 }
1759 else
1760 {
1761 fd = emacs_open (pfn, O_RDONLY, 0);
1762 if (fd < 0)
1763 {
1764 if (! (errno == ENOENT || errno == ENOTDIR))
1765 last_errno = errno;
1766 }
1767 else
1768 {
1769 int err = (fstat (fd, &st) != 0 ? errno
1770 : S_ISDIR (st.st_mode) ? EISDIR : 0);
1771 if (err)
1772 {
1773 last_errno = err;
1774 emacs_close (fd);
1775 fd = -1;
1776 }
1777 }
1778 }
1779
1780 if (fd >= 0)
1781 {
1782 if (newer && !FIXNATP (predicate))
1783 {
1784 struct timespec mtime = get_stat_mtime (&st);
1785
1786 if (timespec_cmp (mtime, save_mtime) <= 0)
1787 emacs_close (fd);
1788 else
1789 {
1790 if (0 <= save_fd)
1791 emacs_close (save_fd);
1792 save_fd = fd;
1793 save_mtime = mtime;
1794 save_string = string;
1795 }
1796 }
1797 else
1798 {
1799 /* We succeeded; return this descriptor and filename. */
1800 if (storeptr)
1801 *storeptr = string;
1802 SAFE_FREE ();
1803 return fd;
1804 }
1805 }
1806
1807 /* No more suffixes. Return the newest. */
1808 if (0 <= save_fd && ! CONSP (XCDR (tail)))
1809 {
1810 if (storeptr)
1811 *storeptr = save_string;
1812 SAFE_FREE ();
1813 return save_fd;
1814 }
1815 }
1816 }
1817 if (absolute)
1818 break;
1819 }
1820
1821 SAFE_FREE ();
1822 errno = last_errno;
1823 return -1;
1824 }
1825
1826
1827 /* Merge the list we've accumulated of globals from the current input source
1828 into the load_history variable. The details depend on whether
1829 the source has an associated file name or not.
1830
1831 FILENAME is the file name that we are loading from.
1832
1833 ENTIRE is true if loading that entire file, false if evaluating
1834 part of it. */
1835
1836 static void
build_load_history(Lisp_Object filename,bool entire)1837 build_load_history (Lisp_Object filename, bool entire)
1838 {
1839 Lisp_Object tail, prev, newelt;
1840 Lisp_Object tem, tem2;
1841 bool foundit = 0;
1842
1843 tail = Vload_history;
1844 prev = Qnil;
1845
1846 FOR_EACH_TAIL (tail)
1847 {
1848 tem = XCAR (tail);
1849
1850 /* Find the feature's previous assoc list... */
1851 if (!NILP (Fequal (filename, Fcar (tem))))
1852 {
1853 foundit = 1;
1854
1855 /* If we're loading the entire file, remove old data. */
1856 if (entire)
1857 {
1858 if (NILP (prev))
1859 Vload_history = XCDR (tail);
1860 else
1861 Fsetcdr (prev, XCDR (tail));
1862 }
1863
1864 /* Otherwise, cons on new symbols that are not already members. */
1865 else
1866 {
1867 tem2 = Vcurrent_load_list;
1868
1869 FOR_EACH_TAIL (tem2)
1870 {
1871 newelt = XCAR (tem2);
1872
1873 if (NILP (Fmember (newelt, tem)))
1874 Fsetcar (tail, Fcons (XCAR (tem),
1875 Fcons (newelt, XCDR (tem))));
1876 maybe_quit ();
1877 }
1878 }
1879 }
1880 else
1881 prev = tail;
1882 maybe_quit ();
1883 }
1884
1885 /* If we're loading an entire file, cons the new assoc onto the
1886 front of load-history, the most-recently-loaded position. Also
1887 do this if we didn't find an existing member for the file. */
1888 if (entire || !foundit)
1889 Vload_history = Fcons (Fnreverse (Vcurrent_load_list),
1890 Vload_history);
1891 }
1892
1893 static void
readevalloop_1(int old)1894 readevalloop_1 (int old)
1895 {
1896 load_convert_to_unibyte = old;
1897 }
1898
1899 /* Signal an `end-of-file' error, if possible with file name
1900 information. */
1901
1902 static AVOID
end_of_file_error(void)1903 end_of_file_error (void)
1904 {
1905 if (STRINGP (Vload_file_name))
1906 xsignal1 (Qend_of_file, Vload_file_name);
1907
1908 xsignal0 (Qend_of_file);
1909 }
1910
1911 static Lisp_Object
readevalloop_eager_expand_eval(Lisp_Object val,Lisp_Object macroexpand)1912 readevalloop_eager_expand_eval (Lisp_Object val, Lisp_Object macroexpand)
1913 {
1914 /* If we macroexpand the toplevel form non-recursively and it ends
1915 up being a `progn' (or if it was a progn to start), treat each
1916 form in the progn as a top-level form. This way, if one form in
1917 the progn defines a macro, that macro is in effect when we expand
1918 the remaining forms. See similar code in bytecomp.el. */
1919 val = call2 (macroexpand, val, Qnil);
1920 if (EQ (CAR_SAFE (val), Qprogn))
1921 {
1922 Lisp_Object subforms = XCDR (val);
1923 val = Qnil;
1924 FOR_EACH_TAIL (subforms)
1925 val = readevalloop_eager_expand_eval (XCAR (subforms), macroexpand);
1926 }
1927 else
1928 val = eval_sub (call2 (macroexpand, val, Qt));
1929 return val;
1930 }
1931
1932 /* UNIBYTE specifies how to set load_convert_to_unibyte
1933 for this invocation.
1934 READFUN, if non-nil, is used instead of `read'.
1935
1936 START, END specify region to read in current buffer (from eval-region).
1937 If the input is not from a buffer, they must be nil. */
1938
1939 static void
readevalloop(Lisp_Object readcharfun,struct infile * infile0,Lisp_Object sourcename,bool printflag,Lisp_Object unibyte,Lisp_Object readfun,Lisp_Object start,Lisp_Object end)1940 readevalloop (Lisp_Object readcharfun,
1941 struct infile *infile0,
1942 Lisp_Object sourcename,
1943 bool printflag,
1944 Lisp_Object unibyte, Lisp_Object readfun,
1945 Lisp_Object start, Lisp_Object end)
1946 {
1947 int c;
1948 Lisp_Object val;
1949 ptrdiff_t count = SPECPDL_INDEX ();
1950 struct buffer *b = 0;
1951 bool continue_reading_p;
1952 Lisp_Object lex_bound;
1953 /* True if reading an entire buffer. */
1954 bool whole_buffer = 0;
1955 /* True on the first time around. */
1956 bool first_sexp = 1;
1957 Lisp_Object macroexpand = intern ("internal-macroexpand-for-load");
1958
1959 if (NILP (Ffboundp (macroexpand))
1960 || (STRINGP (sourcename) && suffix_p (sourcename, ".elc")))
1961 /* Don't macroexpand before the corresponding function is defined
1962 and don't bother macroexpanding in .elc files, since it should have
1963 been done already. */
1964 macroexpand = Qnil;
1965
1966 if (MARKERP (readcharfun))
1967 {
1968 if (NILP (start))
1969 start = readcharfun;
1970 }
1971
1972 if (BUFFERP (readcharfun))
1973 b = XBUFFER (readcharfun);
1974 else if (MARKERP (readcharfun))
1975 b = XMARKER (readcharfun)->buffer;
1976
1977 /* We assume START is nil when input is not from a buffer. */
1978 if (! NILP (start) && !b)
1979 emacs_abort ();
1980
1981 specbind (Qstandard_input, readcharfun);
1982 specbind (Qcurrent_load_list, Qnil);
1983 record_unwind_protect_int (readevalloop_1, load_convert_to_unibyte);
1984 load_convert_to_unibyte = !NILP (unibyte);
1985
1986 /* If lexical binding is active (either because it was specified in
1987 the file's header, or via a buffer-local variable), create an empty
1988 lexical environment, otherwise, turn off lexical binding. */
1989 lex_bound = find_symbol_value (Qlexical_binding);
1990 specbind (Qinternal_interpreter_environment,
1991 (NILP (lex_bound) || EQ (lex_bound, Qunbound)
1992 ? Qnil : list1 (Qt)));
1993
1994 /* Ensure sourcename is absolute, except whilst preloading. */
1995 if (!will_dump_p ()
1996 && !NILP (sourcename) && !NILP (Ffile_name_absolute_p (sourcename)))
1997 sourcename = Fexpand_file_name (sourcename, Qnil);
1998
1999 LOADHIST_ATTACH (sourcename);
2000
2001 continue_reading_p = 1;
2002 while (continue_reading_p)
2003 {
2004 ptrdiff_t count1 = SPECPDL_INDEX ();
2005
2006 if (b != 0 && !BUFFER_LIVE_P (b))
2007 error ("Reading from killed buffer");
2008
2009 if (!NILP (start))
2010 {
2011 /* Switch to the buffer we are reading from. */
2012 record_unwind_protect_excursion ();
2013 set_buffer_internal (b);
2014
2015 /* Save point in it. */
2016 record_unwind_protect_excursion ();
2017 /* Save ZV in it. */
2018 record_unwind_protect (save_restriction_restore, save_restriction_save ());
2019 /* Those get unbound after we read one expression. */
2020
2021 /* Set point and ZV around stuff to be read. */
2022 Fgoto_char (start);
2023 if (!NILP (end))
2024 Fnarrow_to_region (make_fixnum (BEGV), end);
2025
2026 /* Just for cleanliness, convert END to a marker
2027 if it is an integer. */
2028 if (FIXNUMP (end))
2029 end = Fpoint_max_marker ();
2030 }
2031
2032 /* On the first cycle, we can easily test here
2033 whether we are reading the whole buffer. */
2034 if (b && first_sexp)
2035 whole_buffer = (BUF_PT (b) == BUF_BEG (b) && BUF_ZV (b) == BUF_Z (b));
2036
2037 eassert (!infile0 || infile == infile0);
2038 read_next:
2039 c = READCHAR;
2040 if (c == ';')
2041 {
2042 while ((c = READCHAR) != '\n' && c != -1);
2043 goto read_next;
2044 }
2045 if (c < 0)
2046 {
2047 unbind_to (count1, Qnil);
2048 break;
2049 }
2050
2051 /* Ignore whitespace here, so we can detect eof. */
2052 if (c == ' ' || c == '\t' || c == '\n' || c == '\f' || c == '\r'
2053 || c == NO_BREAK_SPACE)
2054 goto read_next;
2055
2056 if (! HASH_TABLE_P (read_objects_map)
2057 || XHASH_TABLE (read_objects_map)->count)
2058 read_objects_map
2059 = make_hash_table (hashtest_eq, DEFAULT_HASH_SIZE,
2060 DEFAULT_REHASH_SIZE, DEFAULT_REHASH_THRESHOLD,
2061 Qnil, false);
2062 if (! HASH_TABLE_P (read_objects_completed)
2063 || XHASH_TABLE (read_objects_completed)->count)
2064 read_objects_completed
2065 = make_hash_table (hashtest_eq, DEFAULT_HASH_SIZE,
2066 DEFAULT_REHASH_SIZE, DEFAULT_REHASH_THRESHOLD,
2067 Qnil, false);
2068 if (!NILP (Vpurify_flag) && c == '(')
2069 {
2070 val = read_list (0, readcharfun);
2071 }
2072 else
2073 {
2074 UNREAD (c);
2075 if (!NILP (readfun))
2076 {
2077 val = call1 (readfun, readcharfun);
2078
2079 /* If READCHARFUN has set point to ZV, we should
2080 stop reading, even if the form read sets point
2081 to a different value when evaluated. */
2082 if (BUFFERP (readcharfun))
2083 {
2084 struct buffer *buf = XBUFFER (readcharfun);
2085 if (BUF_PT (buf) == BUF_ZV (buf))
2086 continue_reading_p = 0;
2087 }
2088 }
2089 else if (! NILP (Vload_read_function))
2090 val = call1 (Vload_read_function, readcharfun);
2091 else
2092 val = read_internal_start (readcharfun, Qnil, Qnil);
2093 }
2094 /* Empty hashes can be reused; otherwise, reset on next call. */
2095 if (HASH_TABLE_P (read_objects_map)
2096 && XHASH_TABLE (read_objects_map)->count > 0)
2097 read_objects_map = Qnil;
2098 if (HASH_TABLE_P (read_objects_completed)
2099 && XHASH_TABLE (read_objects_completed)->count > 0)
2100 read_objects_completed = Qnil;
2101
2102 if (!NILP (start) && continue_reading_p)
2103 start = Fpoint_marker ();
2104
2105 /* Restore saved point and BEGV. */
2106 unbind_to (count1, Qnil);
2107
2108 /* Now eval what we just read. */
2109 if (!NILP (macroexpand))
2110 val = readevalloop_eager_expand_eval (val, macroexpand);
2111 else
2112 val = eval_sub (val);
2113
2114 if (printflag)
2115 {
2116 Vvalues = Fcons (val, Vvalues);
2117 if (EQ (Vstandard_output, Qt))
2118 Fprin1 (val, Qnil);
2119 else
2120 Fprint (val, Qnil);
2121 }
2122
2123 first_sexp = 0;
2124 }
2125
2126 build_load_history (sourcename,
2127 infile0 || whole_buffer);
2128
2129 unbind_to (count, Qnil);
2130 }
2131
2132 DEFUN ("eval-buffer", Feval_buffer, Seval_buffer, 0, 5, "",
2133 doc: /* Execute the accessible portion of current buffer as Lisp code.
2134 You can use \\[narrow-to-region] to limit the part of buffer to be evaluated.
2135 When called from a Lisp program (i.e., not interactively), this
2136 function accepts up to five optional arguments:
2137 BUFFER is the buffer to evaluate (nil means use current buffer),
2138 or a name of a buffer (a string).
2139 PRINTFLAG controls printing of output by any output functions in the
2140 evaluated code, such as `print', `princ', and `prin1':
2141 a value of nil means discard it; anything else is the stream to print to.
2142 See Info node `(elisp)Output Streams' for details on streams.
2143 FILENAME specifies the file name to use for `load-history'.
2144 UNIBYTE, if non-nil, specifies `load-convert-to-unibyte' for this
2145 invocation.
2146 DO-ALLOW-PRINT, if non-nil, specifies that output functions in the
2147 evaluated code should work normally even if PRINTFLAG is nil, in
2148 which case the output is displayed in the echo area.
2149
2150 This function ignores the current value of the `lexical-binding'
2151 variable. Instead it will heed any
2152 -*- lexical-binding: t -*-
2153 settings in the buffer, and if there is no such setting, the buffer
2154 will be evaluated without lexical binding.
2155
2156 This function preserves the position of point. */)
2157 (Lisp_Object buffer, Lisp_Object printflag, Lisp_Object filename, Lisp_Object unibyte, Lisp_Object do_allow_print)
2158 {
2159 ptrdiff_t count = SPECPDL_INDEX ();
2160 Lisp_Object tem, buf;
2161
2162 if (NILP (buffer))
2163 buf = Fcurrent_buffer ();
2164 else
2165 buf = Fget_buffer (buffer);
2166 if (NILP (buf))
2167 error ("No such buffer");
2168
2169 if (NILP (printflag) && NILP (do_allow_print))
2170 tem = Qsymbolp;
2171 else
2172 tem = printflag;
2173
2174 if (NILP (filename))
2175 filename = BVAR (XBUFFER (buf), filename);
2176
2177 specbind (Qeval_buffer_list, Fcons (buf, Veval_buffer_list));
2178 specbind (Qstandard_output, tem);
2179 record_unwind_protect_excursion ();
2180 BUF_TEMP_SET_PT (XBUFFER (buf), BUF_BEGV (XBUFFER (buf)));
2181 specbind (Qlexical_binding, lisp_file_lexically_bound_p (buf) ? Qt : Qnil);
2182 BUF_TEMP_SET_PT (XBUFFER (buf), BUF_BEGV (XBUFFER (buf)));
2183 readevalloop (buf, 0, filename,
2184 !NILP (printflag), unibyte, Qnil, Qnil, Qnil);
2185 return unbind_to (count, Qnil);
2186 }
2187
2188 DEFUN ("eval-region", Feval_region, Seval_region, 2, 4, "r",
2189 doc: /* Execute the region as Lisp code.
2190 When called from programs, expects two arguments,
2191 giving starting and ending indices in the current buffer
2192 of the text to be executed.
2193 Programs can pass third argument PRINTFLAG which controls output:
2194 a value of nil means discard it; anything else is stream for printing it.
2195 See Info node `(elisp)Output Streams' for details on streams.
2196 Also the fourth argument READ-FUNCTION, if non-nil, is used
2197 instead of `read' to read each expression. It gets one argument
2198 which is the input stream for reading characters.
2199
2200 This function does not move point. */)
2201 (Lisp_Object start, Lisp_Object end, Lisp_Object printflag, Lisp_Object read_function)
2202 {
2203 /* FIXME: Do the eval-sexp-add-defvars dance! */
2204 ptrdiff_t count = SPECPDL_INDEX ();
2205 Lisp_Object tem, cbuf;
2206
2207 cbuf = Fcurrent_buffer ();
2208
2209 if (NILP (printflag))
2210 tem = Qsymbolp;
2211 else
2212 tem = printflag;
2213 specbind (Qstandard_output, tem);
2214 specbind (Qeval_buffer_list, Fcons (cbuf, Veval_buffer_list));
2215
2216 /* `readevalloop' calls functions which check the type of start and end. */
2217 readevalloop (cbuf, 0, BVAR (XBUFFER (cbuf), filename),
2218 !NILP (printflag), Qnil, read_function,
2219 start, end);
2220
2221 return unbind_to (count, Qnil);
2222 }
2223
2224
2225 DEFUN ("read", Fread, Sread, 0, 1, 0,
2226 doc: /* Read one Lisp expression as text from STREAM, return as Lisp object.
2227 If STREAM is nil, use the value of `standard-input' (which see).
2228 STREAM or the value of `standard-input' may be:
2229 a buffer (read from point and advance it)
2230 a marker (read from where it points and advance it)
2231 a function (call it with no arguments for each character,
2232 call it with a char as argument to push a char back)
2233 a string (takes text from string, starting at the beginning)
2234 t (read text line using minibuffer and use it, or read from
2235 standard input in batch mode). */)
2236 (Lisp_Object stream)
2237 {
2238 if (NILP (stream))
2239 stream = Vstandard_input;
2240 if (EQ (stream, Qt))
2241 stream = Qread_char;
2242 if (EQ (stream, Qread_char))
2243 /* FIXME: ?! This is used when the reader is called from the
2244 minibuffer without a stream, as in (read). But is this feature
2245 ever used, and if so, why? IOW, will anything break if this
2246 feature is removed !? */
2247 return call1 (intern ("read-minibuffer"),
2248 build_string ("Lisp expression: "));
2249
2250 return read_internal_start (stream, Qnil, Qnil);
2251 }
2252
2253 DEFUN ("read-from-string", Fread_from_string, Sread_from_string, 1, 3, 0,
2254 doc: /* Read one Lisp expression which is represented as text by STRING.
2255 Returns a cons: (OBJECT-READ . FINAL-STRING-INDEX).
2256 FINAL-STRING-INDEX is an integer giving the position of the next
2257 remaining character in STRING. START and END optionally delimit
2258 a substring of STRING from which to read; they default to 0 and
2259 \(length STRING) respectively. Negative values are counted from
2260 the end of STRING. */)
2261 (Lisp_Object string, Lisp_Object start, Lisp_Object end)
2262 {
2263 Lisp_Object ret;
2264 CHECK_STRING (string);
2265 /* `read_internal_start' sets `read_from_string_index'. */
2266 ret = read_internal_start (string, start, end);
2267 return Fcons (ret, make_fixnum (read_from_string_index));
2268 }
2269
2270 /* Function to set up the global context we need in toplevel read
2271 calls. START and END only used when STREAM is a string. */
2272 static Lisp_Object
read_internal_start(Lisp_Object stream,Lisp_Object start,Lisp_Object end)2273 read_internal_start (Lisp_Object stream, Lisp_Object start, Lisp_Object end)
2274 {
2275 Lisp_Object retval;
2276
2277 readchar_count = 0;
2278 new_backquote_flag = force_new_style_backquotes;
2279 /* We can get called from readevalloop which may have set these
2280 already. */
2281 if (! HASH_TABLE_P (read_objects_map)
2282 || XHASH_TABLE (read_objects_map)->count)
2283 read_objects_map
2284 = make_hash_table (hashtest_eq, DEFAULT_HASH_SIZE, DEFAULT_REHASH_SIZE,
2285 DEFAULT_REHASH_THRESHOLD, Qnil, false);
2286 if (! HASH_TABLE_P (read_objects_completed)
2287 || XHASH_TABLE (read_objects_completed)->count)
2288 read_objects_completed
2289 = make_hash_table (hashtest_eq, DEFAULT_HASH_SIZE, DEFAULT_REHASH_SIZE,
2290 DEFAULT_REHASH_THRESHOLD, Qnil, false);
2291 if (EQ (Vread_with_symbol_positions, Qt)
2292 || EQ (Vread_with_symbol_positions, stream))
2293 Vread_symbol_positions_list = Qnil;
2294
2295 if (STRINGP (stream)
2296 || ((CONSP (stream) && STRINGP (XCAR (stream)))))
2297 {
2298 ptrdiff_t startval, endval;
2299 Lisp_Object string;
2300
2301 if (STRINGP (stream))
2302 string = stream;
2303 else
2304 string = XCAR (stream);
2305
2306 validate_subarray (string, start, end, SCHARS (string),
2307 &startval, &endval);
2308
2309 read_from_string_index = startval;
2310 read_from_string_index_byte = string_char_to_byte (string, startval);
2311 read_from_string_limit = endval;
2312 }
2313
2314 retval = read0 (stream);
2315 if (EQ (Vread_with_symbol_positions, Qt)
2316 || EQ (Vread_with_symbol_positions, stream))
2317 Vread_symbol_positions_list = Fnreverse (Vread_symbol_positions_list);
2318 /* Empty hashes can be reused; otherwise, reset on next call. */
2319 if (HASH_TABLE_P (read_objects_map)
2320 && XHASH_TABLE (read_objects_map)->count > 0)
2321 read_objects_map = Qnil;
2322 if (HASH_TABLE_P (read_objects_completed)
2323 && XHASH_TABLE (read_objects_completed)->count > 0)
2324 read_objects_completed = Qnil;
2325 return retval;
2326 }
2327
2328
2329 /* Signal Qinvalid_read_syntax error.
2330 S is error string of length N (if > 0) */
2331
2332 static AVOID
invalid_syntax(const char * s)2333 invalid_syntax (const char *s)
2334 {
2335 xsignal1 (Qinvalid_read_syntax, build_string (s));
2336 }
2337
2338
2339 /* Use this for recursive reads, in contexts where internal tokens
2340 are not allowed. */
2341
2342 static Lisp_Object
read0(Lisp_Object readcharfun)2343 read0 (Lisp_Object readcharfun)
2344 {
2345 register Lisp_Object val;
2346 int c;
2347
2348 val = read1 (readcharfun, &c, 0);
2349 if (!c)
2350 return val;
2351
2352 xsignal1 (Qinvalid_read_syntax,
2353 Fmake_string (make_fixnum (1), make_fixnum (c), Qnil));
2354 }
2355
2356 /* Grow a read buffer BUF that contains OFFSET useful bytes of data,
2357 by at least MAX_MULTIBYTE_LENGTH bytes. Update *BUF_ADDR and
2358 *BUF_SIZE accordingly; 0 <= OFFSET <= *BUF_SIZE. If *BUF_ADDR is
2359 initially null, BUF is on the stack: copy its data to the new heap
2360 buffer. Otherwise, BUF must equal *BUF_ADDR and can simply be
2361 reallocated. Either way, remember the heap allocation (which is at
2362 pdl slot COUNT) so that it can be freed when unwinding the stack.*/
2363
2364 static char *
grow_read_buffer(char * buf,ptrdiff_t offset,char ** buf_addr,ptrdiff_t * buf_size,ptrdiff_t count)2365 grow_read_buffer (char *buf, ptrdiff_t offset,
2366 char **buf_addr, ptrdiff_t *buf_size, ptrdiff_t count)
2367 {
2368 char *p = xpalloc (*buf_addr, buf_size, MAX_MULTIBYTE_LENGTH, -1, 1);
2369 if (!*buf_addr)
2370 {
2371 memcpy (p, buf, offset);
2372 record_unwind_protect_ptr (xfree, p);
2373 }
2374 else
2375 set_unwind_protect_ptr (count, xfree, p);
2376 *buf_addr = p;
2377 return p;
2378 }
2379
2380 /* Return the scalar value that has the Unicode character name NAME.
2381 Raise 'invalid-read-syntax' if there is no such character. */
2382 static int
character_name_to_code(char const * name,ptrdiff_t name_len)2383 character_name_to_code (char const *name, ptrdiff_t name_len)
2384 {
2385 /* For "U+XXXX", pass the leading '+' to string_to_number to reject
2386 monstrosities like "U+-0000". */
2387 ptrdiff_t len = name_len - 1;
2388 Lisp_Object code
2389 = (name[0] == 'U' && name[1] == '+'
2390 ? string_to_number (name + 1, 16, &len)
2391 : call2 (Qchar_from_name, make_unibyte_string (name, name_len), Qt));
2392
2393 if (! RANGED_FIXNUMP (0, code, MAX_UNICODE_CHAR)
2394 || len != name_len - 1
2395 || char_surrogate_p (XFIXNUM (code)))
2396 {
2397 AUTO_STRING (format, "\\N{%s}");
2398 AUTO_STRING_WITH_LEN (namestr, name, name_len);
2399 xsignal1 (Qinvalid_read_syntax, CALLN (Fformat, format, namestr));
2400 }
2401
2402 return XFIXNUM (code);
2403 }
2404
2405 /* Bound on the length of a Unicode character name. As of
2406 Unicode 9.0.0 the maximum is 83, so this should be safe. */
2407 enum { UNICODE_CHARACTER_NAME_LENGTH_BOUND = 200 };
2408
2409 /* Read a \-escape sequence, assuming we already read the `\'.
2410 If the escape sequence forces unibyte, return eight-bit char. */
2411
2412 static int
read_escape(Lisp_Object readcharfun,bool stringp)2413 read_escape (Lisp_Object readcharfun, bool stringp)
2414 {
2415 int c = READCHAR;
2416 /* \u allows up to four hex digits, \U up to eight. Default to the
2417 behavior for \u, and change this value in the case that \U is seen. */
2418 int unicode_hex_count = 4;
2419
2420 switch (c)
2421 {
2422 case -1:
2423 end_of_file_error ();
2424
2425 case 'a':
2426 return '\007';
2427 case 'b':
2428 return '\b';
2429 case 'd':
2430 return 0177;
2431 case 'e':
2432 return 033;
2433 case 'f':
2434 return '\f';
2435 case 'n':
2436 return '\n';
2437 case 'r':
2438 return '\r';
2439 case 't':
2440 return '\t';
2441 case 'v':
2442 return '\v';
2443 case '\n':
2444 return -1;
2445 case ' ':
2446 if (stringp)
2447 return -1;
2448 return ' ';
2449
2450 case 'M':
2451 c = READCHAR;
2452 if (c != '-')
2453 error ("Invalid escape character syntax");
2454 c = READCHAR;
2455 if (c == '\\')
2456 c = read_escape (readcharfun, 0);
2457 return c | meta_modifier;
2458
2459 case 'S':
2460 c = READCHAR;
2461 if (c != '-')
2462 error ("Invalid escape character syntax");
2463 c = READCHAR;
2464 if (c == '\\')
2465 c = read_escape (readcharfun, 0);
2466 return c | shift_modifier;
2467
2468 case 'H':
2469 c = READCHAR;
2470 if (c != '-')
2471 error ("Invalid escape character syntax");
2472 c = READCHAR;
2473 if (c == '\\')
2474 c = read_escape (readcharfun, 0);
2475 return c | hyper_modifier;
2476
2477 case 'A':
2478 c = READCHAR;
2479 if (c != '-')
2480 error ("Invalid escape character syntax");
2481 c = READCHAR;
2482 if (c == '\\')
2483 c = read_escape (readcharfun, 0);
2484 return c | alt_modifier;
2485
2486 case 's':
2487 c = READCHAR;
2488 if (stringp || c != '-')
2489 {
2490 UNREAD (c);
2491 return ' ';
2492 }
2493 c = READCHAR;
2494 if (c == '\\')
2495 c = read_escape (readcharfun, 0);
2496 return c | super_modifier;
2497
2498 case 'C':
2499 c = READCHAR;
2500 if (c != '-')
2501 error ("Invalid escape character syntax");
2502 FALLTHROUGH;
2503 case '^':
2504 c = READCHAR;
2505 if (c == '\\')
2506 c = read_escape (readcharfun, 0);
2507 if ((c & ~CHAR_MODIFIER_MASK) == '?')
2508 return 0177 | (c & CHAR_MODIFIER_MASK);
2509 else if (! SINGLE_BYTE_CHAR_P ((c & ~CHAR_MODIFIER_MASK)))
2510 return c | ctrl_modifier;
2511 /* ASCII control chars are made from letters (both cases),
2512 as well as the non-letters within 0100...0137. */
2513 else if ((c & 0137) >= 0101 && (c & 0137) <= 0132)
2514 return (c & (037 | ~0177));
2515 else if ((c & 0177) >= 0100 && (c & 0177) <= 0137)
2516 return (c & (037 | ~0177));
2517 else
2518 return c | ctrl_modifier;
2519
2520 case '0':
2521 case '1':
2522 case '2':
2523 case '3':
2524 case '4':
2525 case '5':
2526 case '6':
2527 case '7':
2528 /* An octal escape, as in ANSI C. */
2529 {
2530 register int i = c - '0';
2531 register int count = 0;
2532 while (++count < 3)
2533 {
2534 if ((c = READCHAR) >= '0' && c <= '7')
2535 {
2536 i *= 8;
2537 i += c - '0';
2538 }
2539 else
2540 {
2541 UNREAD (c);
2542 break;
2543 }
2544 }
2545
2546 if (i >= 0x80 && i < 0x100)
2547 i = BYTE8_TO_CHAR (i);
2548 return i;
2549 }
2550
2551 case 'x':
2552 /* A hex escape, as in ANSI C. */
2553 {
2554 unsigned int i = 0;
2555 int count = 0;
2556 while (1)
2557 {
2558 c = READCHAR;
2559 int digit = char_hexdigit (c);
2560 if (digit < 0)
2561 {
2562 UNREAD (c);
2563 break;
2564 }
2565 i = (i << 4) + digit;
2566 /* Allow hex escapes as large as ?\xfffffff, because some
2567 packages use them to denote characters with modifiers. */
2568 if ((CHAR_META | (CHAR_META - 1)) < i)
2569 error ("Hex character out of range: \\x%x...", i);
2570 count += count < 3;
2571 }
2572
2573 if (count < 3 && i >= 0x80)
2574 return BYTE8_TO_CHAR (i);
2575 return i;
2576 }
2577
2578 case 'U':
2579 /* Post-Unicode-2.0: Up to eight hex chars. */
2580 unicode_hex_count = 8;
2581 FALLTHROUGH;
2582 case 'u':
2583
2584 /* A Unicode escape. We only permit them in strings and characters,
2585 not arbitrarily in the source code, as in some other languages. */
2586 {
2587 unsigned int i = 0;
2588 int count = 0;
2589
2590 while (++count <= unicode_hex_count)
2591 {
2592 c = READCHAR;
2593 /* `isdigit' and `isalpha' may be locale-specific, which we don't
2594 want. */
2595 int digit = char_hexdigit (c);
2596 if (digit < 0)
2597 error ("Non-hex character used for Unicode escape: %c (%d)",
2598 c, c);
2599 i = (i << 4) + digit;
2600 }
2601 if (i > 0x10FFFF)
2602 error ("Non-Unicode character: 0x%x", i);
2603 return i;
2604 }
2605
2606 case 'N':
2607 /* Named character. */
2608 {
2609 c = READCHAR;
2610 if (c != '{')
2611 invalid_syntax ("Expected opening brace after \\N");
2612 char name[UNICODE_CHARACTER_NAME_LENGTH_BOUND + 1];
2613 bool whitespace = false;
2614 ptrdiff_t length = 0;
2615 while (true)
2616 {
2617 c = READCHAR;
2618 if (c < 0)
2619 end_of_file_error ();
2620 if (c == '}')
2621 break;
2622 if (! (0 < c && c < 0x80))
2623 {
2624 AUTO_STRING (format,
2625 "Invalid character U+%04X in character name");
2626 xsignal1 (Qinvalid_read_syntax,
2627 CALLN (Fformat, format, make_fixed_natnum (c)));
2628 }
2629 /* Treat multiple adjacent whitespace characters as a
2630 single space character. This makes it easier to use
2631 character names in e.g. multi-line strings. */
2632 if (c_isspace (c))
2633 {
2634 if (whitespace)
2635 continue;
2636 c = ' ';
2637 whitespace = true;
2638 }
2639 else
2640 whitespace = false;
2641 name[length++] = c;
2642 if (length >= sizeof name)
2643 invalid_syntax ("Character name too long");
2644 }
2645 if (length == 0)
2646 invalid_syntax ("Empty character name");
2647 name[length] = '\0';
2648
2649 /* character_name_to_code can invoke read1, recursively.
2650 This is why read1's buffer is not static. */
2651 return character_name_to_code (name, length);
2652 }
2653
2654 default:
2655 return c;
2656 }
2657 }
2658
2659 /* Return the digit that CHARACTER stands for in the given BASE.
2660 Return -1 if CHARACTER is out of range for BASE,
2661 and -2 if CHARACTER is not valid for any supported BASE. */
2662 static int
digit_to_number(int character,int base)2663 digit_to_number (int character, int base)
2664 {
2665 int digit;
2666
2667 if ('0' <= character && character <= '9')
2668 digit = character - '0';
2669 else if ('a' <= character && character <= 'z')
2670 digit = character - 'a' + 10;
2671 else if ('A' <= character && character <= 'Z')
2672 digit = character - 'A' + 10;
2673 else
2674 return -2;
2675
2676 return digit < base ? digit : -1;
2677 }
2678
2679 static char const invalid_radix_integer_format[] = "integer, radix %"pI"d";
2680
2681 /* Small, as read1 is recursive (Bug#31995). But big enough to hold
2682 the invalid_radix_integer string. */
2683 enum { stackbufsize = max (64,
2684 (sizeof invalid_radix_integer_format
2685 - sizeof "%"pI"d"
2686 + INT_STRLEN_BOUND (EMACS_INT) + 1)) };
2687
2688 static void
invalid_radix_integer(EMACS_INT radix,char stackbuf[VLA_ELEMS (stackbufsize)])2689 invalid_radix_integer (EMACS_INT radix, char stackbuf[VLA_ELEMS (stackbufsize)])
2690 {
2691 sprintf (stackbuf, invalid_radix_integer_format, radix);
2692 invalid_syntax (stackbuf);
2693 }
2694
2695 /* Read an integer in radix RADIX using READCHARFUN to read
2696 characters. RADIX must be in the interval [2..36]. Use STACKBUF
2697 for temporary storage as needed. Value is the integer read.
2698 Signal an error if encountering invalid read syntax. */
2699
2700 static Lisp_Object
read_integer(Lisp_Object readcharfun,int radix,char stackbuf[VLA_ELEMS (stackbufsize)])2701 read_integer (Lisp_Object readcharfun, int radix,
2702 char stackbuf[VLA_ELEMS (stackbufsize)])
2703 {
2704 char *read_buffer = stackbuf;
2705 ptrdiff_t read_buffer_size = stackbufsize;
2706 char *p = read_buffer;
2707 char *heapbuf = NULL;
2708 int valid = -1; /* 1 if valid, 0 if not, -1 if incomplete. */
2709 ptrdiff_t count = SPECPDL_INDEX ();
2710
2711 int c = READCHAR;
2712 if (c == '-' || c == '+')
2713 {
2714 *p++ = c;
2715 c = READCHAR;
2716 }
2717
2718 if (c == '0')
2719 {
2720 *p++ = c;
2721 valid = 1;
2722
2723 /* Ignore redundant leading zeros, so the buffer doesn't
2724 fill up with them. */
2725 do
2726 c = READCHAR;
2727 while (c == '0');
2728 }
2729
2730 for (int digit; (digit = digit_to_number (c, radix)) >= -1; )
2731 {
2732 if (digit == -1)
2733 valid = 0;
2734 if (valid < 0)
2735 valid = 1;
2736 /* Allow 1 extra byte for the \0. */
2737 if (p + 1 == read_buffer + read_buffer_size)
2738 {
2739 ptrdiff_t offset = p - read_buffer;
2740 read_buffer = grow_read_buffer (read_buffer, offset,
2741 &heapbuf, &read_buffer_size,
2742 count);
2743 p = read_buffer + offset;
2744 }
2745 *p++ = c;
2746 c = READCHAR;
2747 }
2748
2749 UNREAD (c);
2750
2751 if (valid != 1)
2752 invalid_radix_integer (radix, stackbuf);
2753
2754 *p = '\0';
2755 return unbind_to (count, string_to_number (read_buffer, radix, NULL));
2756 }
2757
2758
2759 /* If the next token is ')' or ']' or '.', we store that character
2760 in *PCH and the return value is not interesting. Else, we store
2761 zero in *PCH and we read and return one lisp object.
2762
2763 FIRST_IN_LIST is true if this is the first element of a list. */
2764
2765 static Lisp_Object
read1(Lisp_Object readcharfun,int * pch,bool first_in_list)2766 read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
2767 {
2768 int c;
2769 bool uninterned_symbol = false;
2770 bool multibyte;
2771 char stackbuf[stackbufsize];
2772 current_thread->stack_top = stackbuf;
2773
2774 *pch = 0;
2775
2776 retry:
2777
2778 c = READCHAR_REPORT_MULTIBYTE (&multibyte);
2779 if (c < 0)
2780 end_of_file_error ();
2781
2782 switch (c)
2783 {
2784 case '(':
2785 return read_list (0, readcharfun);
2786
2787 case '[':
2788 return read_vector (readcharfun, 0);
2789
2790 case ')':
2791 case ']':
2792 {
2793 *pch = c;
2794 return Qnil;
2795 }
2796
2797 case '#':
2798 c = READCHAR;
2799 if (c == 's')
2800 {
2801 c = READCHAR;
2802 if (c == '(')
2803 {
2804 /* Accept extended format for hash tables (extensible to
2805 other types), e.g.
2806 #s(hash-table size 2 test equal data (k1 v1 k2 v2)) */
2807 Lisp_Object tmp = read_list (0, readcharfun);
2808 Lisp_Object head = CAR_SAFE (tmp);
2809 Lisp_Object data = Qnil;
2810 Lisp_Object val = Qnil;
2811 /* The size is 2 * number of allowed keywords to
2812 make-hash-table. */
2813 Lisp_Object params[12];
2814 Lisp_Object ht;
2815 Lisp_Object key = Qnil;
2816 int param_count = 0;
2817
2818 if (!EQ (head, Qhash_table))
2819 {
2820 ptrdiff_t size = XFIXNUM (Flength (tmp));
2821 Lisp_Object record = Fmake_record (CAR_SAFE (tmp),
2822 make_fixnum (size - 1),
2823 Qnil);
2824 for (int i = 1; i < size; i++)
2825 {
2826 tmp = Fcdr (tmp);
2827 ASET (record, i, Fcar (tmp));
2828 }
2829 return record;
2830 }
2831
2832 tmp = CDR_SAFE (tmp);
2833
2834 /* This is repetitive but fast and simple. */
2835 params[param_count] = QCsize;
2836 params[param_count + 1] = Fplist_get (tmp, Qsize);
2837 if (!NILP (params[param_count + 1]))
2838 param_count += 2;
2839
2840 params[param_count] = QCtest;
2841 params[param_count + 1] = Fplist_get (tmp, Qtest);
2842 if (!NILP (params[param_count + 1]))
2843 param_count += 2;
2844
2845 params[param_count] = QCweakness;
2846 params[param_count + 1] = Fplist_get (tmp, Qweakness);
2847 if (!NILP (params[param_count + 1]))
2848 param_count += 2;
2849
2850 params[param_count] = QCrehash_size;
2851 params[param_count + 1] = Fplist_get (tmp, Qrehash_size);
2852 if (!NILP (params[param_count + 1]))
2853 param_count += 2;
2854
2855 params[param_count] = QCrehash_threshold;
2856 params[param_count + 1] = Fplist_get (tmp, Qrehash_threshold);
2857 if (!NILP (params[param_count + 1]))
2858 param_count += 2;
2859
2860 params[param_count] = QCpurecopy;
2861 params[param_count + 1] = Fplist_get (tmp, Qpurecopy);
2862 if (!NILP (params[param_count + 1]))
2863 param_count += 2;
2864
2865 /* This is the hash table data. */
2866 data = Fplist_get (tmp, Qdata);
2867
2868 /* Now use params to make a new hash table and fill it. */
2869 ht = Fmake_hash_table (param_count, params);
2870
2871 Lisp_Object last = data;
2872 FOR_EACH_TAIL_SAFE (data)
2873 {
2874 key = XCAR (data);
2875 data = XCDR (data);
2876 if (!CONSP (data))
2877 break;
2878 val = XCAR (data);
2879 last = XCDR (data);
2880 Fputhash (key, val, ht);
2881 }
2882 if (!NILP (last))
2883 error ("Hash table data is not a list of even length");
2884
2885 return ht;
2886 }
2887 UNREAD (c);
2888 invalid_syntax ("#");
2889 }
2890 if (c == '^')
2891 {
2892 c = READCHAR;
2893 if (c == '[')
2894 {
2895 Lisp_Object tmp;
2896 tmp = read_vector (readcharfun, 0);
2897 if (ASIZE (tmp) < CHAR_TABLE_STANDARD_SLOTS)
2898 error ("Invalid size char-table");
2899 XSETPVECTYPE (XVECTOR (tmp), PVEC_CHAR_TABLE);
2900 return tmp;
2901 }
2902 else if (c == '^')
2903 {
2904 c = READCHAR;
2905 if (c == '[')
2906 {
2907 /* Sub char-table can't be read as a regular
2908 vector because of a two C integer fields. */
2909 Lisp_Object tbl, tmp = read_list (1, readcharfun);
2910 ptrdiff_t size = list_length (tmp);
2911 int i, depth, min_char;
2912 struct Lisp_Cons *cell;
2913
2914 if (size == 0)
2915 error ("Zero-sized sub char-table");
2916
2917 if (! RANGED_FIXNUMP (1, XCAR (tmp), 3))
2918 error ("Invalid depth in sub char-table");
2919 depth = XFIXNUM (XCAR (tmp));
2920 if (chartab_size[depth] != size - 2)
2921 error ("Invalid size in sub char-table");
2922 cell = XCONS (tmp), tmp = XCDR (tmp), size--;
2923 free_cons (cell);
2924
2925 if (! RANGED_FIXNUMP (0, XCAR (tmp), MAX_CHAR))
2926 error ("Invalid minimum character in sub-char-table");
2927 min_char = XFIXNUM (XCAR (tmp));
2928 cell = XCONS (tmp), tmp = XCDR (tmp), size--;
2929 free_cons (cell);
2930
2931 tbl = make_uninit_sub_char_table (depth, min_char);
2932 for (i = 0; i < size; i++)
2933 {
2934 XSUB_CHAR_TABLE (tbl)->contents[i] = XCAR (tmp);
2935 cell = XCONS (tmp), tmp = XCDR (tmp);
2936 free_cons (cell);
2937 }
2938 return tbl;
2939 }
2940 invalid_syntax ("#^^");
2941 }
2942 invalid_syntax ("#^");
2943 }
2944 if (c == '&')
2945 {
2946 Lisp_Object length;
2947 length = read1 (readcharfun, pch, first_in_list);
2948 c = READCHAR;
2949 if (c == '"')
2950 {
2951 Lisp_Object tmp, val;
2952 EMACS_INT size_in_chars = bool_vector_bytes (XFIXNAT (length));
2953 unsigned char *data;
2954
2955 UNREAD (c);
2956 tmp = read1 (readcharfun, pch, first_in_list);
2957 if (STRING_MULTIBYTE (tmp)
2958 || (size_in_chars != SCHARS (tmp)
2959 /* We used to print 1 char too many
2960 when the number of bits was a multiple of 8.
2961 Accept such input in case it came from an old
2962 version. */
2963 && ! (XFIXNAT (length)
2964 == (SCHARS (tmp) - 1) * BOOL_VECTOR_BITS_PER_CHAR)))
2965 invalid_syntax ("#&...");
2966
2967 val = make_uninit_bool_vector (XFIXNAT (length));
2968 data = bool_vector_uchar_data (val);
2969 memcpy (data, SDATA (tmp), size_in_chars);
2970 /* Clear the extraneous bits in the last byte. */
2971 if (XFIXNUM (length) != size_in_chars * BOOL_VECTOR_BITS_PER_CHAR)
2972 data[size_in_chars - 1]
2973 &= (1 << (XFIXNUM (length) % BOOL_VECTOR_BITS_PER_CHAR)) - 1;
2974 return val;
2975 }
2976 invalid_syntax ("#&...");
2977 }
2978 if (c == '[')
2979 {
2980 /* Accept compiled functions at read-time so that we don't have to
2981 build them using function calls. */
2982 Lisp_Object tmp;
2983 struct Lisp_Vector *vec;
2984 tmp = read_vector (readcharfun, 1);
2985 vec = XVECTOR (tmp);
2986 if (vec->header.size == 0)
2987 invalid_syntax ("Empty byte-code object");
2988 make_byte_code (vec);
2989 return tmp;
2990 }
2991 if (c == '(')
2992 {
2993 Lisp_Object tmp;
2994 int ch;
2995
2996 /* Read the string itself. */
2997 tmp = read1 (readcharfun, &ch, 0);
2998 if (ch != 0 || !STRINGP (tmp))
2999 invalid_syntax ("#");
3000 /* Read the intervals and their properties. */
3001 while (1)
3002 {
3003 Lisp_Object beg, end, plist;
3004
3005 beg = read1 (readcharfun, &ch, 0);
3006 end = plist = Qnil;
3007 if (ch == ')')
3008 break;
3009 if (ch == 0)
3010 end = read1 (readcharfun, &ch, 0);
3011 if (ch == 0)
3012 plist = read1 (readcharfun, &ch, 0);
3013 if (ch)
3014 invalid_syntax ("Invalid string property list");
3015 Fset_text_properties (beg, end, plist, tmp);
3016 }
3017
3018 return tmp;
3019 }
3020
3021 /* #@NUMBER is used to skip NUMBER following bytes.
3022 That's used in .elc files to skip over doc strings
3023 and function definitions. */
3024 if (c == '@')
3025 {
3026 enum { extra = 100 };
3027 ptrdiff_t i, nskip = 0, digits = 0;
3028
3029 /* Read a decimal integer. */
3030 while ((c = READCHAR) >= 0
3031 && c >= '0' && c <= '9')
3032 {
3033 if ((STRING_BYTES_BOUND - extra) / 10 <= nskip)
3034 string_overflow ();
3035 digits++;
3036 nskip *= 10;
3037 nskip += c - '0';
3038 if (digits == 2 && nskip == 0)
3039 { /* We've just seen #@00, which means "skip to end". */
3040 skip_dyn_eof (readcharfun);
3041 return Qnil;
3042 }
3043 }
3044 if (nskip > 0)
3045 /* We can't use UNREAD here, because in the code below we side-step
3046 READCHAR. Instead, assume the first char after #@NNN occupies
3047 a single byte, which is the case normally since it's just
3048 a space. */
3049 nskip--;
3050 else
3051 UNREAD (c);
3052
3053 if (load_force_doc_strings
3054 && (FROM_FILE_P (readcharfun)))
3055 {
3056 /* If we are supposed to force doc strings into core right now,
3057 record the last string that we skipped,
3058 and record where in the file it comes from. */
3059
3060 /* But first exchange saved_doc_string
3061 with prev_saved_doc_string, so we save two strings. */
3062 {
3063 char *temp = saved_doc_string;
3064 ptrdiff_t temp_size = saved_doc_string_size;
3065 file_offset temp_pos = saved_doc_string_position;
3066 ptrdiff_t temp_len = saved_doc_string_length;
3067
3068 saved_doc_string = prev_saved_doc_string;
3069 saved_doc_string_size = prev_saved_doc_string_size;
3070 saved_doc_string_position = prev_saved_doc_string_position;
3071 saved_doc_string_length = prev_saved_doc_string_length;
3072
3073 prev_saved_doc_string = temp;
3074 prev_saved_doc_string_size = temp_size;
3075 prev_saved_doc_string_position = temp_pos;
3076 prev_saved_doc_string_length = temp_len;
3077 }
3078
3079 if (saved_doc_string_size == 0)
3080 {
3081 saved_doc_string = xmalloc (nskip + extra);
3082 saved_doc_string_size = nskip + extra;
3083 }
3084 if (nskip > saved_doc_string_size)
3085 {
3086 saved_doc_string = xrealloc (saved_doc_string, nskip + extra);
3087 saved_doc_string_size = nskip + extra;
3088 }
3089
3090 FILE *instream = infile->stream;
3091 saved_doc_string_position = (file_tell (instream)
3092 - infile->lookahead);
3093
3094 /* Copy that many bytes into saved_doc_string. */
3095 i = 0;
3096 for (int n = min (nskip, infile->lookahead); 0 < n; n--)
3097 saved_doc_string[i++]
3098 = c = infile->buf[--infile->lookahead];
3099 block_input ();
3100 for (; i < nskip && 0 <= c; i++)
3101 saved_doc_string[i] = c = getc (instream);
3102 unblock_input ();
3103
3104 saved_doc_string_length = i;
3105 }
3106 else
3107 /* Skip that many bytes. */
3108 skip_dyn_bytes (readcharfun, nskip);
3109
3110 goto retry;
3111 }
3112 if (c == '!')
3113 {
3114 /* #! appears at the beginning of an executable file.
3115 Skip the first line. */
3116 while (c != '\n' && c >= 0)
3117 c = READCHAR;
3118 goto retry;
3119 }
3120 if (c == '$')
3121 return Vload_file_name;
3122 if (c == '\'')
3123 return list2 (Qfunction, read0 (readcharfun));
3124 /* #:foo is the uninterned symbol named foo. */
3125 if (c == ':')
3126 {
3127 uninterned_symbol = true;
3128 c = READCHAR;
3129 if (!(c > 040
3130 && c != NO_BREAK_SPACE
3131 && (c >= 0200
3132 || strchr ("\"';()[]#`,", c) == NULL)))
3133 {
3134 /* No symbol character follows, this is the empty
3135 symbol. */
3136 UNREAD (c);
3137 return Fmake_symbol (empty_unibyte_string);
3138 }
3139 goto read_symbol;
3140 }
3141 /* ## is the empty symbol. */
3142 if (c == '#')
3143 return Fintern (empty_unibyte_string, Qnil);
3144
3145 if (c >= '0' && c <= '9')
3146 {
3147 EMACS_INT n = c - '0';
3148 bool overflow = false;
3149
3150 /* Read a non-negative integer. */
3151 while ('0' <= (c = READCHAR) && c <= '9')
3152 {
3153 overflow |= INT_MULTIPLY_WRAPV (n, 10, &n);
3154 overflow |= INT_ADD_WRAPV (n, c - '0', &n);
3155 }
3156
3157 if (!overflow)
3158 {
3159 if (c == 'r' || c == 'R')
3160 {
3161 if (! (2 <= n && n <= 36))
3162 invalid_radix_integer (n, stackbuf);
3163 return read_integer (readcharfun, n, stackbuf);
3164 }
3165
3166 if (n <= MOST_POSITIVE_FIXNUM && ! NILP (Vread_circle))
3167 {
3168 /* Reader forms that can reuse previously read objects. */
3169
3170 /* #n=object returns object, but associates it with
3171 n for #n#. */
3172 if (c == '=')
3173 {
3174 /* Make a placeholder for #n# to use temporarily. */
3175 /* Note: We used to use AUTO_CONS to allocate
3176 placeholder, but that is a bad idea, since it
3177 will place a stack-allocated cons cell into
3178 the list in read_objects_map, which is a
3179 staticpro'd global variable, and thus each of
3180 its elements is marked during each GC. A
3181 stack-allocated object will become garbled
3182 when its stack slot goes out of scope, and
3183 some other function reuses it for entirely
3184 different purposes, which will cause crashes
3185 in GC. */
3186 Lisp_Object placeholder = Fcons (Qnil, Qnil);
3187 struct Lisp_Hash_Table *h
3188 = XHASH_TABLE (read_objects_map);
3189 Lisp_Object number = make_fixnum (n), hash;
3190
3191 ptrdiff_t i = hash_lookup (h, number, &hash);
3192 if (i >= 0)
3193 /* Not normal, but input could be malformed. */
3194 set_hash_value_slot (h, i, placeholder);
3195 else
3196 hash_put (h, number, placeholder, hash);
3197
3198 /* Read the object itself. */
3199 Lisp_Object tem = read0 (readcharfun);
3200
3201 /* If it can be recursive, remember it for
3202 future substitutions. */
3203 if (! SYMBOLP (tem)
3204 && ! NUMBERP (tem)
3205 && ! (STRINGP (tem) && !string_intervals (tem)))
3206 {
3207 struct Lisp_Hash_Table *h2
3208 = XHASH_TABLE (read_objects_completed);
3209 i = hash_lookup (h2, tem, &hash);
3210 eassert (i < 0);
3211 hash_put (h2, tem, Qnil, hash);
3212 }
3213
3214 /* Now put it everywhere the placeholder was... */
3215 if (CONSP (tem))
3216 {
3217 Fsetcar (placeholder, XCAR (tem));
3218 Fsetcdr (placeholder, XCDR (tem));
3219 return placeholder;
3220 }
3221 else
3222 {
3223 Flread__substitute_object_in_subtree
3224 (tem, placeholder, read_objects_completed);
3225
3226 /* ...and #n# will use the real value from now on. */
3227 i = hash_lookup (h, number, &hash);
3228 eassert (i >= 0);
3229 set_hash_value_slot (h, i, tem);
3230
3231 return tem;
3232 }
3233 }
3234
3235 /* #n# returns a previously read object. */
3236 if (c == '#')
3237 {
3238 struct Lisp_Hash_Table *h
3239 = XHASH_TABLE (read_objects_map);
3240 ptrdiff_t i = hash_lookup (h, make_fixnum (n), NULL);
3241 if (i >= 0)
3242 return HASH_VALUE (h, i);
3243 }
3244 }
3245 }
3246 /* Fall through to error message. */
3247 }
3248 else if (c == 'x' || c == 'X')
3249 return read_integer (readcharfun, 16, stackbuf);
3250 else if (c == 'o' || c == 'O')
3251 return read_integer (readcharfun, 8, stackbuf);
3252 else if (c == 'b' || c == 'B')
3253 return read_integer (readcharfun, 2, stackbuf);
3254
3255 UNREAD (c);
3256 invalid_syntax ("#");
3257
3258 case ';':
3259 while ((c = READCHAR) >= 0 && c != '\n');
3260 goto retry;
3261
3262 case '\'':
3263 return list2 (Qquote, read0 (readcharfun));
3264
3265 case '`':
3266 {
3267 int next_char = READCHAR;
3268 UNREAD (next_char);
3269 /* Transition from old-style to new-style:
3270 If we see "(`" it used to mean old-style, which usually works
3271 fine because ` should almost never appear in such a position
3272 for new-style. But occasionally we need "(`" to mean new
3273 style, so we try to distinguish the two by the fact that we
3274 can either write "( `foo" or "(` foo", where the first
3275 intends to use new-style whereas the second intends to use
3276 old-style. For Emacs-25, we should completely remove this
3277 first_in_list exception (old-style can still be obtained via
3278 "(\`" anyway). */
3279 if (!new_backquote_flag && first_in_list && next_char == ' ')
3280 load_error_old_style_backquotes ();
3281 else
3282 {
3283 Lisp_Object value;
3284 bool saved_new_backquote_flag = new_backquote_flag;
3285
3286 new_backquote_flag = 1;
3287 value = read0 (readcharfun);
3288 new_backquote_flag = saved_new_backquote_flag;
3289
3290 return list2 (Qbackquote, value);
3291 }
3292 }
3293 case ',':
3294 {
3295 int next_char = READCHAR;
3296 UNREAD (next_char);
3297 /* Transition from old-style to new-style:
3298 It used to be impossible to have a new-style , other than within
3299 a new-style `. This is sufficient when ` and , are used in the
3300 normal way, but ` and , can also appear in args to macros that
3301 will not interpret them in the usual way, in which case , may be
3302 used without any ` anywhere near.
3303 So we now use the same heuristic as for backquote: old-style
3304 unquotes are only recognized when first on a list, and when
3305 followed by a space.
3306 Because it's more difficult to peek 2 chars ahead, a new-style
3307 ,@ can still not be used outside of a `, unless it's in the middle
3308 of a list. */
3309 if (new_backquote_flag
3310 || !first_in_list
3311 || (next_char != ' ' && next_char != '@'))
3312 {
3313 Lisp_Object comma_type = Qnil;
3314 Lisp_Object value;
3315 int ch = READCHAR;
3316
3317 if (ch == '@')
3318 comma_type = Qcomma_at;
3319 else
3320 {
3321 if (ch >= 0) UNREAD (ch);
3322 comma_type = Qcomma;
3323 }
3324
3325 value = read0 (readcharfun);
3326 return list2 (comma_type, value);
3327 }
3328 else
3329 load_error_old_style_backquotes ();
3330 }
3331 case '?':
3332 {
3333 int modifiers;
3334 int next_char;
3335 bool ok;
3336
3337 c = READCHAR;
3338 if (c < 0)
3339 end_of_file_error ();
3340
3341 /* Accept `single space' syntax like (list ? x) where the
3342 whitespace character is SPC or TAB.
3343 Other literal whitespace like NL, CR, and FF are not accepted,
3344 as there are well-established escape sequences for these. */
3345 if (c == ' ' || c == '\t')
3346 return make_fixnum (c);
3347
3348 if (c == '(' || c == ')' || c == '[' || c == ']'
3349 || c == '"' || c == ';')
3350 {
3351 CHECK_LIST (Vlread_unescaped_character_literals);
3352 Lisp_Object char_obj = make_fixed_natnum (c);
3353 if (NILP (Fmemq (char_obj, Vlread_unescaped_character_literals)))
3354 Vlread_unescaped_character_literals =
3355 Fcons (char_obj, Vlread_unescaped_character_literals);
3356 }
3357
3358 if (c == '\\')
3359 c = read_escape (readcharfun, 0);
3360 modifiers = c & CHAR_MODIFIER_MASK;
3361 c &= ~CHAR_MODIFIER_MASK;
3362 if (CHAR_BYTE8_P (c))
3363 c = CHAR_TO_BYTE8 (c);
3364 c |= modifiers;
3365
3366 next_char = READCHAR;
3367 ok = (next_char <= 040
3368 || (next_char < 0200
3369 && strchr ("\"';()[]#?`,.", next_char) != NULL));
3370 UNREAD (next_char);
3371 if (ok)
3372 return make_fixnum (c);
3373
3374 invalid_syntax ("?");
3375 }
3376
3377 case '"':
3378 {
3379 ptrdiff_t count = SPECPDL_INDEX ();
3380 char *read_buffer = stackbuf;
3381 ptrdiff_t read_buffer_size = sizeof stackbuf;
3382 char *heapbuf = NULL;
3383 char *p = read_buffer;
3384 char *end = read_buffer + read_buffer_size;
3385 int ch;
3386 /* True if we saw an escape sequence specifying
3387 a multibyte character. */
3388 bool force_multibyte = false;
3389 /* True if we saw an escape sequence specifying
3390 a single-byte character. */
3391 bool force_singlebyte = false;
3392 bool cancel = false;
3393 ptrdiff_t nchars = 0;
3394
3395 while ((ch = READCHAR) >= 0
3396 && ch != '\"')
3397 {
3398 if (end - p < MAX_MULTIBYTE_LENGTH)
3399 {
3400 ptrdiff_t offset = p - read_buffer;
3401 read_buffer = grow_read_buffer (read_buffer, offset,
3402 &heapbuf, &read_buffer_size,
3403 count);
3404 p = read_buffer + offset;
3405 end = read_buffer + read_buffer_size;
3406 }
3407
3408 if (ch == '\\')
3409 {
3410 int modifiers;
3411
3412 ch = read_escape (readcharfun, 1);
3413
3414 /* CH is -1 if \ newline or \ space has just been seen. */
3415 if (ch == -1)
3416 {
3417 if (p == read_buffer)
3418 cancel = true;
3419 continue;
3420 }
3421
3422 modifiers = ch & CHAR_MODIFIER_MASK;
3423 ch = ch & ~CHAR_MODIFIER_MASK;
3424
3425 if (CHAR_BYTE8_P (ch))
3426 force_singlebyte = true;
3427 else if (! ASCII_CHAR_P (ch))
3428 force_multibyte = true;
3429 else /* I.e. ASCII_CHAR_P (ch). */
3430 {
3431 /* Allow `\C- ' and `\C-?'. */
3432 if (modifiers == CHAR_CTL)
3433 {
3434 if (ch == ' ')
3435 ch = 0, modifiers = 0;
3436 else if (ch == '?')
3437 ch = 127, modifiers = 0;
3438 }
3439 if (modifiers & CHAR_SHIFT)
3440 {
3441 /* Shift modifier is valid only with [A-Za-z]. */
3442 if (ch >= 'A' && ch <= 'Z')
3443 modifiers &= ~CHAR_SHIFT;
3444 else if (ch >= 'a' && ch <= 'z')
3445 ch -= ('a' - 'A'), modifiers &= ~CHAR_SHIFT;
3446 }
3447
3448 if (modifiers & CHAR_META)
3449 {
3450 /* Move the meta bit to the right place for a
3451 string. */
3452 modifiers &= ~CHAR_META;
3453 ch = BYTE8_TO_CHAR (ch | 0x80);
3454 force_singlebyte = true;
3455 }
3456 }
3457
3458 /* Any modifiers remaining are invalid. */
3459 if (modifiers)
3460 error ("Invalid modifier in string");
3461 p += CHAR_STRING (ch, (unsigned char *) p);
3462 }
3463 else
3464 {
3465 p += CHAR_STRING (ch, (unsigned char *) p);
3466 if (CHAR_BYTE8_P (ch))
3467 force_singlebyte = true;
3468 else if (! ASCII_CHAR_P (ch))
3469 force_multibyte = true;
3470 }
3471 nchars++;
3472 }
3473
3474 if (ch < 0)
3475 end_of_file_error ();
3476
3477 /* If purifying, and string starts with \ newline,
3478 return zero instead. This is for doc strings
3479 that we are really going to find in etc/DOC.nn.nn. */
3480 if (!NILP (Vpurify_flag) && NILP (Vdoc_file_name) && cancel)
3481 return unbind_to (count, make_fixnum (0));
3482
3483 if (! force_multibyte && force_singlebyte)
3484 {
3485 /* READ_BUFFER contains raw 8-bit bytes and no multibyte
3486 forms. Convert it to unibyte. */
3487 nchars = str_as_unibyte ((unsigned char *) read_buffer,
3488 p - read_buffer);
3489 p = read_buffer + nchars;
3490 }
3491
3492 Lisp_Object result
3493 = make_specified_string (read_buffer, nchars, p - read_buffer,
3494 (force_multibyte
3495 || (p - read_buffer != nchars)));
3496 return unbind_to (count, result);
3497 }
3498
3499 case '.':
3500 {
3501 int next_char = READCHAR;
3502 UNREAD (next_char);
3503
3504 if (next_char <= 040
3505 || (next_char < 0200
3506 && strchr ("\"';([#?`,", next_char) != NULL))
3507 {
3508 *pch = c;
3509 return Qnil;
3510 }
3511 }
3512 /* The atom-reading loop below will now loop at least once,
3513 assuring that we will not try to UNREAD two characters in a
3514 row. */
3515 FALLTHROUGH;
3516 default:
3517 if (c <= 040) goto retry;
3518 if (c == NO_BREAK_SPACE)
3519 goto retry;
3520
3521 read_symbol:
3522 {
3523 ptrdiff_t count = SPECPDL_INDEX ();
3524 char *read_buffer = stackbuf;
3525 ptrdiff_t read_buffer_size = sizeof stackbuf;
3526 char *heapbuf = NULL;
3527 char *p = read_buffer;
3528 char *end = read_buffer + read_buffer_size;
3529 bool quoted = false;
3530 EMACS_INT start_position = readchar_count - 1;
3531
3532 do
3533 {
3534 if (end - p < MAX_MULTIBYTE_LENGTH + 1)
3535 {
3536 ptrdiff_t offset = p - read_buffer;
3537 read_buffer = grow_read_buffer (read_buffer, offset,
3538 &heapbuf, &read_buffer_size,
3539 count);
3540 p = read_buffer + offset;
3541 end = read_buffer + read_buffer_size;
3542 }
3543
3544 if (c == '\\')
3545 {
3546 c = READCHAR;
3547 if (c == -1)
3548 end_of_file_error ();
3549 quoted = true;
3550 }
3551
3552 if (multibyte)
3553 p += CHAR_STRING (c, (unsigned char *) p);
3554 else
3555 *p++ = c;
3556 c = READCHAR;
3557 }
3558 while (c > 040
3559 && c != NO_BREAK_SPACE
3560 && (c >= 0200
3561 || strchr ("\"';()[]#`,", c) == NULL));
3562
3563 *p = 0;
3564 ptrdiff_t nbytes = p - read_buffer;
3565 UNREAD (c);
3566
3567 if (!quoted && !uninterned_symbol)
3568 {
3569 ptrdiff_t len;
3570 Lisp_Object result = string_to_number (read_buffer, 10, &len);
3571 if (! NILP (result) && len == nbytes)
3572 return unbind_to (count, result);
3573 }
3574 {
3575 Lisp_Object result;
3576 ptrdiff_t nchars
3577 = (multibyte
3578 ? multibyte_chars_in_text ((unsigned char *) read_buffer,
3579 nbytes)
3580 : nbytes);
3581
3582 if (uninterned_symbol)
3583 {
3584 Lisp_Object name
3585 = ((! NILP (Vpurify_flag)
3586 ? make_pure_string : make_specified_string)
3587 (read_buffer, nchars, nbytes, multibyte));
3588 result = Fmake_symbol (name);
3589 }
3590 else
3591 {
3592 /* Don't create the string object for the name unless
3593 we're going to retain it in a new symbol.
3594
3595 Like intern_1 but supports multibyte names. */
3596 Lisp_Object obarray = check_obarray (Vobarray);
3597 Lisp_Object tem = oblookup (obarray, read_buffer,
3598 nchars, nbytes);
3599
3600 if (SYMBOLP (tem))
3601 result = tem;
3602 else
3603 {
3604 Lisp_Object name
3605 = make_specified_string (read_buffer, nchars, nbytes,
3606 multibyte);
3607 result = intern_driver (name, obarray, tem);
3608 }
3609 }
3610
3611 if (EQ (Vread_with_symbol_positions, Qt)
3612 || EQ (Vread_with_symbol_positions, readcharfun))
3613 Vread_symbol_positions_list
3614 = Fcons (Fcons (result, make_fixnum (start_position)),
3615 Vread_symbol_positions_list);
3616 return unbind_to (count, result);
3617 }
3618 }
3619 }
3620 }
3621
3622 DEFUN ("lread--substitute-object-in-subtree",
3623 Flread__substitute_object_in_subtree,
3624 Slread__substitute_object_in_subtree, 3, 3, 0,
3625 doc: /* In OBJECT, replace every occurrence of PLACEHOLDER with OBJECT.
3626 COMPLETED is a hash table of objects that might be circular, or is t
3627 if any object might be circular. */)
3628 (Lisp_Object object, Lisp_Object placeholder, Lisp_Object completed)
3629 {
3630 struct subst subst = { object, placeholder, completed, Qnil };
3631 Lisp_Object check_object = substitute_object_recurse (&subst, object);
3632
3633 /* The returned object here is expected to always eq the
3634 original. */
3635 if (!EQ (check_object, object))
3636 error ("Unexpected mutation error in reader");
3637 return Qnil;
3638 }
3639
3640 static Lisp_Object
substitute_object_recurse(struct subst * subst,Lisp_Object subtree)3641 substitute_object_recurse (struct subst *subst, Lisp_Object subtree)
3642 {
3643 /* If we find the placeholder, return the target object. */
3644 if (EQ (subst->placeholder, subtree))
3645 return subst->object;
3646
3647 /* For common object types that can't contain other objects, don't
3648 bother looking them up; we're done. */
3649 if (SYMBOLP (subtree)
3650 || (STRINGP (subtree) && !string_intervals (subtree))
3651 || NUMBERP (subtree))
3652 return subtree;
3653
3654 /* If we've been to this node before, don't explore it again. */
3655 if (!NILP (Fmemq (subtree, subst->seen)))
3656 return subtree;
3657
3658 /* If this node can be the entry point to a cycle, remember that
3659 we've seen it. It can only be such an entry point if it was made
3660 by #n=, which means that we can find it as a value in
3661 COMPLETED. */
3662 if (EQ (subst->completed, Qt)
3663 || hash_lookup (XHASH_TABLE (subst->completed), subtree, NULL) >= 0)
3664 subst->seen = Fcons (subtree, subst->seen);
3665
3666 /* Recurse according to subtree's type.
3667 Every branch must return a Lisp_Object. */
3668 switch (XTYPE (subtree))
3669 {
3670 case Lisp_Vectorlike:
3671 {
3672 ptrdiff_t i = 0, length = 0;
3673 if (BOOL_VECTOR_P (subtree))
3674 return subtree; /* No sub-objects anyway. */
3675 else if (CHAR_TABLE_P (subtree) || SUB_CHAR_TABLE_P (subtree)
3676 || COMPILEDP (subtree) || HASH_TABLE_P (subtree)
3677 || RECORDP (subtree))
3678 length = PVSIZE (subtree);
3679 else if (VECTORP (subtree))
3680 length = ASIZE (subtree);
3681 else
3682 /* An unknown pseudovector may contain non-Lisp fields, so we
3683 can't just blindly traverse all its fields. We used to call
3684 `Flength' which signaled `sequencep', so I just preserved this
3685 behavior. */
3686 wrong_type_argument (Qsequencep, subtree);
3687
3688 if (SUB_CHAR_TABLE_P (subtree))
3689 i = 2;
3690 for ( ; i < length; i++)
3691 ASET (subtree, i,
3692 substitute_object_recurse (subst, AREF (subtree, i)));
3693 return subtree;
3694 }
3695
3696 case Lisp_Cons:
3697 XSETCAR (subtree, substitute_object_recurse (subst, XCAR (subtree)));
3698 XSETCDR (subtree, substitute_object_recurse (subst, XCDR (subtree)));
3699 return subtree;
3700
3701 case Lisp_String:
3702 {
3703 /* Check for text properties in each interval.
3704 substitute_in_interval contains part of the logic. */
3705
3706 INTERVAL root_interval = string_intervals (subtree);
3707 traverse_intervals_noorder (root_interval,
3708 substitute_in_interval, subst);
3709 return subtree;
3710 }
3711
3712 /* Other types don't recurse any further. */
3713 default:
3714 return subtree;
3715 }
3716 }
3717
3718 /* Helper function for substitute_object_recurse. */
3719 static void
substitute_in_interval(INTERVAL interval,void * arg)3720 substitute_in_interval (INTERVAL interval, void *arg)
3721 {
3722 set_interval_plist (interval,
3723 substitute_object_recurse (arg, interval->plist));
3724 }
3725
3726
3727 /* Convert the initial prefix of STRING to a number, assuming base BASE.
3728 If the prefix has floating point syntax and BASE is 10, return a
3729 nearest float; otherwise, if the prefix has integer syntax, return
3730 the integer; otherwise, return nil. If PLEN, set *PLEN to the
3731 length of the numeric prefix if there is one, otherwise *PLEN is
3732 unspecified. */
3733
3734 Lisp_Object
string_to_number(char const * string,int base,ptrdiff_t * plen)3735 string_to_number (char const *string, int base, ptrdiff_t *plen)
3736 {
3737 char const *cp = string;
3738 bool float_syntax = false;
3739 double value = 0;
3740
3741 /* Negate the value ourselves. This treats 0, NaNs, and infinity properly on
3742 IEEE floating point hosts, and works around a formerly-common bug where
3743 atof ("-0.0") drops the sign. */
3744 bool negative = *cp == '-';
3745 bool positive = *cp == '+';
3746
3747 bool signedp = negative | positive;
3748 cp += signedp;
3749
3750 enum { INTOVERFLOW = 1, LEAD_INT = 2, DOT_CHAR = 4, TRAIL_INT = 8,
3751 E_EXP = 16 };
3752 int state = 0;
3753 int leading_digit = digit_to_number (*cp, base);
3754 uintmax_t n = leading_digit;
3755 if (leading_digit >= 0)
3756 {
3757 state |= LEAD_INT;
3758 for (int digit; 0 <= (digit = digit_to_number (*++cp, base)); )
3759 {
3760 if (INT_MULTIPLY_OVERFLOW (n, base))
3761 state |= INTOVERFLOW;
3762 n *= base;
3763 if (INT_ADD_OVERFLOW (n, digit))
3764 state |= INTOVERFLOW;
3765 n += digit;
3766 }
3767 }
3768 char const *after_digits = cp;
3769 if (*cp == '.')
3770 {
3771 state |= DOT_CHAR;
3772 cp++;
3773 }
3774
3775 if (base == 10)
3776 {
3777 if ('0' <= *cp && *cp <= '9')
3778 {
3779 state |= TRAIL_INT;
3780 do
3781 cp++;
3782 while ('0' <= *cp && *cp <= '9');
3783 }
3784 if (*cp == 'e' || *cp == 'E')
3785 {
3786 char const *ecp = cp;
3787 cp++;
3788 if (*cp == '+' || *cp == '-')
3789 cp++;
3790 if ('0' <= *cp && *cp <= '9')
3791 {
3792 state |= E_EXP;
3793 do
3794 cp++;
3795 while ('0' <= *cp && *cp <= '9');
3796 }
3797 #if IEEE_FLOATING_POINT
3798 else if (cp[-1] == '+'
3799 && cp[0] == 'I' && cp[1] == 'N' && cp[2] == 'F')
3800 {
3801 state |= E_EXP;
3802 cp += 3;
3803 value = INFINITY;
3804 }
3805 else if (cp[-1] == '+'
3806 && cp[0] == 'N' && cp[1] == 'a' && cp[2] == 'N')
3807 {
3808 state |= E_EXP;
3809 cp += 3;
3810 union ieee754_double u
3811 = { .ieee_nan = { .exponent = 0x7ff, .quiet_nan = 1,
3812 .mantissa0 = n >> 31 >> 1, .mantissa1 = n }};
3813 value = u.d;
3814 }
3815 #endif
3816 else
3817 cp = ecp;
3818 }
3819
3820 float_syntax = ((state & (DOT_CHAR|TRAIL_INT)) == (DOT_CHAR|TRAIL_INT)
3821 || (state & ~INTOVERFLOW) == (LEAD_INT|E_EXP));
3822 }
3823
3824 if (plen)
3825 *plen = cp - string;
3826
3827 /* Return a float if the number uses float syntax. */
3828 if (float_syntax)
3829 {
3830 /* Convert to floating point, unless the value is already known
3831 because it is infinite or a NaN. */
3832 if (! value)
3833 value = atof (string + signedp);
3834 return make_float (negative ? -value : value);
3835 }
3836
3837 /* Return nil if the number uses invalid syntax. */
3838 if (! (state & LEAD_INT))
3839 return Qnil;
3840
3841 /* Fast path if the integer (san sign) fits in uintmax_t. */
3842 if (! (state & INTOVERFLOW))
3843 {
3844 if (!negative)
3845 return make_uint (n);
3846 if (-MOST_NEGATIVE_FIXNUM < n)
3847 return make_neg_biguint (n);
3848 EMACS_INT signed_n = n;
3849 return make_fixnum (-signed_n);
3850 }
3851
3852 /* Trim any leading "+" and trailing nondigits, then return a bignum. */
3853 string += positive;
3854 if (!*after_digits)
3855 return make_bignum_str (string, base);
3856 ptrdiff_t trimmed_len = after_digits - string;
3857 USE_SAFE_ALLOCA;
3858 char *trimmed = SAFE_ALLOCA (trimmed_len + 1);
3859 memcpy (trimmed, string, trimmed_len);
3860 trimmed[trimmed_len] = '\0';
3861 Lisp_Object result = make_bignum_str (trimmed, base);
3862 SAFE_FREE ();
3863 return result;
3864 }
3865
3866
3867 static Lisp_Object
read_vector(Lisp_Object readcharfun,bool bytecodeflag)3868 read_vector (Lisp_Object readcharfun, bool bytecodeflag)
3869 {
3870 Lisp_Object tem = read_list (1, readcharfun);
3871 ptrdiff_t size = list_length (tem);
3872 if (bytecodeflag && size <= COMPILED_STACK_DEPTH)
3873 error ("Invalid byte code");
3874 Lisp_Object vector = make_nil_vector (size);
3875
3876 Lisp_Object *ptr = XVECTOR (vector)->contents;
3877 for (ptrdiff_t i = 0; i < size; i++)
3878 {
3879 Lisp_Object item = Fcar (tem);
3880 /* If `load-force-doc-strings' is t when reading a lazily-loaded
3881 bytecode object, the docstring containing the bytecode and
3882 constants values must be treated as unibyte and passed to
3883 Fread, to get the actual bytecode string and constants vector. */
3884 if (bytecodeflag && load_force_doc_strings)
3885 {
3886 if (i == COMPILED_BYTECODE)
3887 {
3888 if (!STRINGP (item))
3889 error ("Invalid byte code");
3890
3891 /* Delay handling the bytecode slot until we know whether
3892 it is lazily-loaded (we can tell by whether the
3893 constants slot is nil). */
3894 ASET (vector, COMPILED_CONSTANTS, item);
3895 item = Qnil;
3896 }
3897 else if (i == COMPILED_CONSTANTS)
3898 {
3899 Lisp_Object bytestr = ptr[COMPILED_CONSTANTS];
3900
3901 if (NILP (item))
3902 {
3903 /* Coerce string to unibyte (like string-as-unibyte,
3904 but without generating extra garbage and
3905 guaranteeing no change in the contents). */
3906 STRING_SET_CHARS (bytestr, SBYTES (bytestr));
3907 STRING_SET_UNIBYTE (bytestr);
3908
3909 item = Fread (Fcons (bytestr, readcharfun));
3910 if (!CONSP (item))
3911 error ("Invalid byte code");
3912
3913 struct Lisp_Cons *otem = XCONS (item);
3914 bytestr = XCAR (item);
3915 item = XCDR (item);
3916 free_cons (otem);
3917 }
3918
3919 /* Now handle the bytecode slot. */
3920 ASET (vector, COMPILED_BYTECODE, bytestr);
3921 }
3922 else if (i == COMPILED_DOC_STRING
3923 && STRINGP (item)
3924 && ! STRING_MULTIBYTE (item))
3925 {
3926 if (EQ (readcharfun, Qget_emacs_mule_file_char))
3927 item = Fdecode_coding_string (item, Qemacs_mule, Qnil, Qnil);
3928 else
3929 item = Fstring_as_multibyte (item);
3930 }
3931 }
3932 ASET (vector, i, item);
3933 struct Lisp_Cons *otem = XCONS (tem);
3934 tem = Fcdr (tem);
3935 free_cons (otem);
3936 }
3937 return vector;
3938 }
3939
3940 /* FLAG means check for ']' to terminate rather than ')' and '.'. */
3941
3942 static Lisp_Object
read_list(bool flag,Lisp_Object readcharfun)3943 read_list (bool flag, Lisp_Object readcharfun)
3944 {
3945 Lisp_Object val, tail;
3946 Lisp_Object elt, tem;
3947 /* 0 is the normal case.
3948 1 means this list is a doc reference; replace it with the number 0.
3949 2 means this list is a doc reference; replace it with the doc string. */
3950 int doc_reference = 0;
3951
3952 /* Initialize this to 1 if we are reading a list. */
3953 bool first_in_list = flag <= 0;
3954
3955 val = Qnil;
3956 tail = Qnil;
3957
3958 while (1)
3959 {
3960 int ch;
3961 elt = read1 (readcharfun, &ch, first_in_list);
3962
3963 first_in_list = 0;
3964
3965 /* While building, if the list starts with #$, treat it specially. */
3966 if (EQ (elt, Vload_file_name)
3967 && ! NILP (elt)
3968 && !NILP (Vpurify_flag))
3969 {
3970 if (NILP (Vdoc_file_name))
3971 /* We have not yet called Snarf-documentation, so assume
3972 this file is described in the DOC file
3973 and Snarf-documentation will fill in the right value later.
3974 For now, replace the whole list with 0. */
3975 doc_reference = 1;
3976 else
3977 /* We have already called Snarf-documentation, so make a relative
3978 file name for this file, so it can be found properly
3979 in the installed Lisp directory.
3980 We don't use Fexpand_file_name because that would make
3981 the directory absolute now. */
3982 {
3983 AUTO_STRING (dot_dot_lisp, "../lisp/");
3984 elt = concat2 (dot_dot_lisp, Ffile_name_nondirectory (elt));
3985 }
3986 }
3987 else if (EQ (elt, Vload_file_name)
3988 && ! NILP (elt)
3989 && load_force_doc_strings)
3990 doc_reference = 2;
3991
3992 if (ch)
3993 {
3994 if (flag > 0)
3995 {
3996 if (ch == ']')
3997 return val;
3998 invalid_syntax (") or . in a vector");
3999 }
4000 if (ch == ')')
4001 return val;
4002 if (ch == '.')
4003 {
4004 if (!NILP (tail))
4005 XSETCDR (tail, read0 (readcharfun));
4006 else
4007 val = read0 (readcharfun);
4008 read1 (readcharfun, &ch, 0);
4009
4010 if (ch == ')')
4011 {
4012 if (doc_reference == 1)
4013 return make_fixnum (0);
4014 if (doc_reference == 2 && FIXNUMP (XCDR (val)))
4015 {
4016 char *saved = NULL;
4017 file_offset saved_position;
4018 /* Get a doc string from the file we are loading.
4019 If it's in saved_doc_string, get it from there.
4020
4021 Here, we don't know if the string is a
4022 bytecode string or a doc string. As a
4023 bytecode string must be unibyte, we always
4024 return a unibyte string. If it is actually a
4025 doc string, caller must make it
4026 multibyte. */
4027
4028 /* Position is negative for user variables. */
4029 EMACS_INT pos = eabs (XFIXNUM (XCDR (val)));
4030 if (pos >= saved_doc_string_position
4031 && pos < (saved_doc_string_position
4032 + saved_doc_string_length))
4033 {
4034 saved = saved_doc_string;
4035 saved_position = saved_doc_string_position;
4036 }
4037 /* Look in prev_saved_doc_string the same way. */
4038 else if (pos >= prev_saved_doc_string_position
4039 && pos < (prev_saved_doc_string_position
4040 + prev_saved_doc_string_length))
4041 {
4042 saved = prev_saved_doc_string;
4043 saved_position = prev_saved_doc_string_position;
4044 }
4045 if (saved)
4046 {
4047 ptrdiff_t start = pos - saved_position;
4048 ptrdiff_t from, to;
4049
4050 /* Process quoting with ^A,
4051 and find the end of the string,
4052 which is marked with ^_ (037). */
4053 for (from = start, to = start;
4054 saved[from] != 037;)
4055 {
4056 int c = saved[from++];
4057 if (c == 1)
4058 {
4059 c = saved[from++];
4060 saved[to++] = (c == 1 ? c
4061 : c == '0' ? 0
4062 : c == '_' ? 037
4063 : c);
4064 }
4065 else
4066 saved[to++] = c;
4067 }
4068
4069 return make_unibyte_string (saved + start,
4070 to - start);
4071 }
4072 else
4073 return get_doc_string (val, 1, 0);
4074 }
4075
4076 return val;
4077 }
4078 invalid_syntax (". in wrong context");
4079 }
4080 invalid_syntax ("] in a list");
4081 }
4082 tem = list1 (elt);
4083 if (!NILP (tail))
4084 XSETCDR (tail, tem);
4085 else
4086 val = tem;
4087 tail = tem;
4088 }
4089 }
4090
4091 static Lisp_Object initial_obarray;
4092
4093 /* `oblookup' stores the bucket number here, for the sake of Funintern. */
4094
4095 static size_t oblookup_last_bucket_number;
4096
4097 /* Get an error if OBARRAY is not an obarray.
4098 If it is one, return it. */
4099
4100 Lisp_Object
check_obarray(Lisp_Object obarray)4101 check_obarray (Lisp_Object obarray)
4102 {
4103 /* We don't want to signal a wrong-type-argument error when we are
4104 shutting down due to a fatal error, and we don't want to hit
4105 assertions in VECTORP and ASIZE if the fatal error was during GC. */
4106 if (!fatal_error_in_progress
4107 && (!VECTORP (obarray) || ASIZE (obarray) == 0))
4108 {
4109 /* If Vobarray is now invalid, force it to be valid. */
4110 if (EQ (Vobarray, obarray)) Vobarray = initial_obarray;
4111 wrong_type_argument (Qvectorp, obarray);
4112 }
4113 return obarray;
4114 }
4115
4116 /* Intern symbol SYM in OBARRAY using bucket INDEX. */
4117
4118 static Lisp_Object
intern_sym(Lisp_Object sym,Lisp_Object obarray,Lisp_Object index)4119 intern_sym (Lisp_Object sym, Lisp_Object obarray, Lisp_Object index)
4120 {
4121 Lisp_Object *ptr;
4122
4123 XSYMBOL (sym)->u.s.interned = (EQ (obarray, initial_obarray)
4124 ? SYMBOL_INTERNED_IN_INITIAL_OBARRAY
4125 : SYMBOL_INTERNED);
4126
4127 if (SREF (SYMBOL_NAME (sym), 0) == ':' && EQ (obarray, initial_obarray))
4128 {
4129 make_symbol_constant (sym);
4130 XSYMBOL (sym)->u.s.redirect = SYMBOL_PLAINVAL;
4131 SET_SYMBOL_VAL (XSYMBOL (sym), sym);
4132 }
4133
4134 ptr = aref_addr (obarray, XFIXNUM (index));
4135 set_symbol_next (sym, SYMBOLP (*ptr) ? XSYMBOL (*ptr) : NULL);
4136 *ptr = sym;
4137 return sym;
4138 }
4139
4140 /* Intern a symbol with name STRING in OBARRAY using bucket INDEX. */
4141
4142 Lisp_Object
intern_driver(Lisp_Object string,Lisp_Object obarray,Lisp_Object index)4143 intern_driver (Lisp_Object string, Lisp_Object obarray, Lisp_Object index)
4144 {
4145 return intern_sym (Fmake_symbol (string), obarray, index);
4146 }
4147
4148 /* Intern the C string STR: return a symbol with that name,
4149 interned in the current obarray. */
4150
4151 Lisp_Object
intern_1(const char * str,ptrdiff_t len)4152 intern_1 (const char *str, ptrdiff_t len)
4153 {
4154 Lisp_Object obarray = check_obarray (Vobarray);
4155 Lisp_Object tem = oblookup (obarray, str, len, len);
4156
4157 return (SYMBOLP (tem) ? tem
4158 /* The above `oblookup' was done on the basis of nchars==nbytes, so
4159 the string has to be unibyte. */
4160 : intern_driver (make_unibyte_string (str, len),
4161 obarray, tem));
4162 }
4163
4164 Lisp_Object
intern_c_string_1(const char * str,ptrdiff_t len)4165 intern_c_string_1 (const char *str, ptrdiff_t len)
4166 {
4167 Lisp_Object obarray = check_obarray (Vobarray);
4168 Lisp_Object tem = oblookup (obarray, str, len, len);
4169
4170 if (!SYMBOLP (tem))
4171 {
4172 /* Creating a non-pure string from a string literal not implemented yet.
4173 We could just use make_string here and live with the extra copy. */
4174 eassert (!NILP (Vpurify_flag));
4175 tem = intern_driver (make_pure_c_string (str, len), obarray, tem);
4176 }
4177 return tem;
4178 }
4179
4180 static void
define_symbol(Lisp_Object sym,char const * str)4181 define_symbol (Lisp_Object sym, char const *str)
4182 {
4183 ptrdiff_t len = strlen (str);
4184 Lisp_Object string = make_pure_c_string (str, len);
4185 init_symbol (sym, string);
4186
4187 /* Qunbound is uninterned, so that it's not confused with any symbol
4188 'unbound' created by a Lisp program. */
4189 if (! EQ (sym, Qunbound))
4190 {
4191 Lisp_Object bucket = oblookup (initial_obarray, str, len, len);
4192 eassert (FIXNUMP (bucket));
4193 intern_sym (sym, initial_obarray, bucket);
4194 }
4195 }
4196
4197 DEFUN ("intern", Fintern, Sintern, 1, 2, 0,
4198 doc: /* Return the canonical symbol whose name is STRING.
4199 If there is none, one is created by this function and returned.
4200 A second optional argument specifies the obarray to use;
4201 it defaults to the value of `obarray'. */)
4202 (Lisp_Object string, Lisp_Object obarray)
4203 {
4204 Lisp_Object tem;
4205
4206 obarray = check_obarray (NILP (obarray) ? Vobarray : obarray);
4207 CHECK_STRING (string);
4208
4209 tem = oblookup (obarray, SSDATA (string), SCHARS (string), SBYTES (string));
4210 if (!SYMBOLP (tem))
4211 tem = intern_driver (NILP (Vpurify_flag) ? string : Fpurecopy (string),
4212 obarray, tem);
4213 return tem;
4214 }
4215
4216 DEFUN ("intern-soft", Fintern_soft, Sintern_soft, 1, 2, 0,
4217 doc: /* Return the canonical symbol named NAME, or nil if none exists.
4218 NAME may be a string or a symbol. If it is a symbol, that exact
4219 symbol is searched for.
4220 A second optional argument specifies the obarray to use;
4221 it defaults to the value of `obarray'. */)
4222 (Lisp_Object name, Lisp_Object obarray)
4223 {
4224 register Lisp_Object tem, string;
4225
4226 if (NILP (obarray)) obarray = Vobarray;
4227 obarray = check_obarray (obarray);
4228
4229 if (!SYMBOLP (name))
4230 {
4231 CHECK_STRING (name);
4232 string = name;
4233 }
4234 else
4235 string = SYMBOL_NAME (name);
4236
4237 tem = oblookup (obarray, SSDATA (string), SCHARS (string), SBYTES (string));
4238 if (FIXNUMP (tem) || (SYMBOLP (name) && !EQ (name, tem)))
4239 return Qnil;
4240 else
4241 return tem;
4242 }
4243
4244 DEFUN ("unintern", Funintern, Sunintern, 1, 2, 0,
4245 doc: /* Delete the symbol named NAME, if any, from OBARRAY.
4246 The value is t if a symbol was found and deleted, nil otherwise.
4247 NAME may be a string or a symbol. If it is a symbol, that symbol
4248 is deleted, if it belongs to OBARRAY--no other symbol is deleted.
4249 OBARRAY, if nil, defaults to the value of the variable `obarray'.
4250 usage: (unintern NAME OBARRAY) */)
4251 (Lisp_Object name, Lisp_Object obarray)
4252 {
4253 register Lisp_Object string, tem;
4254 size_t hash;
4255
4256 if (NILP (obarray)) obarray = Vobarray;
4257 obarray = check_obarray (obarray);
4258
4259 if (SYMBOLP (name))
4260 string = SYMBOL_NAME (name);
4261 else
4262 {
4263 CHECK_STRING (name);
4264 string = name;
4265 }
4266
4267 tem = oblookup (obarray, SSDATA (string),
4268 SCHARS (string),
4269 SBYTES (string));
4270 if (FIXNUMP (tem))
4271 return Qnil;
4272 /* If arg was a symbol, don't delete anything but that symbol itself. */
4273 if (SYMBOLP (name) && !EQ (name, tem))
4274 return Qnil;
4275
4276 /* There are plenty of other symbols which will screw up the Emacs
4277 session if we unintern them, as well as even more ways to use
4278 `setq' or `fset' or whatnot to make the Emacs session
4279 unusable. Let's not go down this silly road. --Stef */
4280 /* if (NILP (tem) || EQ (tem, Qt))
4281 error ("Attempt to unintern t or nil"); */
4282
4283 XSYMBOL (tem)->u.s.interned = SYMBOL_UNINTERNED;
4284
4285 hash = oblookup_last_bucket_number;
4286
4287 if (EQ (AREF (obarray, hash), tem))
4288 {
4289 if (XSYMBOL (tem)->u.s.next)
4290 {
4291 Lisp_Object sym;
4292 XSETSYMBOL (sym, XSYMBOL (tem)->u.s.next);
4293 ASET (obarray, hash, sym);
4294 }
4295 else
4296 ASET (obarray, hash, make_fixnum (0));
4297 }
4298 else
4299 {
4300 Lisp_Object tail, following;
4301
4302 for (tail = AREF (obarray, hash);
4303 XSYMBOL (tail)->u.s.next;
4304 tail = following)
4305 {
4306 XSETSYMBOL (following, XSYMBOL (tail)->u.s.next);
4307 if (EQ (following, tem))
4308 {
4309 set_symbol_next (tail, XSYMBOL (following)->u.s.next);
4310 break;
4311 }
4312 }
4313 }
4314
4315 return Qt;
4316 }
4317
4318 /* Return the symbol in OBARRAY whose names matches the string
4319 of SIZE characters (SIZE_BYTE bytes) at PTR.
4320 If there is no such symbol, return the integer bucket number of
4321 where the symbol would be if it were present.
4322
4323 Also store the bucket number in oblookup_last_bucket_number. */
4324
4325 Lisp_Object
oblookup(Lisp_Object obarray,register const char * ptr,ptrdiff_t size,ptrdiff_t size_byte)4326 oblookup (Lisp_Object obarray, register const char *ptr, ptrdiff_t size, ptrdiff_t size_byte)
4327 {
4328 size_t hash;
4329 size_t obsize;
4330 register Lisp_Object tail;
4331 Lisp_Object bucket, tem;
4332
4333 obarray = check_obarray (obarray);
4334 /* This is sometimes needed in the middle of GC. */
4335 obsize = gc_asize (obarray);
4336 hash = hash_string (ptr, size_byte) % obsize;
4337 bucket = AREF (obarray, hash);
4338 oblookup_last_bucket_number = hash;
4339 if (EQ (bucket, make_fixnum (0)))
4340 ;
4341 else if (!SYMBOLP (bucket))
4342 error ("Bad data in guts of obarray"); /* Like CADR error message. */
4343 else
4344 for (tail = bucket; ; XSETSYMBOL (tail, XSYMBOL (tail)->u.s.next))
4345 {
4346 if (SBYTES (SYMBOL_NAME (tail)) == size_byte
4347 && SCHARS (SYMBOL_NAME (tail)) == size
4348 && !memcmp (SDATA (SYMBOL_NAME (tail)), ptr, size_byte))
4349 return tail;
4350 else if (XSYMBOL (tail)->u.s.next == 0)
4351 break;
4352 }
4353 XSETINT (tem, hash);
4354 return tem;
4355 }
4356
4357 void
map_obarray(Lisp_Object obarray,void (* fn)(Lisp_Object,Lisp_Object),Lisp_Object arg)4358 map_obarray (Lisp_Object obarray, void (*fn) (Lisp_Object, Lisp_Object), Lisp_Object arg)
4359 {
4360 ptrdiff_t i;
4361 register Lisp_Object tail;
4362 CHECK_VECTOR (obarray);
4363 for (i = ASIZE (obarray) - 1; i >= 0; i--)
4364 {
4365 tail = AREF (obarray, i);
4366 if (SYMBOLP (tail))
4367 while (1)
4368 {
4369 (*fn) (tail, arg);
4370 if (XSYMBOL (tail)->u.s.next == 0)
4371 break;
4372 XSETSYMBOL (tail, XSYMBOL (tail)->u.s.next);
4373 }
4374 }
4375 }
4376
4377 static void
mapatoms_1(Lisp_Object sym,Lisp_Object function)4378 mapatoms_1 (Lisp_Object sym, Lisp_Object function)
4379 {
4380 call1 (function, sym);
4381 }
4382
4383 DEFUN ("mapatoms", Fmapatoms, Smapatoms, 1, 2, 0,
4384 doc: /* Call FUNCTION on every symbol in OBARRAY.
4385 OBARRAY defaults to the value of `obarray'. */)
4386 (Lisp_Object function, Lisp_Object obarray)
4387 {
4388 if (NILP (obarray)) obarray = Vobarray;
4389 obarray = check_obarray (obarray);
4390
4391 map_obarray (obarray, mapatoms_1, function);
4392 return Qnil;
4393 }
4394
4395 #define OBARRAY_SIZE 15121
4396
4397 void
init_obarray_once(void)4398 init_obarray_once (void)
4399 {
4400 Vobarray = make_vector (OBARRAY_SIZE, make_fixnum (0));
4401 initial_obarray = Vobarray;
4402 staticpro (&initial_obarray);
4403
4404 for (int i = 0; i < ARRAYELTS (lispsym); i++)
4405 define_symbol (builtin_lisp_symbol (i), defsym_name[i]);
4406
4407 DEFSYM (Qunbound, "unbound");
4408
4409 DEFSYM (Qnil, "nil");
4410 SET_SYMBOL_VAL (XSYMBOL (Qnil), Qnil);
4411 make_symbol_constant (Qnil);
4412 XSYMBOL (Qnil)->u.s.declared_special = true;
4413
4414 DEFSYM (Qt, "t");
4415 SET_SYMBOL_VAL (XSYMBOL (Qt), Qt);
4416 make_symbol_constant (Qt);
4417 XSYMBOL (Qt)->u.s.declared_special = true;
4418
4419 /* Qt is correct even if not dumping. loadup.el will set to nil at end. */
4420 Vpurify_flag = Qt;
4421
4422 DEFSYM (Qvariable_documentation, "variable-documentation");
4423 }
4424
4425
4426 void
defsubr(union Aligned_Lisp_Subr * aname)4427 defsubr (union Aligned_Lisp_Subr *aname)
4428 {
4429 struct Lisp_Subr *sname = &aname->s;
4430 Lisp_Object sym, tem;
4431 sym = intern_c_string (sname->symbol_name);
4432 XSETPVECTYPE (sname, PVEC_SUBR);
4433 XSETSUBR (tem, sname);
4434 set_symbol_function (sym, tem);
4435 }
4436
4437 #ifdef NOTDEF /* Use fset in subr.el now! */
4438 void
defalias(struct Lisp_Subr * sname,char * string)4439 defalias (struct Lisp_Subr *sname, char *string)
4440 {
4441 Lisp_Object sym;
4442 sym = intern (string);
4443 XSETSUBR (XSYMBOL (sym)->u.s.function, sname);
4444 }
4445 #endif /* NOTDEF */
4446
4447 /* Define an "integer variable"; a symbol whose value is forwarded to a
4448 C variable of type intmax_t. Sample call (with "xx" to fool make-docfile):
4449 DEFxxVAR_INT ("emacs-priority", &emacs_priority, "Documentation"); */
4450 void
defvar_int(struct Lisp_Intfwd const * i_fwd,char const * namestring)4451 defvar_int (struct Lisp_Intfwd const *i_fwd, char const *namestring)
4452 {
4453 Lisp_Object sym = intern_c_string (namestring);
4454 XSYMBOL (sym)->u.s.declared_special = true;
4455 XSYMBOL (sym)->u.s.redirect = SYMBOL_FORWARDED;
4456 SET_SYMBOL_FWD (XSYMBOL (sym), i_fwd);
4457 }
4458
4459 /* Similar but define a variable whose value is t if 1, nil if 0. */
4460 void
defvar_bool(struct Lisp_Boolfwd const * b_fwd,char const * namestring)4461 defvar_bool (struct Lisp_Boolfwd const *b_fwd, char const *namestring)
4462 {
4463 Lisp_Object sym = intern_c_string (namestring);
4464 XSYMBOL (sym)->u.s.declared_special = true;
4465 XSYMBOL (sym)->u.s.redirect = SYMBOL_FORWARDED;
4466 SET_SYMBOL_FWD (XSYMBOL (sym), b_fwd);
4467 Vbyte_boolean_vars = Fcons (sym, Vbyte_boolean_vars);
4468 }
4469
4470 /* Similar but define a variable whose value is the Lisp Object stored
4471 at address. Two versions: with and without gc-marking of the C
4472 variable. The nopro version is used when that variable will be
4473 gc-marked for some other reason, since marking the same slot twice
4474 can cause trouble with strings. */
4475 void
defvar_lisp_nopro(struct Lisp_Objfwd const * o_fwd,char const * namestring)4476 defvar_lisp_nopro (struct Lisp_Objfwd const *o_fwd, char const *namestring)
4477 {
4478 Lisp_Object sym = intern_c_string (namestring);
4479 XSYMBOL (sym)->u.s.declared_special = true;
4480 XSYMBOL (sym)->u.s.redirect = SYMBOL_FORWARDED;
4481 SET_SYMBOL_FWD (XSYMBOL (sym), o_fwd);
4482 }
4483
4484 void
defvar_lisp(struct Lisp_Objfwd const * o_fwd,char const * namestring)4485 defvar_lisp (struct Lisp_Objfwd const *o_fwd, char const *namestring)
4486 {
4487 defvar_lisp_nopro (o_fwd, namestring);
4488 staticpro (o_fwd->objvar);
4489 }
4490
4491 /* Similar but define a variable whose value is the Lisp Object stored
4492 at a particular offset in the current kboard object. */
4493
4494 void
defvar_kboard(struct Lisp_Kboard_Objfwd const * ko_fwd,char const * namestring)4495 defvar_kboard (struct Lisp_Kboard_Objfwd const *ko_fwd, char const *namestring)
4496 {
4497 Lisp_Object sym = intern_c_string (namestring);
4498 XSYMBOL (sym)->u.s.declared_special = true;
4499 XSYMBOL (sym)->u.s.redirect = SYMBOL_FORWARDED;
4500 SET_SYMBOL_FWD (XSYMBOL (sym), ko_fwd);
4501 }
4502
4503 /* Check that the elements of lpath exist. */
4504
4505 static void
load_path_check(Lisp_Object lpath)4506 load_path_check (Lisp_Object lpath)
4507 {
4508 Lisp_Object path_tail;
4509
4510 /* The only elements that might not exist are those from
4511 PATH_LOADSEARCH, EMACSLOADPATH. Anything else is only added if
4512 it exists. */
4513 for (path_tail = lpath; !NILP (path_tail); path_tail = XCDR (path_tail))
4514 {
4515 Lisp_Object dirfile;
4516 dirfile = Fcar (path_tail);
4517 if (STRINGP (dirfile))
4518 {
4519 dirfile = Fdirectory_file_name (dirfile);
4520 if (! file_accessible_directory_p (dirfile))
4521 dir_warning ("Lisp directory", XCAR (path_tail));
4522 }
4523 }
4524 }
4525
4526 /* Return the default load-path, to be used if EMACSLOADPATH is unset.
4527 This does not include the standard site-lisp directories
4528 under the installation prefix (i.e., PATH_SITELOADSEARCH),
4529 but it does (unless no_site_lisp is set) include site-lisp
4530 directories in the source/build directories if those exist and we
4531 are running uninstalled.
4532
4533 Uses the following logic:
4534 If !will_dump: Use PATH_LOADSEARCH.
4535 The remainder is what happens when dumping is about to happen:
4536 If dumping, just use PATH_DUMPLOADSEARCH.
4537 Otherwise use PATH_LOADSEARCH.
4538
4539 If !initialized, then just return PATH_DUMPLOADSEARCH.
4540 If initialized:
4541 If Vinstallation_directory is not nil (ie, running uninstalled):
4542 If installation-dir/lisp exists and not already a member,
4543 we must be running uninstalled. Reset the load-path
4544 to just installation-dir/lisp. (The default PATH_LOADSEARCH
4545 refers to the eventual installation directories. Since we
4546 are not yet installed, we should not use them, even if they exist.)
4547 If installation-dir/lisp does not exist, just add
4548 PATH_DUMPLOADSEARCH at the end instead.
4549 Add installation-dir/site-lisp (if !no_site_lisp, and exists
4550 and not already a member) at the front.
4551 If installation-dir != source-dir (ie running an uninstalled,
4552 out-of-tree build) AND install-dir/src/Makefile exists BUT
4553 install-dir/src/Makefile.in does NOT exist (this is a sanity
4554 check), then repeat the above steps for source-dir/lisp, site-lisp. */
4555
4556 static Lisp_Object
load_path_default(void)4557 load_path_default (void)
4558 {
4559 if (will_dump_p ())
4560 /* PATH_DUMPLOADSEARCH is the lisp dir in the source directory.
4561 We used to add ../lisp (ie the lisp dir in the build
4562 directory) at the front here, but that should not be
4563 necessary, since in out of tree builds lisp/ is empty, save
4564 for Makefile. */
4565 return decode_env_path (0, PATH_DUMPLOADSEARCH, 0);
4566
4567 Lisp_Object lpath = Qnil;
4568 const char *normal = PATH_LOADSEARCH;
4569 const char *loadpath = NULL;
4570
4571 #ifdef HAVE_NS
4572 loadpath = ns_load_path ();
4573 #endif
4574
4575 lpath = decode_env_path (0, loadpath ? loadpath : normal, 0);
4576
4577 if (!NILP (Vinstallation_directory))
4578 {
4579 Lisp_Object tem, tem1;
4580
4581 /* Add to the path the lisp subdir of the installation
4582 dir, if it is accessible. Note: in out-of-tree builds,
4583 this directory is empty save for Makefile. */
4584 tem = Fexpand_file_name (build_string ("lisp"),
4585 Vinstallation_directory);
4586 tem1 = Ffile_accessible_directory_p (tem);
4587 if (!NILP (tem1))
4588 {
4589 if (NILP (Fmember (tem, lpath)))
4590 {
4591 /* We are running uninstalled. The default load-path
4592 points to the eventual installed lisp directories.
4593 We should not use those now, even if they exist,
4594 so start over from a clean slate. */
4595 lpath = list1 (tem);
4596 }
4597 }
4598 else
4599 /* That dir doesn't exist, so add the build-time
4600 Lisp dirs instead. */
4601 {
4602 Lisp_Object dump_path =
4603 decode_env_path (0, PATH_DUMPLOADSEARCH, 0);
4604 lpath = nconc2 (lpath, dump_path);
4605 }
4606
4607 /* Add site-lisp under the installation dir, if it exists. */
4608 if (!no_site_lisp)
4609 {
4610 tem = Fexpand_file_name (build_string ("site-lisp"),
4611 Vinstallation_directory);
4612 tem1 = Ffile_accessible_directory_p (tem);
4613 if (!NILP (tem1))
4614 {
4615 if (NILP (Fmember (tem, lpath)))
4616 lpath = Fcons (tem, lpath);
4617 }
4618 }
4619
4620 /* If Emacs was not built in the source directory,
4621 and it is run from where it was built, add to load-path
4622 the lisp and site-lisp dirs under that directory. */
4623
4624 if (NILP (Fequal (Vinstallation_directory, Vsource_directory)))
4625 {
4626 Lisp_Object tem2;
4627
4628 tem = Fexpand_file_name (build_string ("src/Makefile"),
4629 Vinstallation_directory);
4630 tem1 = Ffile_exists_p (tem);
4631
4632 /* Don't be fooled if they moved the entire source tree
4633 AFTER dumping Emacs. If the build directory is indeed
4634 different from the source dir, src/Makefile.in and
4635 src/Makefile will not be found together. */
4636 tem = Fexpand_file_name (build_string ("src/Makefile.in"),
4637 Vinstallation_directory);
4638 tem2 = Ffile_exists_p (tem);
4639 if (!NILP (tem1) && NILP (tem2))
4640 {
4641 tem = Fexpand_file_name (build_string ("lisp"),
4642 Vsource_directory);
4643
4644 if (NILP (Fmember (tem, lpath)))
4645 lpath = Fcons (tem, lpath);
4646
4647 if (!no_site_lisp)
4648 {
4649 tem = Fexpand_file_name (build_string ("site-lisp"),
4650 Vsource_directory);
4651 tem1 = Ffile_accessible_directory_p (tem);
4652 if (!NILP (tem1))
4653 {
4654 if (NILP (Fmember (tem, lpath)))
4655 lpath = Fcons (tem, lpath);
4656 }
4657 }
4658 }
4659 } /* Vinstallation_directory != Vsource_directory */
4660
4661 } /* if Vinstallation_directory */
4662
4663 return lpath;
4664 }
4665
4666 void
init_lread(void)4667 init_lread (void)
4668 {
4669 /* First, set Vload_path. */
4670
4671 /* Ignore EMACSLOADPATH when dumping. */
4672 bool use_loadpath = !will_dump_p ();
4673
4674 if (use_loadpath && egetenv ("EMACSLOADPATH"))
4675 {
4676 Vload_path = decode_env_path ("EMACSLOADPATH", 0, 1);
4677
4678 /* Check (non-nil) user-supplied elements. */
4679 load_path_check (Vload_path);
4680
4681 /* If no nils in the environment variable, use as-is.
4682 Otherwise, replace any nils with the default. */
4683 if (! NILP (Fmemq (Qnil, Vload_path)))
4684 {
4685 Lisp_Object elem, elpath = Vload_path;
4686 Lisp_Object default_lpath = load_path_default ();
4687
4688 /* Check defaults, before adding site-lisp. */
4689 load_path_check (default_lpath);
4690
4691 /* Add the site-lisp directories to the front of the default. */
4692 if (!no_site_lisp && PATH_SITELOADSEARCH[0] != '\0')
4693 {
4694 Lisp_Object sitelisp;
4695 sitelisp = decode_env_path (0, PATH_SITELOADSEARCH, 0);
4696 if (! NILP (sitelisp))
4697 default_lpath = nconc2 (sitelisp, default_lpath);
4698 }
4699
4700 Vload_path = Qnil;
4701
4702 /* Replace nils from EMACSLOADPATH by default. */
4703 while (CONSP (elpath))
4704 {
4705 elem = XCAR (elpath);
4706 elpath = XCDR (elpath);
4707 Vload_path = CALLN (Fappend, Vload_path,
4708 NILP (elem) ? default_lpath : list1 (elem));
4709 }
4710 } /* Fmemq (Qnil, Vload_path) */
4711 }
4712 else
4713 {
4714 Vload_path = load_path_default ();
4715
4716 /* Check before adding site-lisp directories.
4717 The install should have created them, but they are not
4718 required, so no need to warn if they are absent.
4719 Or we might be running before installation. */
4720 load_path_check (Vload_path);
4721
4722 /* Add the site-lisp directories at the front. */
4723 if (!will_dump_p () && !no_site_lisp && PATH_SITELOADSEARCH[0] != '\0')
4724 {
4725 Lisp_Object sitelisp;
4726 sitelisp = decode_env_path (0, PATH_SITELOADSEARCH, 0);
4727 if (! NILP (sitelisp)) Vload_path = nconc2 (sitelisp, Vload_path);
4728 }
4729 }
4730
4731 Vvalues = Qnil;
4732
4733 load_in_progress = 0;
4734 Vload_file_name = Qnil;
4735 Vstandard_input = Qt;
4736 Vloads_in_progress = Qnil;
4737 }
4738
4739 /* Print a warning that directory intended for use USE and with name
4740 DIRNAME cannot be accessed. On entry, errno should correspond to
4741 the access failure. Print the warning on stderr and put it in
4742 *Messages*. */
4743
4744 void
dir_warning(char const * use,Lisp_Object dirname)4745 dir_warning (char const *use, Lisp_Object dirname)
4746 {
4747 static char const format[] = "Warning: %s '%s': %s\n";
4748 char *diagnostic = emacs_strerror (errno);
4749 fprintf (stderr, format, use, SSDATA (ENCODE_SYSTEM (dirname)), diagnostic);
4750
4751 /* Don't log the warning before we've initialized!! */
4752 if (initialized)
4753 {
4754 ptrdiff_t diaglen = strlen (diagnostic);
4755 AUTO_STRING_WITH_LEN (diag, diagnostic, diaglen);
4756 if (! NILP (Vlocale_coding_system))
4757 {
4758 Lisp_Object s
4759 = code_convert_string_norecord (diag, Vlocale_coding_system, false);
4760 diagnostic = SSDATA (s);
4761 diaglen = SBYTES (s);
4762 }
4763 USE_SAFE_ALLOCA;
4764 char *buffer = SAFE_ALLOCA (sizeof format - 3 * (sizeof "%s" - 1)
4765 + strlen (use) + SBYTES (dirname) + diaglen);
4766 ptrdiff_t message_len = esprintf (buffer, format, use, SSDATA (dirname),
4767 diagnostic);
4768 message_dolog (buffer, message_len, 0, STRING_MULTIBYTE (dirname));
4769 SAFE_FREE ();
4770 }
4771 }
4772
4773 void
syms_of_lread(void)4774 syms_of_lread (void)
4775 {
4776 defsubr (&Sread);
4777 defsubr (&Sread_from_string);
4778 defsubr (&Slread__substitute_object_in_subtree);
4779 defsubr (&Sintern);
4780 defsubr (&Sintern_soft);
4781 defsubr (&Sunintern);
4782 defsubr (&Sget_load_suffixes);
4783 defsubr (&Sload);
4784 defsubr (&Seval_buffer);
4785 defsubr (&Seval_region);
4786 defsubr (&Sread_char);
4787 defsubr (&Sread_char_exclusive);
4788 defsubr (&Sread_event);
4789 defsubr (&Sget_file_char);
4790 defsubr (&Smapatoms);
4791 defsubr (&Slocate_file_internal);
4792
4793 DEFVAR_LISP ("obarray", Vobarray,
4794 doc: /* Symbol table for use by `intern' and `read'.
4795 It is a vector whose length ought to be prime for best results.
4796 The vector's contents don't make sense if examined from Lisp programs;
4797 to find all the symbols in an obarray, use `mapatoms'. */);
4798
4799 DEFVAR_LISP ("values", Vvalues,
4800 doc: /* List of values of all expressions which were read, evaluated and printed.
4801 Order is reverse chronological. */);
4802 XSYMBOL (intern ("values"))->u.s.declared_special = false;
4803
4804 DEFVAR_LISP ("standard-input", Vstandard_input,
4805 doc: /* Stream for read to get input from.
4806 See documentation of `read' for possible values. */);
4807 Vstandard_input = Qt;
4808
4809 DEFVAR_LISP ("read-with-symbol-positions", Vread_with_symbol_positions,
4810 doc: /* If non-nil, add position of read symbols to `read-symbol-positions-list'.
4811
4812 If this variable is a buffer, then only forms read from that buffer
4813 will be added to `read-symbol-positions-list'.
4814 If this variable is t, then all read forms will be added.
4815 The effect of all other values other than nil are not currently
4816 defined, although they may be in the future.
4817
4818 The positions are relative to the last call to `read' or
4819 `read-from-string'. It is probably a bad idea to set this variable at
4820 the toplevel; bind it instead. */);
4821 Vread_with_symbol_positions = Qnil;
4822
4823 DEFVAR_LISP ("read-symbol-positions-list", Vread_symbol_positions_list,
4824 doc: /* A list mapping read symbols to their positions.
4825 This variable is modified during calls to `read' or
4826 `read-from-string', but only when `read-with-symbol-positions' is
4827 non-nil.
4828
4829 Each element of the list looks like (SYMBOL . CHAR-POSITION), where
4830 CHAR-POSITION is an integer giving the offset of that occurrence of the
4831 symbol from the position where `read' or `read-from-string' started.
4832
4833 Note that a symbol will appear multiple times in this list, if it was
4834 read multiple times. The list is in the same order as the symbols
4835 were read in. */);
4836 Vread_symbol_positions_list = Qnil;
4837
4838 DEFVAR_LISP ("read-circle", Vread_circle,
4839 doc: /* Non-nil means read recursive structures using #N= and #N# syntax. */);
4840 Vread_circle = Qt;
4841
4842 DEFVAR_LISP ("load-path", Vload_path,
4843 doc: /* List of directories to search for files to load.
4844 Each element is a string (directory file name) or nil (meaning
4845 `default-directory').
4846 This list is consulted by the `require' function.
4847 Initialized during startup as described in Info node `(elisp)Library Search'.
4848 Use `directory-file-name' when adding items to this path. However, Lisp
4849 programs that process this list should tolerate directories both with
4850 and without trailing slashes. */);
4851
4852 DEFVAR_LISP ("load-suffixes", Vload_suffixes,
4853 doc: /* List of suffixes for Emacs Lisp files and dynamic modules.
4854 This list includes suffixes for both compiled and source Emacs Lisp files.
4855 This list should not include the empty string.
4856 `load' and related functions try to append these suffixes, in order,
4857 to the specified file name if a suffix is allowed or required. */);
4858 #ifdef HAVE_MODULES
4859 Vload_suffixes = list3 (build_pure_c_string (".elc"),
4860 build_pure_c_string (".el"),
4861 build_pure_c_string (MODULES_SUFFIX));
4862 #else
4863 Vload_suffixes = list2 (build_pure_c_string (".elc"),
4864 build_pure_c_string (".el"));
4865 #endif
4866 DEFVAR_LISP ("module-file-suffix", Vmodule_file_suffix,
4867 doc: /* Suffix of loadable module file, or nil if modules are not supported. */);
4868 #ifdef HAVE_MODULES
4869 Vmodule_file_suffix = build_pure_c_string (MODULES_SUFFIX);
4870 #else
4871 Vmodule_file_suffix = Qnil;
4872 #endif
4873 DEFVAR_LISP ("load-file-rep-suffixes", Vload_file_rep_suffixes,
4874 doc: /* List of suffixes that indicate representations of \
4875 the same file.
4876 This list should normally start with the empty string.
4877
4878 Enabling Auto Compression mode appends the suffixes in
4879 `jka-compr-load-suffixes' to this list and disabling Auto Compression
4880 mode removes them again. `load' and related functions use this list to
4881 determine whether they should look for compressed versions of a file
4882 and, if so, which suffixes they should try to append to the file name
4883 in order to do so. However, if you want to customize which suffixes
4884 the loading functions recognize as compression suffixes, you should
4885 customize `jka-compr-load-suffixes' rather than the present variable. */);
4886 Vload_file_rep_suffixes = list1 (empty_unibyte_string);
4887
4888 DEFVAR_BOOL ("load-in-progress", load_in_progress,
4889 doc: /* Non-nil if inside of `load'. */);
4890 DEFSYM (Qload_in_progress, "load-in-progress");
4891
4892 DEFVAR_LISP ("after-load-alist", Vafter_load_alist,
4893 doc: /* An alist of functions to be evalled when particular files are loaded.
4894 Each element looks like (REGEXP-OR-FEATURE FUNCS...).
4895
4896 REGEXP-OR-FEATURE is either a regular expression to match file names, or
4897 a symbol (a feature name).
4898
4899 When `load' is run and the file-name argument matches an element's
4900 REGEXP-OR-FEATURE, or when `provide' is run and provides the symbol
4901 REGEXP-OR-FEATURE, the FUNCS in the element are called.
4902
4903 An error in FUNCS does not undo the load, but does prevent calling
4904 the rest of the FUNCS. */);
4905 Vafter_load_alist = Qnil;
4906
4907 DEFVAR_LISP ("load-history", Vload_history,
4908 doc: /* Alist mapping loaded file names to symbols and features.
4909 Each alist element should be a list (FILE-NAME ENTRIES...), where
4910 FILE-NAME is the name of a file that has been loaded into Emacs.
4911 The file name is absolute and true (i.e. it doesn't contain symlinks).
4912 As an exception, one of the alist elements may have FILE-NAME nil,
4913 for symbols and features not associated with any file.
4914
4915 The remaining ENTRIES in the alist element describe the functions and
4916 variables defined in that file, the features provided, and the
4917 features required. Each entry has the form `(provide . FEATURE)',
4918 `(require . FEATURE)', `(defun . FUNCTION)', `(autoload . SYMBOL)',
4919 `(defface . SYMBOL)', `(define-type . SYMBOL)',
4920 `(cl-defmethod METHOD SPECIALIZERS)', or `(t . SYMBOL)'.
4921 Entries like `(t . SYMBOL)' may precede a `(defun . FUNCTION)' entry,
4922 and mean that SYMBOL was an autoload before this file redefined it
4923 as a function. In addition, entries may also be single symbols,
4924 which means that symbol was defined by `defvar' or `defconst'.
4925
4926 During preloading, the file name recorded is relative to the main Lisp
4927 directory. These file names are converted to absolute at startup. */);
4928 Vload_history = Qnil;
4929
4930 DEFVAR_LISP ("load-file-name", Vload_file_name,
4931 doc: /* Full name of file being loaded by `load'. */);
4932 Vload_file_name = Qnil;
4933
4934 DEFVAR_LISP ("user-init-file", Vuser_init_file,
4935 doc: /* File name, including directory, of user's initialization file.
4936 If the file loaded had extension `.elc', and the corresponding source file
4937 exists, this variable contains the name of source file, suitable for use
4938 by functions like `custom-save-all' which edit the init file.
4939 While Emacs loads and evaluates any init file, value is the real name
4940 of the file, regardless of whether or not it has the `.elc' extension. */);
4941 Vuser_init_file = Qnil;
4942
4943 DEFVAR_LISP ("current-load-list", Vcurrent_load_list,
4944 doc: /* Used for internal purposes by `load'. */);
4945 Vcurrent_load_list = Qnil;
4946
4947 DEFVAR_LISP ("load-read-function", Vload_read_function,
4948 doc: /* Function used by `load' and `eval-region' for reading expressions.
4949 Called with a single argument (the stream from which to read).
4950 The default is to use the function `read'. */);
4951 DEFSYM (Qread, "read");
4952 Vload_read_function = Qread;
4953
4954 DEFVAR_LISP ("load-source-file-function", Vload_source_file_function,
4955 doc: /* Function called in `load' to load an Emacs Lisp source file.
4956 The value should be a function for doing code conversion before
4957 reading a source file. It can also be nil, in which case loading is
4958 done without any code conversion.
4959
4960 If the value is a function, it is called with four arguments,
4961 FULLNAME, FILE, NOERROR, NOMESSAGE. FULLNAME is the absolute name of
4962 the file to load, FILE is the non-absolute name (for messages etc.),
4963 and NOERROR and NOMESSAGE are the corresponding arguments passed to
4964 `load'. The function should return t if the file was loaded. */);
4965 Vload_source_file_function = Qnil;
4966
4967 DEFVAR_BOOL ("load-force-doc-strings", load_force_doc_strings,
4968 doc: /* Non-nil means `load' should force-load all dynamic doc strings.
4969 This is useful when the file being loaded is a temporary copy. */);
4970 load_force_doc_strings = 0;
4971
4972 DEFVAR_BOOL ("load-convert-to-unibyte", load_convert_to_unibyte,
4973 doc: /* Non-nil means `read' converts strings to unibyte whenever possible.
4974 This is normally bound by `load' and `eval-buffer' to control `read',
4975 and is not meant for users to change. */);
4976 load_convert_to_unibyte = 0;
4977
4978 DEFVAR_LISP ("source-directory", Vsource_directory,
4979 doc: /* Directory in which Emacs sources were found when Emacs was built.
4980 You cannot count on them to still be there! */);
4981 Vsource_directory
4982 = Fexpand_file_name (build_string ("../"),
4983 Fcar (decode_env_path (0, PATH_DUMPLOADSEARCH, 0)));
4984
4985 DEFVAR_LISP ("preloaded-file-list", Vpreloaded_file_list,
4986 doc: /* List of files that were preloaded (when dumping Emacs). */);
4987 Vpreloaded_file_list = Qnil;
4988
4989 DEFVAR_LISP ("byte-boolean-vars", Vbyte_boolean_vars,
4990 doc: /* List of all DEFVAR_BOOL variables, used by the byte code optimizer. */);
4991 Vbyte_boolean_vars = Qnil;
4992
4993 DEFVAR_BOOL ("load-dangerous-libraries", load_dangerous_libraries,
4994 doc: /* Non-nil means load dangerous compiled Lisp files.
4995 Some versions of XEmacs use different byte codes than Emacs. These
4996 incompatible byte codes can make Emacs crash when it tries to execute
4997 them. */);
4998 load_dangerous_libraries = 0;
4999
5000 DEFVAR_BOOL ("force-load-messages", force_load_messages,
5001 doc: /* Non-nil means force printing messages when loading Lisp files.
5002 This overrides the value of the NOMESSAGE argument to `load'. */);
5003 force_load_messages = 0;
5004
5005 DEFVAR_LISP ("bytecomp-version-regexp", Vbytecomp_version_regexp,
5006 doc: /* Regular expression matching safe to load compiled Lisp files.
5007 When Emacs loads a compiled Lisp file, it reads the first 512 bytes
5008 from the file, and matches them against this regular expression.
5009 When the regular expression matches, the file is considered to be safe
5010 to load. See also `load-dangerous-libraries'. */);
5011 Vbytecomp_version_regexp
5012 = build_pure_c_string ("^;;;.\\(in Emacs version\\|bytecomp version FSF\\)");
5013
5014 DEFSYM (Qlexical_binding, "lexical-binding");
5015 DEFVAR_LISP ("lexical-binding", Vlexical_binding,
5016 doc: /* Whether to use lexical binding when evaluating code.
5017 Non-nil means that the code in the current buffer should be evaluated
5018 with lexical binding.
5019 This variable is automatically set from the file variables of an
5020 interpreted Lisp file read using `load'. Unlike other file local
5021 variables, this must be set in the first line of a file. */);
5022 Vlexical_binding = Qnil;
5023 Fmake_variable_buffer_local (Qlexical_binding);
5024
5025 DEFVAR_LISP ("eval-buffer-list", Veval_buffer_list,
5026 doc: /* List of buffers being read from by calls to `eval-buffer' and `eval-region'. */);
5027 Veval_buffer_list = Qnil;
5028
5029 DEFVAR_LISP ("lread--unescaped-character-literals",
5030 Vlread_unescaped_character_literals,
5031 doc: /* List of deprecated unescaped character literals encountered by `read'.
5032 For internal use only. */);
5033 Vlread_unescaped_character_literals = Qnil;
5034 DEFSYM (Qlread_unescaped_character_literals,
5035 "lread--unescaped-character-literals");
5036
5037 /* Defined in lisp/emacs-lisp/byte-run.el. */
5038 DEFSYM (Qbyte_run_unescaped_character_literals_warning,
5039 "byte-run--unescaped-character-literals-warning");
5040
5041 DEFVAR_BOOL ("load-prefer-newer", load_prefer_newer,
5042 doc: /* Non-nil means `load' prefers the newest version of a file.
5043 This applies when a filename suffix is not explicitly specified and
5044 `load' is trying various possible suffixes (see `load-suffixes' and
5045 `load-file-rep-suffixes'). Normally, it stops at the first file
5046 that exists unless you explicitly specify one or the other. If this
5047 option is non-nil, it checks all suffixes and uses whichever file is
5048 newest.
5049 Note that if you customize this, obviously it will not affect files
5050 that are loaded before your customizations are read! */);
5051 load_prefer_newer = 0;
5052
5053 DEFVAR_BOOL ("force-new-style-backquotes", force_new_style_backquotes,
5054 doc: /* Non-nil means to always use the current syntax for backquotes.
5055 If nil, `load' and `read' raise errors when encountering some
5056 old-style variants of backquote and comma. If non-nil, these
5057 constructs are always interpreted as described in the Info node
5058 `(elisp)Backquote', even if that interpretation is incompatible with
5059 previous versions of Emacs. Setting this variable to non-nil makes
5060 Emacs compatible with the behavior planned for Emacs 28. In Emacs 28,
5061 this variable will become obsolete. */);
5062 force_new_style_backquotes = false;
5063
5064 /* Vsource_directory was initialized in init_lread. */
5065
5066 DEFSYM (Qcurrent_load_list, "current-load-list");
5067 DEFSYM (Qstandard_input, "standard-input");
5068 DEFSYM (Qread_char, "read-char");
5069 DEFSYM (Qget_file_char, "get-file-char");
5070
5071 /* Used instead of Qget_file_char while loading *.elc files compiled
5072 by Emacs 21 or older. */
5073 DEFSYM (Qget_emacs_mule_file_char, "get-emacs-mule-file-char");
5074
5075 DEFSYM (Qload_force_doc_strings, "load-force-doc-strings");
5076
5077 DEFSYM (Qbackquote, "`");
5078 DEFSYM (Qcomma, ",");
5079 DEFSYM (Qcomma_at, ",@");
5080
5081 DEFSYM (Qinhibit_file_name_operation, "inhibit-file-name-operation");
5082 DEFSYM (Qascii_character, "ascii-character");
5083 DEFSYM (Qfunction, "function");
5084 DEFSYM (Qload, "load");
5085 DEFSYM (Qload_file_name, "load-file-name");
5086 DEFSYM (Qeval_buffer_list, "eval-buffer-list");
5087 DEFSYM (Qdir_ok, "dir-ok");
5088 DEFSYM (Qdo_after_load_evaluation, "do-after-load-evaluation");
5089
5090 staticpro (&read_objects_map);
5091 read_objects_map = Qnil;
5092 staticpro (&read_objects_completed);
5093 read_objects_completed = Qnil;
5094
5095 Vloads_in_progress = Qnil;
5096 staticpro (&Vloads_in_progress);
5097
5098 DEFSYM (Qhash_table, "hash-table");
5099 DEFSYM (Qdata, "data");
5100 DEFSYM (Qtest, "test");
5101 DEFSYM (Qsize, "size");
5102 DEFSYM (Qpurecopy, "purecopy");
5103 DEFSYM (Qweakness, "weakness");
5104 DEFSYM (Qrehash_size, "rehash-size");
5105 DEFSYM (Qrehash_threshold, "rehash-threshold");
5106
5107 DEFSYM (Qchar_from_name, "char-from-name");
5108 }
5109