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