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