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