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