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