* files.el (hack-local-variables-prop-line)
[emacs.git] / src / lread.c
blobcb3f5b046333fe37c46b9b1289bbba9534b08419
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, 2009 Free Software Foundation, Inc.
6 This file is part of GNU Emacs.
8 GNU Emacs is free software: you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation, either version 3 of the License, or
11 (at your option) any later version.
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.
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
22 #include <config.h>
23 #include <stdio.h>
24 #include <sys/types.h>
25 #include <sys/stat.h>
26 #include <sys/file.h>
27 #include <errno.h>
28 #include <setjmp.h>
29 #include "lisp.h"
30 #include "intervals.h"
31 #include "buffer.h"
32 #include "character.h"
33 #include "charset.h"
34 #include "coding.h"
35 #include <epaths.h>
36 #include "commands.h"
37 #include "keyboard.h"
38 #include "frame.h"
39 #include "termhooks.h"
40 #include "coding.h"
41 #include "blockinput.h"
43 #ifdef MSDOS
44 #if __DJGPP__ < 2
45 #include <unistd.h> /* to get X_OK */
46 #endif
47 #include "msdos.h"
48 #endif
50 #ifdef HAVE_UNISTD_H
51 #include <unistd.h>
52 #endif
54 #ifndef X_OK
55 #define X_OK 01
56 #endif
58 #include <math.h>
60 #ifdef HAVE_SETLOCALE
61 #include <locale.h>
62 #endif /* HAVE_SETLOCALE */
64 #ifdef HAVE_FCNTL_H
65 #include <fcntl.h>
66 #endif
67 #ifndef O_RDONLY
68 #define O_RDONLY 0
69 #endif
71 #ifdef HAVE_FSEEKO
72 #define file_offset off_t
73 #define file_tell ftello
74 #else
75 #define file_offset long
76 #define file_tell ftell
77 #endif
79 #ifndef USE_CRT_DLL
80 extern int errno;
81 #endif
83 Lisp_Object Qread_char, Qget_file_char, Qstandard_input, Qcurrent_load_list;
84 Lisp_Object Qvariable_documentation, Vvalues, Vstandard_input, Vafter_load_alist;
85 Lisp_Object Qascii_character, Qload, Qload_file_name;
86 Lisp_Object Qbackquote, Qcomma, Qcomma_at, Qcomma_dot, Qfunction;
87 Lisp_Object Qinhibit_file_name_operation;
88 Lisp_Object Qeval_buffer_list, Veval_buffer_list;
89 Lisp_Object Qfile_truename, Qdo_after_load_evaluation; /* ACM 2006/5/16 */
91 /* Used instead of Qget_file_char while loading *.elc files compiled
92 by Emacs 21 or older. */
93 static Lisp_Object Qget_emacs_mule_file_char;
95 static Lisp_Object Qload_force_doc_strings;
97 extern Lisp_Object Qevent_symbol_element_mask;
98 extern Lisp_Object Qfile_exists_p;
100 /* non-zero if inside `load' */
101 int load_in_progress;
103 /* Directory in which the sources were found. */
104 Lisp_Object Vsource_directory;
106 /* Search path and suffixes for files to be loaded. */
107 Lisp_Object Vload_path, Vload_suffixes, Vload_file_rep_suffixes;
109 /* File name of user's init file. */
110 Lisp_Object Vuser_init_file;
112 /* This is the user-visible association list that maps features to
113 lists of defs in their load files. */
114 Lisp_Object Vload_history;
116 /* This is used to build the load history. */
117 Lisp_Object Vcurrent_load_list;
119 /* List of files that were preloaded. */
120 Lisp_Object Vpreloaded_file_list;
122 /* Name of file actually being read by `load'. */
123 Lisp_Object Vload_file_name;
125 /* Function to use for reading, in `load' and friends. */
126 Lisp_Object Vload_read_function;
128 /* Non-nil means read recursive structures using #n= and #n# syntax. */
129 Lisp_Object Vread_circle;
131 /* The association list of objects read with the #n=object form.
132 Each member of the list has the form (n . object), and is used to
133 look up the object for the corresponding #n# construct.
134 It must be set to nil before all top-level calls to read0. */
135 Lisp_Object read_objects;
137 /* Nonzero means load should forcibly load all dynamic doc strings. */
138 static int load_force_doc_strings;
140 /* Nonzero means read should convert strings to unibyte. */
141 static int load_convert_to_unibyte;
143 /* Nonzero means READCHAR should read bytes one by one (not character)
144 when READCHARFUN is Qget_file_char or Qget_emacs_mule_file_char.
145 This is set to 1 by read1 temporarily while handling #@NUMBER. */
146 static int load_each_byte;
148 /* Function to use for loading an Emacs Lisp source file (not
149 compiled) instead of readevalloop. */
150 Lisp_Object Vload_source_file_function;
152 /* List of all DEFVAR_BOOL variables. Used by the byte optimizer. */
153 Lisp_Object Vbyte_boolean_vars;
155 /* Whether or not to add a `read-positions' property to symbols
156 read. */
157 Lisp_Object Vread_with_symbol_positions;
159 /* List of (SYMBOL . POSITION) accumulated so far. */
160 Lisp_Object Vread_symbol_positions_list;
162 /* List of descriptors now open for Fload. */
163 static Lisp_Object load_descriptor_list;
165 /* File for get_file_char to read from. Use by load. */
166 static FILE *instream;
168 /* When nonzero, read conses in pure space */
169 static int read_pure;
171 /* For use within read-from-string (this reader is non-reentrant!!) */
172 static int read_from_string_index;
173 static int read_from_string_index_byte;
174 static int read_from_string_limit;
176 /* Number of characters read in the current call to Fread or
177 Fread_from_string. */
178 static int readchar_count;
180 /* This contains the last string skipped with #@. */
181 static char *saved_doc_string;
182 /* Length of buffer allocated in saved_doc_string. */
183 static int saved_doc_string_size;
184 /* Length of actual data in saved_doc_string. */
185 static int saved_doc_string_length;
186 /* This is the file position that string came from. */
187 static file_offset saved_doc_string_position;
189 /* This contains the previous string skipped with #@.
190 We copy it from saved_doc_string when a new string
191 is put in saved_doc_string. */
192 static char *prev_saved_doc_string;
193 /* Length of buffer allocated in prev_saved_doc_string. */
194 static int prev_saved_doc_string_size;
195 /* Length of actual data in prev_saved_doc_string. */
196 static int prev_saved_doc_string_length;
197 /* This is the file position that string came from. */
198 static file_offset prev_saved_doc_string_position;
200 /* Nonzero means inside a new-style backquote
201 with no surrounding parentheses.
202 Fread initializes this to zero, so we need not specbind it
203 or worry about what happens to it when there is an error. */
204 static int new_backquote_flag;
205 static Lisp_Object Vold_style_backquotes, Qold_style_backquotes;
207 /* A list of file names for files being loaded in Fload. Used to
208 check for recursive loads. */
210 static Lisp_Object Vloads_in_progress;
212 /* Non-zero means load dangerous compiled Lisp files. */
214 int load_dangerous_libraries;
216 /* A regular expression used to detect files compiled with Emacs. */
218 static Lisp_Object Vbytecomp_version_regexp;
220 static int read_emacs_mule_char P_ ((int, int (*) (int, Lisp_Object),
221 Lisp_Object));
223 static void readevalloop P_ ((Lisp_Object, FILE*, Lisp_Object,
224 Lisp_Object (*) (), int,
225 Lisp_Object, Lisp_Object,
226 Lisp_Object, Lisp_Object));
227 static Lisp_Object load_unwind P_ ((Lisp_Object));
228 static Lisp_Object load_descriptor_unwind P_ ((Lisp_Object));
230 static void invalid_syntax P_ ((const char *, int)) NO_RETURN;
231 static void end_of_file_error P_ (()) NO_RETURN;
234 /* Functions that read one byte from the current source READCHARFUN
235 or unreads one byte. If the integer argument C is -1, it returns
236 one read byte, or -1 when there's no more byte in the source. If C
237 is 0 or positive, it unreads C, and the return value is not
238 interesting. */
240 static int readbyte_for_lambda P_ ((int, Lisp_Object));
241 static int readbyte_from_file P_ ((int, Lisp_Object));
242 static int readbyte_from_string P_ ((int, Lisp_Object));
244 /* Handle unreading and rereading of characters.
245 Write READCHAR to read a character,
246 UNREAD(c) to unread c to be read again.
248 These macros correctly read/unread multibyte characters. */
250 #define READCHAR readchar (readcharfun, NULL)
251 #define UNREAD(c) unreadchar (readcharfun, c)
253 /* Same as READCHAR but set *MULTIBYTE to the multibyteness of the source. */
254 #define READCHAR_REPORT_MULTIBYTE(multibyte) readchar (readcharfun, multibyte)
256 /* When READCHARFUN is Qget_file_char, Qget_emacs_mule_file_char,
257 Qlambda, or a cons, we use this to keep an unread character because
258 a file stream can't handle multibyte-char unreading. The value -1
259 means that there's no unread character. */
260 static int unread_char;
262 static int
263 readchar (readcharfun, multibyte)
264 Lisp_Object readcharfun;
265 int *multibyte;
267 Lisp_Object tem;
268 register int c;
269 int (*readbyte) P_ ((int, Lisp_Object));
270 unsigned char buf[MAX_MULTIBYTE_LENGTH];
271 int i, len;
272 int emacs_mule_encoding = 0;
274 if (multibyte)
275 *multibyte = 0;
277 readchar_count++;
279 if (BUFFERP (readcharfun))
281 register struct buffer *inbuffer = XBUFFER (readcharfun);
283 int pt_byte = BUF_PT_BYTE (inbuffer);
285 if (pt_byte >= BUF_ZV_BYTE (inbuffer))
286 return -1;
288 if (! NILP (inbuffer->enable_multibyte_characters))
290 /* Fetch the character code from the buffer. */
291 unsigned char *p = BUF_BYTE_ADDRESS (inbuffer, pt_byte);
292 BUF_INC_POS (inbuffer, pt_byte);
293 c = STRING_CHAR (p, pt_byte - orig_pt_byte);
294 if (multibyte)
295 *multibyte = 1;
297 else
299 c = BUF_FETCH_BYTE (inbuffer, pt_byte);
300 if (! ASCII_BYTE_P (c))
301 c = BYTE8_TO_CHAR (c);
302 pt_byte++;
304 SET_BUF_PT_BOTH (inbuffer, BUF_PT (inbuffer) + 1, pt_byte);
306 return c;
308 if (MARKERP (readcharfun))
310 register struct buffer *inbuffer = XMARKER (readcharfun)->buffer;
312 int bytepos = marker_byte_position (readcharfun);
314 if (bytepos >= BUF_ZV_BYTE (inbuffer))
315 return -1;
317 if (! NILP (inbuffer->enable_multibyte_characters))
319 /* Fetch the character code from the buffer. */
320 unsigned char *p = BUF_BYTE_ADDRESS (inbuffer, bytepos);
321 BUF_INC_POS (inbuffer, bytepos);
322 c = STRING_CHAR (p, bytepos - orig_bytepos);
323 if (multibyte)
324 *multibyte = 1;
326 else
328 c = BUF_FETCH_BYTE (inbuffer, bytepos);
329 if (! ASCII_BYTE_P (c))
330 c = BYTE8_TO_CHAR (c);
331 bytepos++;
334 XMARKER (readcharfun)->bytepos = bytepos;
335 XMARKER (readcharfun)->charpos++;
337 return c;
340 if (EQ (readcharfun, Qlambda))
342 readbyte = readbyte_for_lambda;
343 goto read_multibyte;
346 if (EQ (readcharfun, Qget_file_char))
348 readbyte = readbyte_from_file;
349 goto read_multibyte;
352 if (STRINGP (readcharfun))
354 if (read_from_string_index >= read_from_string_limit)
355 c = -1;
356 else if (STRING_MULTIBYTE (readcharfun))
358 if (multibyte)
359 *multibyte = 1;
360 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c, readcharfun,
361 read_from_string_index,
362 read_from_string_index_byte);
364 else
366 c = SREF (readcharfun, read_from_string_index_byte);
367 read_from_string_index++;
368 read_from_string_index_byte++;
370 return c;
373 if (CONSP (readcharfun))
375 /* This is the case that read_vector is reading from a unibyte
376 string that contains a byte sequence previously skipped
377 because of #@NUMBER. The car part of readcharfun is that
378 string, and the cdr part is a value of readcharfun given to
379 read_vector. */
380 readbyte = readbyte_from_string;
381 if (EQ (XCDR (readcharfun), Qget_emacs_mule_file_char))
382 emacs_mule_encoding = 1;
383 goto read_multibyte;
386 if (EQ (readcharfun, Qget_emacs_mule_file_char))
388 readbyte = readbyte_from_file;
389 emacs_mule_encoding = 1;
390 goto read_multibyte;
393 tem = call0 (readcharfun);
395 if (NILP (tem))
396 return -1;
397 return XINT (tem);
399 read_multibyte:
400 if (unread_char >= 0)
402 c = unread_char;
403 unread_char = -1;
404 return c;
406 c = (*readbyte) (-1, readcharfun);
407 if (c < 0 || load_each_byte)
408 return c;
409 if (multibyte)
410 *multibyte = 1;
411 if (ASCII_BYTE_P (c))
412 return c;
413 if (emacs_mule_encoding)
414 return read_emacs_mule_char (c, readbyte, readcharfun);
415 i = 0;
416 buf[i++] = c;
417 len = BYTES_BY_CHAR_HEAD (c);
418 while (i < len)
420 c = (*readbyte) (-1, readcharfun);
421 if (c < 0 || ! TRAILING_CODE_P (c))
423 while (--i > 1)
424 (*readbyte) (buf[i], readcharfun);
425 return BYTE8_TO_CHAR (buf[0]);
427 buf[i++] = c;
429 return STRING_CHAR (buf, i);
432 /* Unread the character C in the way appropriate for the stream READCHARFUN.
433 If the stream is a user function, call it with the char as argument. */
435 static void
436 unreadchar (readcharfun, c)
437 Lisp_Object readcharfun;
438 int c;
440 readchar_count--;
441 if (c == -1)
442 /* Don't back up the pointer if we're unreading the end-of-input mark,
443 since readchar didn't advance it when we read it. */
445 else if (BUFFERP (readcharfun))
447 struct buffer *b = XBUFFER (readcharfun);
448 int bytepos = BUF_PT_BYTE (b);
450 BUF_PT (b)--;
451 if (! NILP (b->enable_multibyte_characters))
452 BUF_DEC_POS (b, bytepos);
453 else
454 bytepos--;
456 BUF_PT_BYTE (b) = bytepos;
458 else if (MARKERP (readcharfun))
460 struct buffer *b = XMARKER (readcharfun)->buffer;
461 int bytepos = XMARKER (readcharfun)->bytepos;
463 XMARKER (readcharfun)->charpos--;
464 if (! NILP (b->enable_multibyte_characters))
465 BUF_DEC_POS (b, bytepos);
466 else
467 bytepos--;
469 XMARKER (readcharfun)->bytepos = bytepos;
471 else if (STRINGP (readcharfun))
473 read_from_string_index--;
474 read_from_string_index_byte
475 = string_char_to_byte (readcharfun, read_from_string_index);
477 else if (CONSP (readcharfun))
479 unread_char = c;
481 else if (EQ (readcharfun, Qlambda))
483 unread_char = c;
485 else if (EQ (readcharfun, Qget_file_char)
486 || EQ (readcharfun, Qget_emacs_mule_file_char))
488 if (load_each_byte)
490 BLOCK_INPUT;
491 ungetc (c, instream);
492 UNBLOCK_INPUT;
494 else
495 unread_char = c;
497 else
498 call1 (readcharfun, make_number (c));
501 static int
502 readbyte_for_lambda (c, readcharfun)
503 int c;
504 Lisp_Object readcharfun;
506 return read_bytecode_char (c >= 0);
510 static int
511 readbyte_from_file (c, readcharfun)
512 int c;
513 Lisp_Object readcharfun;
515 if (c >= 0)
517 BLOCK_INPUT;
518 ungetc (c, instream);
519 UNBLOCK_INPUT;
520 return 0;
523 BLOCK_INPUT;
524 c = getc (instream);
526 #ifdef EINTR
527 /* Interrupted reads have been observed while reading over the network */
528 while (c == EOF && ferror (instream) && errno == EINTR)
530 UNBLOCK_INPUT;
531 QUIT;
532 BLOCK_INPUT;
533 clearerr (instream);
534 c = getc (instream);
536 #endif
538 UNBLOCK_INPUT;
540 return (c == EOF ? -1 : c);
543 static int
544 readbyte_from_string (c, readcharfun)
545 int c;
546 Lisp_Object readcharfun;
548 Lisp_Object string = XCAR (readcharfun);
550 if (c >= 0)
552 read_from_string_index--;
553 read_from_string_index_byte
554 = string_char_to_byte (string, read_from_string_index);
557 if (read_from_string_index >= read_from_string_limit)
558 c = -1;
559 else
560 FETCH_STRING_CHAR_ADVANCE (c, string,
561 read_from_string_index,
562 read_from_string_index_byte);
563 return c;
567 /* Read one non-ASCII character from INSTREAM. The character is
568 encoded in `emacs-mule' and the first byte is already read in
569 C. */
571 extern char emacs_mule_bytes[256];
573 static int
574 read_emacs_mule_char (c, readbyte, readcharfun)
575 int c;
576 int (*readbyte) P_ ((int, Lisp_Object));
577 Lisp_Object readcharfun;
579 /* Emacs-mule coding uses at most 4-byte for one character. */
580 unsigned char buf[4];
581 int len = emacs_mule_bytes[c];
582 struct charset *charset;
583 int i;
584 unsigned code;
586 if (len == 1)
587 /* C is not a valid leading-code of `emacs-mule'. */
588 return BYTE8_TO_CHAR (c);
590 i = 0;
591 buf[i++] = c;
592 while (i < len)
594 c = (*readbyte) (-1, readcharfun);
595 if (c < 0xA0)
597 while (--i > 1)
598 (*readbyte) (buf[i], readcharfun);
599 return BYTE8_TO_CHAR (buf[0]);
601 buf[i++] = c;
604 if (len == 2)
606 charset = emacs_mule_charset[buf[0]];
607 code = buf[1] & 0x7F;
609 else if (len == 3)
611 if (buf[0] == EMACS_MULE_LEADING_CODE_PRIVATE_11
612 || buf[0] == EMACS_MULE_LEADING_CODE_PRIVATE_12)
614 charset = emacs_mule_charset[buf[1]];
615 code = buf[2] & 0x7F;
617 else
619 charset = emacs_mule_charset[buf[0]];
620 code = ((buf[1] << 8) | buf[2]) & 0x7F7F;
623 else
625 charset = emacs_mule_charset[buf[1]];
626 code = ((buf[2] << 8) | buf[3]) & 0x7F7F;
628 c = DECODE_CHAR (charset, code);
629 if (c < 0)
630 Fsignal (Qinvalid_read_syntax,
631 Fcons (build_string ("invalid multibyte form"), Qnil));
632 return c;
636 static Lisp_Object read_internal_start P_ ((Lisp_Object, Lisp_Object,
637 Lisp_Object));
638 static Lisp_Object read0 P_ ((Lisp_Object));
639 static Lisp_Object read1 P_ ((Lisp_Object, int *, int));
641 static Lisp_Object read_list P_ ((int, Lisp_Object));
642 static Lisp_Object read_vector P_ ((Lisp_Object, int));
644 static Lisp_Object substitute_object_recurse P_ ((Lisp_Object, Lisp_Object,
645 Lisp_Object));
646 static void substitute_object_in_subtree P_ ((Lisp_Object,
647 Lisp_Object));
648 static void substitute_in_interval P_ ((INTERVAL, Lisp_Object));
651 /* Get a character from the tty. */
653 /* Read input events until we get one that's acceptable for our purposes.
655 If NO_SWITCH_FRAME is non-zero, switch-frame events are stashed
656 until we get a character we like, and then stuffed into
657 unread_switch_frame.
659 If ASCII_REQUIRED is non-zero, we check function key events to see
660 if the unmodified version of the symbol has a Qascii_character
661 property, and use that character, if present.
663 If ERROR_NONASCII is non-zero, we signal an error if the input we
664 get isn't an ASCII character with modifiers. If it's zero but
665 ASCII_REQUIRED is non-zero, we just re-read until we get an ASCII
666 character.
668 If INPUT_METHOD is nonzero, we invoke the current input method
669 if the character warrants that.
671 If SECONDS is a number, we wait that many seconds for input, and
672 return Qnil if no input arrives within that time. */
674 Lisp_Object
675 read_filtered_event (no_switch_frame, ascii_required, error_nonascii,
676 input_method, seconds)
677 int no_switch_frame, ascii_required, error_nonascii, input_method;
678 Lisp_Object seconds;
680 Lisp_Object val, delayed_switch_frame;
681 EMACS_TIME end_time;
683 #ifdef HAVE_WINDOW_SYSTEM
684 if (display_hourglass_p)
685 cancel_hourglass ();
686 #endif
688 delayed_switch_frame = Qnil;
690 /* Compute timeout. */
691 if (NUMBERP (seconds))
693 EMACS_TIME wait_time;
694 int sec, usec;
695 double duration = extract_float (seconds);
697 sec = (int) duration;
698 usec = (duration - sec) * 1000000;
699 EMACS_GET_TIME (end_time);
700 EMACS_SET_SECS_USECS (wait_time, sec, usec);
701 EMACS_ADD_TIME (end_time, end_time, wait_time);
704 /* Read until we get an acceptable event. */
705 retry:
707 val = read_char (0, 0, 0, (input_method ? Qnil : Qt), 0,
708 NUMBERP (seconds) ? &end_time : NULL);
709 while (INTEGERP (val) && XINT (val) == -2); /* wrong_kboard_jmpbuf */
711 if (BUFFERP (val))
712 goto retry;
714 /* switch-frame events are put off until after the next ASCII
715 character. This is better than signaling an error just because
716 the last characters were typed to a separate minibuffer frame,
717 for example. Eventually, some code which can deal with
718 switch-frame events will read it and process it. */
719 if (no_switch_frame
720 && EVENT_HAS_PARAMETERS (val)
721 && EQ (EVENT_HEAD_KIND (EVENT_HEAD (val)), Qswitch_frame))
723 delayed_switch_frame = val;
724 goto retry;
727 if (ascii_required && !(NUMBERP (seconds) && NILP (val)))
729 /* Convert certain symbols to their ASCII equivalents. */
730 if (SYMBOLP (val))
732 Lisp_Object tem, tem1;
733 tem = Fget (val, Qevent_symbol_element_mask);
734 if (!NILP (tem))
736 tem1 = Fget (Fcar (tem), Qascii_character);
737 /* Merge this symbol's modifier bits
738 with the ASCII equivalent of its basic code. */
739 if (!NILP (tem1))
740 XSETFASTINT (val, XINT (tem1) | XINT (Fcar (Fcdr (tem))));
744 /* If we don't have a character now, deal with it appropriately. */
745 if (!INTEGERP (val))
747 if (error_nonascii)
749 Vunread_command_events = Fcons (val, Qnil);
750 error ("Non-character input-event");
752 else
753 goto retry;
757 if (! NILP (delayed_switch_frame))
758 unread_switch_frame = delayed_switch_frame;
760 #if 0
762 #ifdef HAVE_WINDOW_SYSTEM
763 if (display_hourglass_p)
764 start_hourglass ();
765 #endif
767 #endif
769 return val;
772 DEFUN ("read-char", Fread_char, Sread_char, 0, 3, 0,
773 doc: /* Read a character from the command input (keyboard or macro).
774 It is returned as a number.
775 If the character has modifiers, they are resolved and reflected to the
776 character code if possible (e.g. C-SPC -> 0).
778 If the user generates an event which is not a character (i.e. a mouse
779 click or function key event), `read-char' signals an error. As an
780 exception, switch-frame events are put off until non-character events
781 can be read.
782 If you want to read non-character events, or ignore them, call
783 `read-event' or `read-char-exclusive' instead.
785 If the optional argument PROMPT is non-nil, display that as a prompt.
786 If the optional argument INHERIT-INPUT-METHOD is non-nil and some
787 input method is turned on in the current buffer, that input method
788 is used for reading a character.
789 If the optional argument SECONDS is non-nil, it should be a number
790 specifying the maximum number of seconds to wait for input. If no
791 input arrives in that time, return nil. SECONDS may be a
792 floating-point value. */)
793 (prompt, inherit_input_method, seconds)
794 Lisp_Object prompt, inherit_input_method, seconds;
796 Lisp_Object val;
798 if (! NILP (prompt))
799 message_with_string ("%s", prompt, 0);
800 val = read_filtered_event (1, 1, 1, ! NILP (inherit_input_method), seconds);
802 return (NILP (val) ? Qnil
803 : make_number (char_resolve_modifier_mask (XINT (val))));
806 DEFUN ("read-event", Fread_event, Sread_event, 0, 3, 0,
807 doc: /* Read an event object from the input stream.
808 If the optional argument PROMPT is non-nil, display that as a prompt.
809 If the optional argument INHERIT-INPUT-METHOD is non-nil and some
810 input method is turned on in the current buffer, that input method
811 is used for reading a character.
812 If the optional argument SECONDS is non-nil, it should be a number
813 specifying the maximum number of seconds to wait for input. If no
814 input arrives in that time, return nil. SECONDS may be a
815 floating-point value. */)
816 (prompt, inherit_input_method, seconds)
817 Lisp_Object prompt, inherit_input_method, seconds;
819 if (! NILP (prompt))
820 message_with_string ("%s", prompt, 0);
821 return read_filtered_event (0, 0, 0, ! NILP (inherit_input_method), seconds);
824 DEFUN ("read-char-exclusive", Fread_char_exclusive, Sread_char_exclusive, 0, 3, 0,
825 doc: /* Read a character from the command input (keyboard or macro).
826 It is returned as a number. Non-character events are ignored.
827 If the character has modifiers, they are resolved and reflected to the
828 character code if possible (e.g. C-SPC -> 0).
830 If the optional argument PROMPT is non-nil, display that as a prompt.
831 If the optional argument INHERIT-INPUT-METHOD is non-nil and some
832 input method is turned on in the current buffer, that input method
833 is used for reading a character.
834 If the optional argument SECONDS is non-nil, it should be a number
835 specifying the maximum number of seconds to wait for input. If no
836 input arrives in that time, return nil. SECONDS may be a
837 floating-point value. */)
838 (prompt, inherit_input_method, seconds)
839 Lisp_Object prompt, inherit_input_method, seconds;
841 Lisp_Object val;
843 if (! NILP (prompt))
844 message_with_string ("%s", prompt, 0);
846 val = read_filtered_event (1, 1, 0, ! NILP (inherit_input_method), seconds);
848 return (NILP (val) ? Qnil
849 : make_number (char_resolve_modifier_mask (XINT (val))));
852 DEFUN ("get-file-char", Fget_file_char, Sget_file_char, 0, 0, 0,
853 doc: /* Don't use this yourself. */)
856 register Lisp_Object val;
857 BLOCK_INPUT;
858 XSETINT (val, getc (instream));
859 UNBLOCK_INPUT;
860 return val;
865 /* Value is a version number of byte compiled code if the file
866 associated with file descriptor FD is a compiled Lisp file that's
867 safe to load. Only files compiled with Emacs are safe to load.
868 Files compiled with XEmacs can lead to a crash in Fbyte_code
869 because of an incompatible change in the byte compiler. */
871 static int
872 safe_to_load_p (fd)
873 int fd;
875 char buf[512];
876 int nbytes, i;
877 int safe_p = 1;
878 int version = 1;
880 /* Read the first few bytes from the file, and look for a line
881 specifying the byte compiler version used. */
882 nbytes = emacs_read (fd, buf, sizeof buf - 1);
883 if (nbytes > 0)
885 buf[nbytes] = '\0';
887 /* Skip to the next newline, skipping over the initial `ELC'
888 with NUL bytes following it, but note the version. */
889 for (i = 0; i < nbytes && buf[i] != '\n'; ++i)
890 if (i == 4)
891 version = buf[i];
893 if (i == nbytes
894 || fast_c_string_match_ignore_case (Vbytecomp_version_regexp,
895 buf + i) < 0)
896 safe_p = 0;
898 if (safe_p)
899 safe_p = version;
901 lseek (fd, 0, SEEK_SET);
902 return safe_p;
906 /* Callback for record_unwind_protect. Restore the old load list OLD,
907 after loading a file successfully. */
909 static Lisp_Object
910 record_load_unwind (old)
911 Lisp_Object old;
913 return Vloads_in_progress = old;
916 /* This handler function is used via internal_condition_case_1. */
918 static Lisp_Object
919 load_error_handler (data)
920 Lisp_Object data;
922 return Qnil;
925 static Lisp_Object
926 load_warn_old_style_backquotes (file)
927 Lisp_Object file;
929 if (!NILP (Vold_style_backquotes))
931 Lisp_Object args[2];
932 args[0] = build_string ("Loading `%s': old-style backquotes detected!");
933 args[1] = file;
934 Fmessage (2, args);
936 return Qnil;
939 DEFUN ("get-load-suffixes", Fget_load_suffixes, Sget_load_suffixes, 0, 0, 0,
940 doc: /* Return the suffixes that `load' should try if a suffix is \
941 required.
942 This uses the variables `load-suffixes' and `load-file-rep-suffixes'. */)
945 Lisp_Object lst = Qnil, suffixes = Vload_suffixes, suffix, ext;
946 while (CONSP (suffixes))
948 Lisp_Object exts = Vload_file_rep_suffixes;
949 suffix = XCAR (suffixes);
950 suffixes = XCDR (suffixes);
951 while (CONSP (exts))
953 ext = XCAR (exts);
954 exts = XCDR (exts);
955 lst = Fcons (concat2 (suffix, ext), lst);
958 return Fnreverse (lst);
961 DEFUN ("load", Fload, Sload, 1, 5, 0,
962 doc: /* Execute a file of Lisp code named FILE.
963 First try FILE with `.elc' appended, then try with `.el',
964 then try FILE unmodified (the exact suffixes in the exact order are
965 determined by `load-suffixes'). Environment variable references in
966 FILE are replaced with their values by calling `substitute-in-file-name'.
967 This function searches the directories in `load-path'.
969 If optional second arg NOERROR is non-nil,
970 report no error if FILE doesn't exist.
971 Print messages at start and end of loading unless
972 optional third arg NOMESSAGE is non-nil.
973 If optional fourth arg NOSUFFIX is non-nil, don't try adding
974 suffixes `.elc' or `.el' to the specified name FILE.
975 If optional fifth arg MUST-SUFFIX is non-nil, insist on
976 the suffix `.elc' or `.el'; don't accept just FILE unless
977 it ends in one of those suffixes or includes a directory name.
979 If this function fails to find a file, it may look for different
980 representations of that file before trying another file.
981 It does so by adding the non-empty suffixes in `load-file-rep-suffixes'
982 to the file name. Emacs uses this feature mainly to find compressed
983 versions of files when Auto Compression mode is enabled.
985 The exact suffixes that this function tries out, in the exact order,
986 are given by the value of the variable `load-file-rep-suffixes' if
987 NOSUFFIX is non-nil and by the return value of the function
988 `get-load-suffixes' if MUST-SUFFIX is non-nil. If both NOSUFFIX and
989 MUST-SUFFIX are nil, this function first tries out the latter suffixes
990 and then the former.
992 Loading a file records its definitions, and its `provide' and
993 `require' calls, in an element of `load-history' whose
994 car is the file name loaded. See `load-history'.
996 Return t if the file exists and loads successfully. */)
997 (file, noerror, nomessage, nosuffix, must_suffix)
998 Lisp_Object file, noerror, nomessage, nosuffix, must_suffix;
1000 register FILE *stream;
1001 register int fd = -1;
1002 int count = SPECPDL_INDEX ();
1003 struct gcpro gcpro1, gcpro2, gcpro3;
1004 Lisp_Object found, efound, hist_file_name;
1005 /* 1 means we printed the ".el is newer" message. */
1006 int newer = 0;
1007 /* 1 means we are loading a compiled file. */
1008 int compiled = 0;
1009 Lisp_Object handler;
1010 int safe_p = 1;
1011 char *fmode = "r";
1012 Lisp_Object tmp[2];
1013 int version;
1015 #ifdef DOS_NT
1016 fmode = "rt";
1017 #endif /* DOS_NT */
1019 CHECK_STRING (file);
1021 /* If file name is magic, call the handler. */
1022 /* This shouldn't be necessary any more now that `openp' handles it right.
1023 handler = Ffind_file_name_handler (file, Qload);
1024 if (!NILP (handler))
1025 return call5 (handler, Qload, file, noerror, nomessage, nosuffix); */
1027 /* Do this after the handler to avoid
1028 the need to gcpro noerror, nomessage and nosuffix.
1029 (Below here, we care only whether they are nil or not.)
1030 The presence of this call is the result of a historical accident:
1031 it used to be in every file-operation and when it got removed
1032 everywhere, it accidentally stayed here. Since then, enough people
1033 supposedly have things like (load "$PROJECT/foo.el") in their .emacs
1034 that it seemed risky to remove. */
1035 if (! NILP (noerror))
1037 file = internal_condition_case_1 (Fsubstitute_in_file_name, file,
1038 Qt, load_error_handler);
1039 if (NILP (file))
1040 return Qnil;
1042 else
1043 file = Fsubstitute_in_file_name (file);
1046 /* Avoid weird lossage with null string as arg,
1047 since it would try to load a directory as a Lisp file */
1048 if (SCHARS (file) > 0)
1050 int size = SBYTES (file);
1052 found = Qnil;
1053 GCPRO2 (file, found);
1055 if (! NILP (must_suffix))
1057 /* Don't insist on adding a suffix if FILE already ends with one. */
1058 if (size > 3
1059 && !strcmp (SDATA (file) + size - 3, ".el"))
1060 must_suffix = Qnil;
1061 else if (size > 4
1062 && !strcmp (SDATA (file) + size - 4, ".elc"))
1063 must_suffix = Qnil;
1064 /* Don't insist on adding a suffix
1065 if the argument includes a directory name. */
1066 else if (! NILP (Ffile_name_directory (file)))
1067 must_suffix = Qnil;
1070 fd = openp (Vload_path, file,
1071 (!NILP (nosuffix) ? Qnil
1072 : !NILP (must_suffix) ? Fget_load_suffixes ()
1073 : Fappend (2, (tmp[0] = Fget_load_suffixes (),
1074 tmp[1] = Vload_file_rep_suffixes,
1075 tmp))),
1076 &found, Qnil);
1077 UNGCPRO;
1080 if (fd == -1)
1082 if (NILP (noerror))
1083 xsignal2 (Qfile_error, build_string ("Cannot open load file"), file);
1084 return Qnil;
1087 /* Tell startup.el whether or not we found the user's init file. */
1088 if (EQ (Qt, Vuser_init_file))
1089 Vuser_init_file = found;
1091 /* If FD is -2, that means openp found a magic file. */
1092 if (fd == -2)
1094 if (NILP (Fequal (found, file)))
1095 /* If FOUND is a different file name from FILE,
1096 find its handler even if we have already inhibited
1097 the `load' operation on FILE. */
1098 handler = Ffind_file_name_handler (found, Qt);
1099 else
1100 handler = Ffind_file_name_handler (found, Qload);
1101 if (! NILP (handler))
1102 return call5 (handler, Qload, found, noerror, nomessage, Qt);
1105 /* Check if we're stuck in a recursive load cycle.
1107 2000-09-21: It's not possible to just check for the file loaded
1108 being a member of Vloads_in_progress. This fails because of the
1109 way the byte compiler currently works; `provide's are not
1110 evaluated, see font-lock.el/jit-lock.el as an example. This
1111 leads to a certain amount of ``normal'' recursion.
1113 Also, just loading a file recursively is not always an error in
1114 the general case; the second load may do something different. */
1116 int count = 0;
1117 Lisp_Object tem;
1118 for (tem = Vloads_in_progress; CONSP (tem); tem = XCDR (tem))
1119 if (!NILP (Fequal (found, XCAR (tem))) && (++count > 3))
1121 if (fd >= 0)
1122 emacs_close (fd);
1123 signal_error ("Recursive load", Fcons (found, Vloads_in_progress));
1125 record_unwind_protect (record_load_unwind, Vloads_in_progress);
1126 Vloads_in_progress = Fcons (found, Vloads_in_progress);
1129 /* Get the name for load-history. */
1130 hist_file_name = (! NILP (Vpurify_flag)
1131 ? Fconcat (2, (tmp[0] = Ffile_name_directory (file),
1132 tmp[1] = Ffile_name_nondirectory (found),
1133 tmp))
1134 : found) ;
1136 version = -1;
1138 /* Check for the presence of old-style quotes and warn about them. */
1139 specbind (Qold_style_backquotes, Qnil);
1140 record_unwind_protect (load_warn_old_style_backquotes, file);
1142 if (!bcmp (SDATA (found) + SBYTES (found) - 4,
1143 ".elc", 4)
1144 || (version = safe_to_load_p (fd)) > 0)
1145 /* Load .elc files directly, but not when they are
1146 remote and have no handler! */
1148 if (fd != -2)
1150 struct stat s1, s2;
1151 int result;
1153 GCPRO3 (file, found, hist_file_name);
1155 if (version < 0
1156 && ! (version = safe_to_load_p (fd)))
1158 safe_p = 0;
1159 if (!load_dangerous_libraries)
1161 if (fd >= 0)
1162 emacs_close (fd);
1163 error ("File `%s' was not compiled in Emacs",
1164 SDATA (found));
1166 else if (!NILP (nomessage))
1167 message_with_string ("File `%s' not compiled in Emacs", found, 1);
1170 compiled = 1;
1172 efound = ENCODE_FILE (found);
1174 #ifdef DOS_NT
1175 fmode = "rb";
1176 #endif /* DOS_NT */
1177 stat ((char *)SDATA (efound), &s1);
1178 SSET (efound, SBYTES (efound) - 1, 0);
1179 result = stat ((char *)SDATA (efound), &s2);
1180 SSET (efound, SBYTES (efound) - 1, 'c');
1182 if (result >= 0 && (unsigned) s1.st_mtime < (unsigned) s2.st_mtime)
1184 /* Make the progress messages mention that source is newer. */
1185 newer = 1;
1187 /* If we won't print another message, mention this anyway. */
1188 if (!NILP (nomessage))
1190 Lisp_Object msg_file;
1191 msg_file = Fsubstring (found, make_number (0), make_number (-1));
1192 message_with_string ("Source file `%s' newer than byte-compiled file",
1193 msg_file, 1);
1196 UNGCPRO;
1199 else
1201 /* We are loading a source file (*.el). */
1202 if (!NILP (Vload_source_file_function))
1204 Lisp_Object val;
1206 if (fd >= 0)
1207 emacs_close (fd);
1208 val = call4 (Vload_source_file_function, found, hist_file_name,
1209 NILP (noerror) ? Qnil : Qt,
1210 NILP (nomessage) ? Qnil : Qt);
1211 return unbind_to (count, val);
1215 GCPRO3 (file, found, hist_file_name);
1217 #ifdef WINDOWSNT
1218 emacs_close (fd);
1219 efound = ENCODE_FILE (found);
1220 stream = fopen ((char *) SDATA (efound), fmode);
1221 #else /* not WINDOWSNT */
1222 stream = fdopen (fd, fmode);
1223 #endif /* not WINDOWSNT */
1224 if (stream == 0)
1226 emacs_close (fd);
1227 error ("Failure to create stdio stream for %s", SDATA (file));
1230 if (! NILP (Vpurify_flag))
1231 Vpreloaded_file_list = Fcons (file, Vpreloaded_file_list);
1233 if (NILP (nomessage))
1235 if (!safe_p)
1236 message_with_string ("Loading %s (compiled; note unsafe, not compiled in Emacs)...",
1237 file, 1);
1238 else if (!compiled)
1239 message_with_string ("Loading %s (source)...", file, 1);
1240 else if (newer)
1241 message_with_string ("Loading %s (compiled; note, source file is newer)...",
1242 file, 1);
1243 else /* The typical case; compiled file newer than source file. */
1244 message_with_string ("Loading %s...", file, 1);
1247 record_unwind_protect (load_unwind, make_save_value (stream, 0));
1248 record_unwind_protect (load_descriptor_unwind, load_descriptor_list);
1249 specbind (Qload_file_name, found);
1250 specbind (Qinhibit_file_name_operation, Qnil);
1251 load_descriptor_list
1252 = Fcons (make_number (fileno (stream)), load_descriptor_list);
1253 load_in_progress++;
1254 if (! version || version >= 22)
1255 readevalloop (Qget_file_char, stream, hist_file_name,
1256 Feval, 0, Qnil, Qnil, Qnil, Qnil);
1257 else
1259 /* We can't handle a file which was compiled with
1260 byte-compile-dynamic by older version of Emacs. */
1261 specbind (Qload_force_doc_strings, Qt);
1262 readevalloop (Qget_emacs_mule_file_char, stream, hist_file_name, Feval,
1263 0, Qnil, Qnil, Qnil, Qnil);
1265 unbind_to (count, Qnil);
1267 /* Run any eval-after-load forms for this file */
1268 if (NILP (Vpurify_flag)
1269 && (!NILP (Ffboundp (Qdo_after_load_evaluation))))
1270 call1 (Qdo_after_load_evaluation, hist_file_name) ;
1272 UNGCPRO;
1274 xfree (saved_doc_string);
1275 saved_doc_string = 0;
1276 saved_doc_string_size = 0;
1278 xfree (prev_saved_doc_string);
1279 prev_saved_doc_string = 0;
1280 prev_saved_doc_string_size = 0;
1282 if (!noninteractive && NILP (nomessage))
1284 if (!safe_p)
1285 message_with_string ("Loading %s (compiled; note unsafe, not compiled in Emacs)...done",
1286 file, 1);
1287 else if (!compiled)
1288 message_with_string ("Loading %s (source)...done", file, 1);
1289 else if (newer)
1290 message_with_string ("Loading %s (compiled; note, source file is newer)...done",
1291 file, 1);
1292 else /* The typical case; compiled file newer than source file. */
1293 message_with_string ("Loading %s...done", file, 1);
1296 if (!NILP (Fequal (build_string ("obsolete"),
1297 Ffile_name_nondirectory
1298 (Fdirectory_file_name (Ffile_name_directory (found))))))
1299 message_with_string ("Package %s is obsolete", file, 1);
1301 return Qt;
1304 static Lisp_Object
1305 load_unwind (arg) /* used as unwind-protect function in load */
1306 Lisp_Object arg;
1308 FILE *stream = (FILE *) XSAVE_VALUE (arg)->pointer;
1309 if (stream != NULL)
1311 BLOCK_INPUT;
1312 fclose (stream);
1313 UNBLOCK_INPUT;
1315 if (--load_in_progress < 0) load_in_progress = 0;
1316 return Qnil;
1319 static Lisp_Object
1320 load_descriptor_unwind (oldlist)
1321 Lisp_Object oldlist;
1323 load_descriptor_list = oldlist;
1324 return Qnil;
1327 /* Close all descriptors in use for Floads.
1328 This is used when starting a subprocess. */
1330 void
1331 close_load_descs ()
1333 #ifndef WINDOWSNT
1334 Lisp_Object tail;
1335 for (tail = load_descriptor_list; CONSP (tail); tail = XCDR (tail))
1336 emacs_close (XFASTINT (XCAR (tail)));
1337 #endif
1340 static int
1341 complete_filename_p (pathname)
1342 Lisp_Object pathname;
1344 register const unsigned char *s = SDATA (pathname);
1345 return (IS_DIRECTORY_SEP (s[0])
1346 || (SCHARS (pathname) > 2
1347 && IS_DEVICE_SEP (s[1]) && IS_DIRECTORY_SEP (s[2])));
1350 DEFUN ("locate-file-internal", Flocate_file_internal, Slocate_file_internal, 2, 4, 0,
1351 doc: /* Search for FILENAME through PATH.
1352 Returns the file's name in absolute form, or nil if not found.
1353 If SUFFIXES is non-nil, it should be a list of suffixes to append to
1354 file name when searching.
1355 If non-nil, PREDICATE is used instead of `file-readable-p'.
1356 PREDICATE can also be an integer to pass to the access(2) function,
1357 in which case file-name-handlers are ignored. */)
1358 (filename, path, suffixes, predicate)
1359 Lisp_Object filename, path, suffixes, predicate;
1361 Lisp_Object file;
1362 int fd = openp (path, filename, suffixes, &file, predicate);
1363 if (NILP (predicate) && fd > 0)
1364 close (fd);
1365 return file;
1369 /* Search for a file whose name is STR, looking in directories
1370 in the Lisp list PATH, and trying suffixes from SUFFIX.
1371 On success, returns a file descriptor. On failure, returns -1.
1373 SUFFIXES is a list of strings containing possible suffixes.
1374 The empty suffix is automatically added if the list is empty.
1376 PREDICATE non-nil means don't open the files,
1377 just look for one that satisfies the predicate. In this case,
1378 returns 1 on success. The predicate can be a lisp function or
1379 an integer to pass to `access' (in which case file-name-handlers
1380 are ignored).
1382 If STOREPTR is nonzero, it points to a slot where the name of
1383 the file actually found should be stored as a Lisp string.
1384 nil is stored there on failure.
1386 If the file we find is remote, return -2
1387 but store the found remote file name in *STOREPTR. */
1390 openp (path, str, suffixes, storeptr, predicate)
1391 Lisp_Object path, str;
1392 Lisp_Object suffixes;
1393 Lisp_Object *storeptr;
1394 Lisp_Object predicate;
1396 register int fd;
1397 int fn_size = 100;
1398 char buf[100];
1399 register char *fn = buf;
1400 int absolute = 0;
1401 int want_size;
1402 Lisp_Object filename;
1403 struct stat st;
1404 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5, gcpro6;
1405 Lisp_Object string, tail, encoded_fn;
1406 int max_suffix_len = 0;
1408 CHECK_STRING (str);
1410 for (tail = suffixes; CONSP (tail); tail = XCDR (tail))
1412 CHECK_STRING_CAR (tail);
1413 max_suffix_len = max (max_suffix_len,
1414 SBYTES (XCAR (tail)));
1417 string = filename = encoded_fn = Qnil;
1418 GCPRO6 (str, string, filename, path, suffixes, encoded_fn);
1420 if (storeptr)
1421 *storeptr = Qnil;
1423 if (complete_filename_p (str))
1424 absolute = 1;
1426 for (; CONSP (path); path = XCDR (path))
1428 filename = Fexpand_file_name (str, XCAR (path));
1429 if (!complete_filename_p (filename))
1430 /* If there are non-absolute elts in PATH (eg ".") */
1431 /* Of course, this could conceivably lose if luser sets
1432 default-directory to be something non-absolute... */
1434 filename = Fexpand_file_name (filename, current_buffer->directory);
1435 if (!complete_filename_p (filename))
1436 /* Give up on this path element! */
1437 continue;
1440 /* Calculate maximum size of any filename made from
1441 this path element/specified file name and any possible suffix. */
1442 want_size = max_suffix_len + SBYTES (filename) + 1;
1443 if (fn_size < want_size)
1444 fn = (char *) alloca (fn_size = 100 + want_size);
1446 /* Loop over suffixes. */
1447 for (tail = NILP (suffixes) ? Fcons (empty_unibyte_string, Qnil) : suffixes;
1448 CONSP (tail); tail = XCDR (tail))
1450 int lsuffix = SBYTES (XCAR (tail));
1451 Lisp_Object handler;
1452 int exists;
1454 /* Concatenate path element/specified name with the suffix.
1455 If the directory starts with /:, remove that. */
1456 if (SCHARS (filename) > 2
1457 && SREF (filename, 0) == '/'
1458 && SREF (filename, 1) == ':')
1460 strncpy (fn, SDATA (filename) + 2,
1461 SBYTES (filename) - 2);
1462 fn[SBYTES (filename) - 2] = 0;
1464 else
1466 strncpy (fn, SDATA (filename),
1467 SBYTES (filename));
1468 fn[SBYTES (filename)] = 0;
1471 if (lsuffix != 0) /* Bug happens on CCI if lsuffix is 0. */
1472 strncat (fn, SDATA (XCAR (tail)), lsuffix);
1474 /* Check that the file exists and is not a directory. */
1475 /* We used to only check for handlers on non-absolute file names:
1476 if (absolute)
1477 handler = Qnil;
1478 else
1479 handler = Ffind_file_name_handler (filename, Qfile_exists_p);
1480 It's not clear why that was the case and it breaks things like
1481 (load "/bar.el") where the file is actually "/bar.el.gz". */
1482 string = build_string (fn);
1483 handler = Ffind_file_name_handler (string, Qfile_exists_p);
1484 if ((!NILP (handler) || !NILP (predicate)) && !NATNUMP (predicate))
1486 if (NILP (predicate))
1487 exists = !NILP (Ffile_readable_p (string));
1488 else
1489 exists = !NILP (call1 (predicate, string));
1490 if (exists && !NILP (Ffile_directory_p (string)))
1491 exists = 0;
1493 if (exists)
1495 /* We succeeded; return this descriptor and filename. */
1496 if (storeptr)
1497 *storeptr = string;
1498 UNGCPRO;
1499 return -2;
1502 else
1504 const char *pfn;
1506 encoded_fn = ENCODE_FILE (string);
1507 pfn = SDATA (encoded_fn);
1508 exists = (stat (pfn, &st) >= 0
1509 && (st.st_mode & S_IFMT) != S_IFDIR);
1510 if (exists)
1512 /* Check that we can access or open it. */
1513 if (NATNUMP (predicate))
1514 fd = (access (pfn, XFASTINT (predicate)) == 0) ? 1 : -1;
1515 else
1516 fd = emacs_open (pfn, O_RDONLY, 0);
1518 if (fd >= 0)
1520 /* We succeeded; return this descriptor and filename. */
1521 if (storeptr)
1522 *storeptr = string;
1523 UNGCPRO;
1524 return fd;
1529 if (absolute)
1530 break;
1533 UNGCPRO;
1534 return -1;
1538 /* Merge the list we've accumulated of globals from the current input source
1539 into the load_history variable. The details depend on whether
1540 the source has an associated file name or not.
1542 FILENAME is the file name that we are loading from.
1543 ENTIRE is 1 if loading that entire file, 0 if evaluating part of it. */
1545 static void
1546 build_load_history (filename, entire)
1547 Lisp_Object filename;
1548 int entire;
1550 register Lisp_Object tail, prev, newelt;
1551 register Lisp_Object tem, tem2;
1552 register int foundit = 0;
1554 tail = Vload_history;
1555 prev = Qnil;
1557 while (CONSP (tail))
1559 tem = XCAR (tail);
1561 /* Find the feature's previous assoc list... */
1562 if (!NILP (Fequal (filename, Fcar (tem))))
1564 foundit = 1;
1566 /* If we're loading the entire file, remove old data. */
1567 if (entire)
1569 if (NILP (prev))
1570 Vload_history = XCDR (tail);
1571 else
1572 Fsetcdr (prev, XCDR (tail));
1575 /* Otherwise, cons on new symbols that are not already members. */
1576 else
1578 tem2 = Vcurrent_load_list;
1580 while (CONSP (tem2))
1582 newelt = XCAR (tem2);
1584 if (NILP (Fmember (newelt, tem)))
1585 Fsetcar (tail, Fcons (XCAR (tem),
1586 Fcons (newelt, XCDR (tem))));
1588 tem2 = XCDR (tem2);
1589 QUIT;
1593 else
1594 prev = tail;
1595 tail = XCDR (tail);
1596 QUIT;
1599 /* If we're loading an entire file, cons the new assoc onto the
1600 front of load-history, the most-recently-loaded position. Also
1601 do this if we didn't find an existing member for the file. */
1602 if (entire || !foundit)
1603 Vload_history = Fcons (Fnreverse (Vcurrent_load_list),
1604 Vload_history);
1607 Lisp_Object
1608 unreadpure (junk) /* Used as unwind-protect function in readevalloop */
1609 Lisp_Object junk;
1611 read_pure = 0;
1612 return Qnil;
1615 static Lisp_Object
1616 readevalloop_1 (old)
1617 Lisp_Object old;
1619 load_convert_to_unibyte = ! NILP (old);
1620 return Qnil;
1623 /* Signal an `end-of-file' error, if possible with file name
1624 information. */
1626 static void
1627 end_of_file_error ()
1629 if (STRINGP (Vload_file_name))
1630 xsignal1 (Qend_of_file, Vload_file_name);
1632 xsignal0 (Qend_of_file);
1635 /* UNIBYTE specifies how to set load_convert_to_unibyte
1636 for this invocation.
1637 READFUN, if non-nil, is used instead of `read'.
1639 START, END specify region to read in current buffer (from eval-region).
1640 If the input is not from a buffer, they must be nil. */
1642 static void
1643 readevalloop (readcharfun, stream, sourcename, evalfun,
1644 printflag, unibyte, readfun, start, end)
1645 Lisp_Object readcharfun;
1646 FILE *stream;
1647 Lisp_Object sourcename;
1648 Lisp_Object (*evalfun) ();
1649 int printflag;
1650 Lisp_Object unibyte, readfun;
1651 Lisp_Object start, end;
1653 register int c;
1654 register Lisp_Object val;
1655 int count = SPECPDL_INDEX ();
1656 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
1657 struct buffer *b = 0;
1658 int continue_reading_p;
1659 /* Nonzero if reading an entire buffer. */
1660 int whole_buffer = 0;
1661 /* 1 on the first time around. */
1662 int first_sexp = 1;
1664 if (MARKERP (readcharfun))
1666 if (NILP (start))
1667 start = readcharfun;
1670 if (BUFFERP (readcharfun))
1671 b = XBUFFER (readcharfun);
1672 else if (MARKERP (readcharfun))
1673 b = XMARKER (readcharfun)->buffer;
1675 /* We assume START is nil when input is not from a buffer. */
1676 if (! NILP (start) && !b)
1677 abort ();
1679 specbind (Qstandard_input, readcharfun); /* GCPROs readcharfun. */
1680 specbind (Qcurrent_load_list, Qnil);
1681 record_unwind_protect (readevalloop_1, load_convert_to_unibyte ? Qt : Qnil);
1682 load_convert_to_unibyte = !NILP (unibyte);
1684 GCPRO4 (sourcename, readfun, start, end);
1686 /* Try to ensure sourcename is a truename, except whilst preloading. */
1687 if (NILP (Vpurify_flag)
1688 && !NILP (sourcename) && !NILP (Ffile_name_absolute_p (sourcename))
1689 && !NILP (Ffboundp (Qfile_truename)))
1690 sourcename = call1 (Qfile_truename, sourcename) ;
1692 LOADHIST_ATTACH (sourcename);
1694 continue_reading_p = 1;
1695 while (continue_reading_p)
1697 int count1 = SPECPDL_INDEX ();
1699 if (b != 0 && NILP (b->name))
1700 error ("Reading from killed buffer");
1702 if (!NILP (start))
1704 /* Switch to the buffer we are reading from. */
1705 record_unwind_protect (save_excursion_restore, save_excursion_save ());
1706 set_buffer_internal (b);
1708 /* Save point in it. */
1709 record_unwind_protect (save_excursion_restore, save_excursion_save ());
1710 /* Save ZV in it. */
1711 record_unwind_protect (save_restriction_restore, save_restriction_save ());
1712 /* Those get unbound after we read one expression. */
1714 /* Set point and ZV around stuff to be read. */
1715 Fgoto_char (start);
1716 if (!NILP (end))
1717 Fnarrow_to_region (make_number (BEGV), end);
1719 /* Just for cleanliness, convert END to a marker
1720 if it is an integer. */
1721 if (INTEGERP (end))
1722 end = Fpoint_max_marker ();
1725 /* On the first cycle, we can easily test here
1726 whether we are reading the whole buffer. */
1727 if (b && first_sexp)
1728 whole_buffer = (PT == BEG && ZV == Z);
1730 instream = stream;
1731 read_next:
1732 c = READCHAR;
1733 if (c == ';')
1735 while ((c = READCHAR) != '\n' && c != -1);
1736 goto read_next;
1738 if (c < 0)
1740 unbind_to (count1, Qnil);
1741 break;
1744 /* Ignore whitespace here, so we can detect eof. */
1745 if (c == ' ' || c == '\t' || c == '\n' || c == '\f' || c == '\r'
1746 || c == 0x8a0) /* NBSP */
1747 goto read_next;
1749 if (!NILP (Vpurify_flag) && c == '(')
1751 record_unwind_protect (unreadpure, Qnil);
1752 val = read_list (-1, readcharfun);
1754 else
1756 UNREAD (c);
1757 read_objects = Qnil;
1758 if (!NILP (readfun))
1760 val = call1 (readfun, readcharfun);
1762 /* If READCHARFUN has set point to ZV, we should
1763 stop reading, even if the form read sets point
1764 to a different value when evaluated. */
1765 if (BUFFERP (readcharfun))
1767 struct buffer *b = XBUFFER (readcharfun);
1768 if (BUF_PT (b) == BUF_ZV (b))
1769 continue_reading_p = 0;
1772 else if (! NILP (Vload_read_function))
1773 val = call1 (Vload_read_function, readcharfun);
1774 else
1775 val = read_internal_start (readcharfun, Qnil, Qnil);
1778 if (!NILP (start) && continue_reading_p)
1779 start = Fpoint_marker ();
1781 /* Restore saved point and BEGV. */
1782 unbind_to (count1, Qnil);
1784 /* Now eval what we just read. */
1785 val = (*evalfun) (val);
1787 if (printflag)
1789 Vvalues = Fcons (val, Vvalues);
1790 if (EQ (Vstandard_output, Qt))
1791 Fprin1 (val, Qnil);
1792 else
1793 Fprint (val, Qnil);
1796 first_sexp = 0;
1799 build_load_history (sourcename,
1800 stream || whole_buffer);
1802 UNGCPRO;
1804 unbind_to (count, Qnil);
1807 DEFUN ("eval-buffer", Feval_buffer, Seval_buffer, 0, 5, "",
1808 doc: /* Execute the current buffer as Lisp code.
1809 When called from a Lisp program (i.e., not interactively), this
1810 function accepts up to five optional arguments:
1811 BUFFER is the buffer to evaluate (nil means use current buffer).
1812 PRINTFLAG controls printing of output:
1813 A value of nil means discard it; anything else is stream for print.
1814 FILENAME specifies the file name to use for `load-history'.
1815 UNIBYTE, if non-nil, specifies `load-convert-to-unibyte' for this
1816 invocation.
1817 DO-ALLOW-PRINT, if non-nil, specifies that `print' and related
1818 functions should work normally even if PRINTFLAG is nil.
1820 This function preserves the position of point. */)
1821 (buffer, printflag, filename, unibyte, do_allow_print)
1822 Lisp_Object buffer, printflag, filename, unibyte, do_allow_print;
1824 int count = SPECPDL_INDEX ();
1825 Lisp_Object tem, buf;
1827 if (NILP (buffer))
1828 buf = Fcurrent_buffer ();
1829 else
1830 buf = Fget_buffer (buffer);
1831 if (NILP (buf))
1832 error ("No such buffer");
1834 if (NILP (printflag) && NILP (do_allow_print))
1835 tem = Qsymbolp;
1836 else
1837 tem = printflag;
1839 if (NILP (filename))
1840 filename = XBUFFER (buf)->filename;
1842 specbind (Qeval_buffer_list, Fcons (buf, Veval_buffer_list));
1843 specbind (Qstandard_output, tem);
1844 record_unwind_protect (save_excursion_restore, save_excursion_save ());
1845 BUF_TEMP_SET_PT (XBUFFER (buf), BUF_BEGV (XBUFFER (buf)));
1846 readevalloop (buf, 0, filename, Feval,
1847 !NILP (printflag), unibyte, Qnil, Qnil, Qnil);
1848 unbind_to (count, Qnil);
1850 return Qnil;
1853 DEFUN ("eval-region", Feval_region, Seval_region, 2, 4, "r",
1854 doc: /* Execute the region as Lisp code.
1855 When called from programs, expects two arguments,
1856 giving starting and ending indices in the current buffer
1857 of the text to be executed.
1858 Programs can pass third argument PRINTFLAG which controls output:
1859 A value of nil means discard it; anything else is stream for printing it.
1860 Also the fourth argument READ-FUNCTION, if non-nil, is used
1861 instead of `read' to read each expression. It gets one argument
1862 which is the input stream for reading characters.
1864 This function does not move point. */)
1865 (start, end, printflag, read_function)
1866 Lisp_Object start, end, printflag, read_function;
1868 int count = SPECPDL_INDEX ();
1869 Lisp_Object tem, cbuf;
1871 cbuf = Fcurrent_buffer ();
1873 if (NILP (printflag))
1874 tem = Qsymbolp;
1875 else
1876 tem = printflag;
1877 specbind (Qstandard_output, tem);
1878 specbind (Qeval_buffer_list, Fcons (cbuf, Veval_buffer_list));
1880 /* readevalloop calls functions which check the type of start and end. */
1881 readevalloop (cbuf, 0, XBUFFER (cbuf)->filename, Feval,
1882 !NILP (printflag), Qnil, read_function,
1883 start, end);
1885 return unbind_to (count, Qnil);
1889 DEFUN ("read", Fread, Sread, 0, 1, 0,
1890 doc: /* Read one Lisp expression as text from STREAM, return as Lisp object.
1891 If STREAM is nil, use the value of `standard-input' (which see).
1892 STREAM or the value of `standard-input' may be:
1893 a buffer (read from point and advance it)
1894 a marker (read from where it points and advance it)
1895 a function (call it with no arguments for each character,
1896 call it with a char as argument to push a char back)
1897 a string (takes text from string, starting at the beginning)
1898 t (read text line using minibuffer and use it, or read from
1899 standard input in batch mode). */)
1900 (stream)
1901 Lisp_Object stream;
1903 if (NILP (stream))
1904 stream = Vstandard_input;
1905 if (EQ (stream, Qt))
1906 stream = Qread_char;
1907 if (EQ (stream, Qread_char))
1908 return Fread_minibuffer (build_string ("Lisp expression: "), Qnil);
1910 return read_internal_start (stream, Qnil, Qnil);
1913 DEFUN ("read-from-string", Fread_from_string, Sread_from_string, 1, 3, 0,
1914 doc: /* Read one Lisp expression which is represented as text by STRING.
1915 Returns a cons: (OBJECT-READ . FINAL-STRING-INDEX).
1916 START and END optionally delimit a substring of STRING from which to read;
1917 they default to 0 and (length STRING) respectively. */)
1918 (string, start, end)
1919 Lisp_Object string, start, end;
1921 Lisp_Object ret;
1922 CHECK_STRING (string);
1923 /* read_internal_start sets read_from_string_index. */
1924 ret = read_internal_start (string, start, end);
1925 return Fcons (ret, make_number (read_from_string_index));
1928 /* Function to set up the global context we need in toplevel read
1929 calls. */
1930 static Lisp_Object
1931 read_internal_start (stream, start, end)
1932 Lisp_Object stream;
1933 Lisp_Object start; /* Only used when stream is a string. */
1934 Lisp_Object end; /* Only used when stream is a string. */
1936 Lisp_Object retval;
1938 readchar_count = 0;
1939 new_backquote_flag = 0;
1940 read_objects = Qnil;
1941 if (EQ (Vread_with_symbol_positions, Qt)
1942 || EQ (Vread_with_symbol_positions, stream))
1943 Vread_symbol_positions_list = Qnil;
1945 if (STRINGP (stream)
1946 || ((CONSP (stream) && STRINGP (XCAR (stream)))))
1948 int startval, endval;
1949 Lisp_Object string;
1951 if (STRINGP (stream))
1952 string = stream;
1953 else
1954 string = XCAR (stream);
1956 if (NILP (end))
1957 endval = SCHARS (string);
1958 else
1960 CHECK_NUMBER (end);
1961 endval = XINT (end);
1962 if (endval < 0 || endval > SCHARS (string))
1963 args_out_of_range (string, end);
1966 if (NILP (start))
1967 startval = 0;
1968 else
1970 CHECK_NUMBER (start);
1971 startval = XINT (start);
1972 if (startval < 0 || startval > endval)
1973 args_out_of_range (string, start);
1975 read_from_string_index = startval;
1976 read_from_string_index_byte = string_char_to_byte (string, startval);
1977 read_from_string_limit = endval;
1980 retval = read0 (stream);
1981 if (EQ (Vread_with_symbol_positions, Qt)
1982 || EQ (Vread_with_symbol_positions, stream))
1983 Vread_symbol_positions_list = Fnreverse (Vread_symbol_positions_list);
1984 return retval;
1988 /* Signal Qinvalid_read_syntax error.
1989 S is error string of length N (if > 0) */
1991 static void
1992 invalid_syntax (s, n)
1993 const char *s;
1994 int n;
1996 if (!n)
1997 n = strlen (s);
1998 xsignal1 (Qinvalid_read_syntax, make_string (s, n));
2002 /* Use this for recursive reads, in contexts where internal tokens
2003 are not allowed. */
2005 static Lisp_Object
2006 read0 (readcharfun)
2007 Lisp_Object readcharfun;
2009 register Lisp_Object val;
2010 int c;
2012 val = read1 (readcharfun, &c, 0);
2013 if (!c)
2014 return val;
2016 xsignal1 (Qinvalid_read_syntax,
2017 Fmake_string (make_number (1), make_number (c)));
2020 static int read_buffer_size;
2021 static char *read_buffer;
2023 /* Read a \-escape sequence, assuming we already read the `\'.
2024 If the escape sequence forces unibyte, return eight-bit char. */
2026 static int
2027 read_escape (readcharfun, stringp)
2028 Lisp_Object readcharfun;
2029 int stringp;
2031 register int c = READCHAR;
2032 /* \u allows up to four hex digits, \U up to eight. Default to the
2033 behavior for \u, and change this value in the case that \U is seen. */
2034 int unicode_hex_count = 4;
2036 switch (c)
2038 case -1:
2039 end_of_file_error ();
2041 case 'a':
2042 return '\007';
2043 case 'b':
2044 return '\b';
2045 case 'd':
2046 return 0177;
2047 case 'e':
2048 return 033;
2049 case 'f':
2050 return '\f';
2051 case 'n':
2052 return '\n';
2053 case 'r':
2054 return '\r';
2055 case 't':
2056 return '\t';
2057 case 'v':
2058 return '\v';
2059 case '\n':
2060 return -1;
2061 case ' ':
2062 if (stringp)
2063 return -1;
2064 return ' ';
2066 case 'M':
2067 c = READCHAR;
2068 if (c != '-')
2069 error ("Invalid escape character syntax");
2070 c = READCHAR;
2071 if (c == '\\')
2072 c = read_escape (readcharfun, 0);
2073 return c | meta_modifier;
2075 case 'S':
2076 c = READCHAR;
2077 if (c != '-')
2078 error ("Invalid escape character syntax");
2079 c = READCHAR;
2080 if (c == '\\')
2081 c = read_escape (readcharfun, 0);
2082 return c | shift_modifier;
2084 case 'H':
2085 c = READCHAR;
2086 if (c != '-')
2087 error ("Invalid escape character syntax");
2088 c = READCHAR;
2089 if (c == '\\')
2090 c = read_escape (readcharfun, 0);
2091 return c | hyper_modifier;
2093 case 'A':
2094 c = READCHAR;
2095 if (c != '-')
2096 error ("Invalid escape character syntax");
2097 c = READCHAR;
2098 if (c == '\\')
2099 c = read_escape (readcharfun, 0);
2100 return c | alt_modifier;
2102 case 's':
2103 c = READCHAR;
2104 if (stringp || c != '-')
2106 UNREAD (c);
2107 return ' ';
2109 c = READCHAR;
2110 if (c == '\\')
2111 c = read_escape (readcharfun, 0);
2112 return c | super_modifier;
2114 case 'C':
2115 c = READCHAR;
2116 if (c != '-')
2117 error ("Invalid escape character syntax");
2118 case '^':
2119 c = READCHAR;
2120 if (c == '\\')
2121 c = read_escape (readcharfun, 0);
2122 if ((c & ~CHAR_MODIFIER_MASK) == '?')
2123 return 0177 | (c & CHAR_MODIFIER_MASK);
2124 else if (! SINGLE_BYTE_CHAR_P ((c & ~CHAR_MODIFIER_MASK)))
2125 return c | ctrl_modifier;
2126 /* ASCII control chars are made from letters (both cases),
2127 as well as the non-letters within 0100...0137. */
2128 else if ((c & 0137) >= 0101 && (c & 0137) <= 0132)
2129 return (c & (037 | ~0177));
2130 else if ((c & 0177) >= 0100 && (c & 0177) <= 0137)
2131 return (c & (037 | ~0177));
2132 else
2133 return c | ctrl_modifier;
2135 case '0':
2136 case '1':
2137 case '2':
2138 case '3':
2139 case '4':
2140 case '5':
2141 case '6':
2142 case '7':
2143 /* An octal escape, as in ANSI C. */
2145 register int i = c - '0';
2146 register int count = 0;
2147 while (++count < 3)
2149 if ((c = READCHAR) >= '0' && c <= '7')
2151 i *= 8;
2152 i += c - '0';
2154 else
2156 UNREAD (c);
2157 break;
2161 if (i >= 0x80 && i < 0x100)
2162 i = BYTE8_TO_CHAR (i);
2163 return i;
2166 case 'x':
2167 /* A hex escape, as in ANSI C. */
2169 int i = 0;
2170 int count = 0;
2171 while (1)
2173 c = READCHAR;
2174 if (c >= '0' && c <= '9')
2176 i *= 16;
2177 i += c - '0';
2179 else if ((c >= 'a' && c <= 'f')
2180 || (c >= 'A' && c <= 'F'))
2182 i *= 16;
2183 if (c >= 'a' && c <= 'f')
2184 i += c - 'a' + 10;
2185 else
2186 i += c - 'A' + 10;
2188 else
2190 UNREAD (c);
2191 break;
2193 count++;
2196 if (count < 3 && i >= 0x80)
2197 return BYTE8_TO_CHAR (i);
2198 return i;
2201 case 'U':
2202 /* Post-Unicode-2.0: Up to eight hex chars. */
2203 unicode_hex_count = 8;
2204 case 'u':
2206 /* A Unicode escape. We only permit them in strings and characters,
2207 not arbitrarily in the source code, as in some other languages. */
2209 unsigned int i = 0;
2210 int count = 0;
2212 while (++count <= unicode_hex_count)
2214 c = READCHAR;
2215 /* isdigit and isalpha may be locale-specific, which we don't
2216 want. */
2217 if (c >= '0' && c <= '9') i = (i << 4) + (c - '0');
2218 else if (c >= 'a' && c <= 'f') i = (i << 4) + (c - 'a') + 10;
2219 else if (c >= 'A' && c <= 'F') i = (i << 4) + (c - 'A') + 10;
2220 else
2222 error ("Non-hex digit used for Unicode escape");
2223 break;
2226 if (i > 0x10FFFF)
2227 error ("Non-Unicode character: 0x%x", i);
2228 return i;
2231 default:
2232 return c;
2236 /* Read an integer in radix RADIX using READCHARFUN to read
2237 characters. RADIX must be in the interval [2..36]; if it isn't, a
2238 read error is signaled . Value is the integer read. Signals an
2239 error if encountering invalid read syntax or if RADIX is out of
2240 range. */
2242 static Lisp_Object
2243 read_integer (readcharfun, radix)
2244 Lisp_Object readcharfun;
2245 int radix;
2247 int ndigits = 0, invalid_p, c, sign = 0;
2248 EMACS_INT number = 0;
2250 if (radix < 2 || radix > 36)
2251 invalid_p = 1;
2252 else
2254 number = ndigits = invalid_p = 0;
2255 sign = 1;
2257 c = READCHAR;
2258 if (c == '-')
2260 c = READCHAR;
2261 sign = -1;
2263 else if (c == '+')
2264 c = READCHAR;
2266 while (c >= 0)
2268 int digit;
2270 if (c >= '0' && c <= '9')
2271 digit = c - '0';
2272 else if (c >= 'a' && c <= 'z')
2273 digit = c - 'a' + 10;
2274 else if (c >= 'A' && c <= 'Z')
2275 digit = c - 'A' + 10;
2276 else
2278 UNREAD (c);
2279 break;
2282 if (digit < 0 || digit >= radix)
2283 invalid_p = 1;
2285 number = radix * number + digit;
2286 ++ndigits;
2287 c = READCHAR;
2291 if (ndigits == 0 || invalid_p)
2293 char buf[50];
2294 sprintf (buf, "integer, radix %d", radix);
2295 invalid_syntax (buf, 0);
2298 return make_number (sign * number);
2302 /* If the next token is ')' or ']' or '.', we store that character
2303 in *PCH and the return value is not interesting. Else, we store
2304 zero in *PCH and we read and return one lisp object.
2306 FIRST_IN_LIST is nonzero if this is the first element of a list. */
2308 static Lisp_Object
2309 read1 (readcharfun, pch, first_in_list)
2310 register Lisp_Object readcharfun;
2311 int *pch;
2312 int first_in_list;
2314 register int c;
2315 int uninterned_symbol = 0;
2316 int multibyte;
2318 *pch = 0;
2319 load_each_byte = 0;
2321 retry:
2323 c = READCHAR_REPORT_MULTIBYTE (&multibyte);
2324 if (c < 0)
2325 end_of_file_error ();
2327 switch (c)
2329 case '(':
2330 return read_list (0, readcharfun);
2332 case '[':
2333 return read_vector (readcharfun, 0);
2335 case ')':
2336 case ']':
2338 *pch = c;
2339 return Qnil;
2342 case '#':
2343 c = READCHAR;
2344 if (c == '^')
2346 c = READCHAR;
2347 if (c == '[')
2349 Lisp_Object tmp;
2350 tmp = read_vector (readcharfun, 0);
2351 if (XVECTOR (tmp)->size < CHAR_TABLE_STANDARD_SLOTS)
2352 error ("Invalid size char-table");
2353 XSETPVECTYPE (XVECTOR (tmp), PVEC_CHAR_TABLE);
2354 return tmp;
2356 else if (c == '^')
2358 c = READCHAR;
2359 if (c == '[')
2361 Lisp_Object tmp;
2362 int depth, size;
2364 tmp = read_vector (readcharfun, 0);
2365 if (!INTEGERP (AREF (tmp, 0)))
2366 error ("Invalid depth in char-table");
2367 depth = XINT (AREF (tmp, 0));
2368 if (depth < 1 || depth > 3)
2369 error ("Invalid depth in char-table");
2370 size = XVECTOR (tmp)->size - 2;
2371 if (chartab_size [depth] != size)
2372 error ("Invalid size char-table");
2373 XSETPVECTYPE (XVECTOR (tmp), PVEC_SUB_CHAR_TABLE);
2374 return tmp;
2376 invalid_syntax ("#^^", 3);
2378 invalid_syntax ("#^", 2);
2380 if (c == '&')
2382 Lisp_Object length;
2383 length = read1 (readcharfun, pch, first_in_list);
2384 c = READCHAR;
2385 if (c == '"')
2387 Lisp_Object tmp, val;
2388 int size_in_chars
2389 = ((XFASTINT (length) + BOOL_VECTOR_BITS_PER_CHAR - 1)
2390 / BOOL_VECTOR_BITS_PER_CHAR);
2392 UNREAD (c);
2393 tmp = read1 (readcharfun, pch, first_in_list);
2394 if (STRING_MULTIBYTE (tmp)
2395 || (size_in_chars != SCHARS (tmp)
2396 /* We used to print 1 char too many
2397 when the number of bits was a multiple of 8.
2398 Accept such input in case it came from an old
2399 version. */
2400 && ! (XFASTINT (length)
2401 == (SCHARS (tmp) - 1) * BOOL_VECTOR_BITS_PER_CHAR)))
2402 invalid_syntax ("#&...", 5);
2404 val = Fmake_bool_vector (length, Qnil);
2405 bcopy (SDATA (tmp), XBOOL_VECTOR (val)->data,
2406 size_in_chars);
2407 /* Clear the extraneous bits in the last byte. */
2408 if (XINT (length) != size_in_chars * BOOL_VECTOR_BITS_PER_CHAR)
2409 XBOOL_VECTOR (val)->data[size_in_chars - 1]
2410 &= (1 << (XINT (length) % BOOL_VECTOR_BITS_PER_CHAR)) - 1;
2411 return val;
2413 invalid_syntax ("#&...", 5);
2415 if (c == '[')
2417 /* Accept compiled functions at read-time so that we don't have to
2418 build them using function calls. */
2419 Lisp_Object tmp;
2420 tmp = read_vector (readcharfun, 1);
2421 return Fmake_byte_code (XVECTOR (tmp)->size,
2422 XVECTOR (tmp)->contents);
2424 if (c == '(')
2426 Lisp_Object tmp;
2427 struct gcpro gcpro1;
2428 int ch;
2430 /* Read the string itself. */
2431 tmp = read1 (readcharfun, &ch, 0);
2432 if (ch != 0 || !STRINGP (tmp))
2433 invalid_syntax ("#", 1);
2434 GCPRO1 (tmp);
2435 /* Read the intervals and their properties. */
2436 while (1)
2438 Lisp_Object beg, end, plist;
2440 beg = read1 (readcharfun, &ch, 0);
2441 end = plist = Qnil;
2442 if (ch == ')')
2443 break;
2444 if (ch == 0)
2445 end = read1 (readcharfun, &ch, 0);
2446 if (ch == 0)
2447 plist = read1 (readcharfun, &ch, 0);
2448 if (ch)
2449 invalid_syntax ("Invalid string property list", 0);
2450 Fset_text_properties (beg, end, plist, tmp);
2452 UNGCPRO;
2453 return tmp;
2456 /* #@NUMBER is used to skip NUMBER following characters.
2457 That's used in .elc files to skip over doc strings
2458 and function definitions. */
2459 if (c == '@')
2461 int i, nskip = 0;
2463 load_each_byte = 1;
2464 /* Read a decimal integer. */
2465 while ((c = READCHAR) >= 0
2466 && c >= '0' && c <= '9')
2468 nskip *= 10;
2469 nskip += c - '0';
2471 if (c >= 0)
2472 UNREAD (c);
2474 if (load_force_doc_strings
2475 && (EQ (readcharfun, Qget_file_char)
2476 || EQ (readcharfun, Qget_emacs_mule_file_char)))
2478 /* If we are supposed to force doc strings into core right now,
2479 record the last string that we skipped,
2480 and record where in the file it comes from. */
2482 /* But first exchange saved_doc_string
2483 with prev_saved_doc_string, so we save two strings. */
2485 char *temp = saved_doc_string;
2486 int temp_size = saved_doc_string_size;
2487 file_offset temp_pos = saved_doc_string_position;
2488 int temp_len = saved_doc_string_length;
2490 saved_doc_string = prev_saved_doc_string;
2491 saved_doc_string_size = prev_saved_doc_string_size;
2492 saved_doc_string_position = prev_saved_doc_string_position;
2493 saved_doc_string_length = prev_saved_doc_string_length;
2495 prev_saved_doc_string = temp;
2496 prev_saved_doc_string_size = temp_size;
2497 prev_saved_doc_string_position = temp_pos;
2498 prev_saved_doc_string_length = temp_len;
2501 if (saved_doc_string_size == 0)
2503 saved_doc_string_size = nskip + 100;
2504 saved_doc_string = (char *) xmalloc (saved_doc_string_size);
2506 if (nskip > saved_doc_string_size)
2508 saved_doc_string_size = nskip + 100;
2509 saved_doc_string = (char *) xrealloc (saved_doc_string,
2510 saved_doc_string_size);
2513 saved_doc_string_position = file_tell (instream);
2515 /* Copy that many characters into saved_doc_string. */
2516 for (i = 0; i < nskip && c >= 0; i++)
2517 saved_doc_string[i] = c = READCHAR;
2519 saved_doc_string_length = i;
2521 else
2523 /* Skip that many characters. */
2524 for (i = 0; i < nskip && c >= 0; i++)
2525 c = READCHAR;
2528 load_each_byte = 0;
2529 goto retry;
2531 if (c == '!')
2533 /* #! appears at the beginning of an executable file.
2534 Skip the first line. */
2535 while (c != '\n' && c >= 0)
2536 c = READCHAR;
2537 goto retry;
2539 if (c == '$')
2540 return Vload_file_name;
2541 if (c == '\'')
2542 return Fcons (Qfunction, Fcons (read0 (readcharfun), Qnil));
2543 /* #:foo is the uninterned symbol named foo. */
2544 if (c == ':')
2546 uninterned_symbol = 1;
2547 c = READCHAR;
2548 goto default_label;
2550 /* Reader forms that can reuse previously read objects. */
2551 if (c >= '0' && c <= '9')
2553 int n = 0;
2554 Lisp_Object tem;
2556 /* Read a non-negative integer. */
2557 while (c >= '0' && c <= '9')
2559 n *= 10;
2560 n += c - '0';
2561 c = READCHAR;
2563 /* #n=object returns object, but associates it with n for #n#. */
2564 if (c == '=' && !NILP (Vread_circle))
2566 /* Make a placeholder for #n# to use temporarily */
2567 Lisp_Object placeholder;
2568 Lisp_Object cell;
2570 placeholder = Fcons(Qnil, Qnil);
2571 cell = Fcons (make_number (n), placeholder);
2572 read_objects = Fcons (cell, read_objects);
2574 /* Read the object itself. */
2575 tem = read0 (readcharfun);
2577 /* Now put it everywhere the placeholder was... */
2578 substitute_object_in_subtree (tem, placeholder);
2580 /* ...and #n# will use the real value from now on. */
2581 Fsetcdr (cell, tem);
2583 return tem;
2585 /* #n# returns a previously read object. */
2586 if (c == '#' && !NILP (Vread_circle))
2588 tem = Fassq (make_number (n), read_objects);
2589 if (CONSP (tem))
2590 return XCDR (tem);
2591 /* Fall through to error message. */
2593 else if (c == 'r' || c == 'R')
2594 return read_integer (readcharfun, n);
2596 /* Fall through to error message. */
2598 else if (c == 'x' || c == 'X')
2599 return read_integer (readcharfun, 16);
2600 else if (c == 'o' || c == 'O')
2601 return read_integer (readcharfun, 8);
2602 else if (c == 'b' || c == 'B')
2603 return read_integer (readcharfun, 2);
2605 UNREAD (c);
2606 invalid_syntax ("#", 1);
2608 case ';':
2609 while ((c = READCHAR) >= 0 && c != '\n');
2610 goto retry;
2612 case '\'':
2614 return Fcons (Qquote, Fcons (read0 (readcharfun), Qnil));
2617 case '`':
2618 if (first_in_list)
2620 Vold_style_backquotes = Qt;
2621 goto default_label;
2623 else
2625 Lisp_Object value;
2627 new_backquote_flag++;
2628 value = read0 (readcharfun);
2629 new_backquote_flag--;
2631 return Fcons (Qbackquote, Fcons (value, Qnil));
2634 case ',':
2635 if (new_backquote_flag)
2637 Lisp_Object comma_type = Qnil;
2638 Lisp_Object value;
2639 int ch = READCHAR;
2641 if (ch == '@')
2642 comma_type = Qcomma_at;
2643 else if (ch == '.')
2644 comma_type = Qcomma_dot;
2645 else
2647 if (ch >= 0) UNREAD (ch);
2648 comma_type = Qcomma;
2651 new_backquote_flag--;
2652 value = read0 (readcharfun);
2653 new_backquote_flag++;
2654 return Fcons (comma_type, Fcons (value, Qnil));
2656 else
2658 Vold_style_backquotes = Qt;
2659 goto default_label;
2662 case '?':
2664 int modifiers;
2665 int next_char;
2666 int ok;
2668 c = READCHAR;
2669 if (c < 0)
2670 end_of_file_error ();
2672 /* Accept `single space' syntax like (list ? x) where the
2673 whitespace character is SPC or TAB.
2674 Other literal whitespace like NL, CR, and FF are not accepted,
2675 as there are well-established escape sequences for these. */
2676 if (c == ' ' || c == '\t')
2677 return make_number (c);
2679 if (c == '\\')
2680 c = read_escape (readcharfun, 0);
2681 modifiers = c & CHAR_MODIFIER_MASK;
2682 c &= ~CHAR_MODIFIER_MASK;
2683 if (CHAR_BYTE8_P (c))
2684 c = CHAR_TO_BYTE8 (c);
2685 c |= modifiers;
2687 next_char = READCHAR;
2688 if (next_char == '.')
2690 /* Only a dotted-pair dot is valid after a char constant. */
2691 int next_next_char = READCHAR;
2692 UNREAD (next_next_char);
2694 ok = (next_next_char <= 040
2695 || (next_next_char < 0200
2696 && (index ("\"';([#?", next_next_char)
2697 || (!first_in_list && next_next_char == '`')
2698 || (new_backquote_flag && next_next_char == ','))));
2700 else
2702 ok = (next_char <= 040
2703 || (next_char < 0200
2704 && (index ("\"';()[]#?", next_char)
2705 || (!first_in_list && next_char == '`')
2706 || (new_backquote_flag && next_char == ','))));
2708 UNREAD (next_char);
2709 if (ok)
2710 return make_number (c);
2712 invalid_syntax ("?", 1);
2715 case '"':
2717 char *p = read_buffer;
2718 char *end = read_buffer + read_buffer_size;
2719 register int c;
2720 /* Nonzero if we saw an escape sequence specifying
2721 a multibyte character. */
2722 int force_multibyte = 0;
2723 /* Nonzero if we saw an escape sequence specifying
2724 a single-byte character. */
2725 int force_singlebyte = 0;
2726 int cancel = 0;
2727 int nchars = 0;
2729 while ((c = READCHAR) >= 0
2730 && c != '\"')
2732 if (end - p < MAX_MULTIBYTE_LENGTH)
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;
2741 if (c == '\\')
2743 int modifiers;
2745 c = read_escape (readcharfun, 1);
2747 /* C is -1 if \ newline has just been seen */
2748 if (c == -1)
2750 if (p == read_buffer)
2751 cancel = 1;
2752 continue;
2755 modifiers = c & CHAR_MODIFIER_MASK;
2756 c = c & ~CHAR_MODIFIER_MASK;
2758 if (CHAR_BYTE8_P (c))
2759 force_singlebyte = 1;
2760 else if (! ASCII_CHAR_P (c))
2761 force_multibyte = 1;
2762 else /* i.e. ASCII_CHAR_P (c) */
2764 /* Allow `\C- ' and `\C-?'. */
2765 if (modifiers == CHAR_CTL)
2767 if (c == ' ')
2768 c = 0, modifiers = 0;
2769 else if (c == '?')
2770 c = 127, modifiers = 0;
2772 if (modifiers & CHAR_SHIFT)
2774 /* Shift modifier is valid only with [A-Za-z]. */
2775 if (c >= 'A' && c <= 'Z')
2776 modifiers &= ~CHAR_SHIFT;
2777 else if (c >= 'a' && c <= 'z')
2778 c -= ('a' - 'A'), modifiers &= ~CHAR_SHIFT;
2781 if (modifiers & CHAR_META)
2783 /* Move the meta bit to the right place for a
2784 string. */
2785 modifiers &= ~CHAR_META;
2786 c = BYTE8_TO_CHAR (c | 0x80);
2787 force_singlebyte = 1;
2791 /* Any modifiers remaining are invalid. */
2792 if (modifiers)
2793 error ("Invalid modifier in string");
2794 p += CHAR_STRING (c, (unsigned char *) p);
2796 else
2798 p += CHAR_STRING (c, (unsigned char *) p);
2799 if (CHAR_BYTE8_P (c))
2800 force_singlebyte = 1;
2801 else if (! ASCII_CHAR_P (c))
2802 force_multibyte = 1;
2804 nchars++;
2807 if (c < 0)
2808 end_of_file_error ();
2810 /* If purifying, and string starts with \ newline,
2811 return zero instead. This is for doc strings
2812 that we are really going to find in etc/DOC.nn.nn */
2813 if (!NILP (Vpurify_flag) && NILP (Vdoc_file_name) && cancel)
2814 return make_number (0);
2816 if (force_multibyte)
2817 /* READ_BUFFER already contains valid multibyte forms. */
2819 else if (force_singlebyte)
2821 nchars = str_as_unibyte (read_buffer, p - read_buffer);
2822 p = read_buffer + nchars;
2824 else
2825 /* Otherwise, READ_BUFFER contains only ASCII. */
2828 /* We want readchar_count to be the number of characters, not
2829 bytes. Hence we adjust for multibyte characters in the
2830 string. ... But it doesn't seem to be necessary, because
2831 READCHAR *does* read multibyte characters from buffers. */
2832 /* readchar_count -= (p - read_buffer) - nchars; */
2833 if (read_pure)
2834 return make_pure_string (read_buffer, nchars, p - read_buffer,
2835 (force_multibyte
2836 || (p - read_buffer != nchars)));
2837 return make_specified_string (read_buffer, nchars, p - read_buffer,
2838 (force_multibyte
2839 || (p - read_buffer != nchars)));
2842 case '.':
2844 int next_char = READCHAR;
2845 UNREAD (next_char);
2847 if (next_char <= 040
2848 || (next_char < 0200
2849 && (index ("\"';([#?", next_char)
2850 || (!first_in_list && next_char == '`')
2851 || (new_backquote_flag && next_char == ','))))
2853 *pch = c;
2854 return Qnil;
2857 /* Otherwise, we fall through! Note that the atom-reading loop
2858 below will now loop at least once, assuring that we will not
2859 try to UNREAD two characters in a row. */
2861 default:
2862 default_label:
2863 if (c <= 040) goto retry;
2864 if (c == 0x8a0) /* NBSP */
2865 goto retry;
2867 char *p = read_buffer;
2868 int quoted = 0;
2871 char *end = read_buffer + read_buffer_size;
2873 while (c > 040
2874 && c != 0x8a0 /* NBSP */
2875 && (c >= 0200
2876 || (!index ("\"';()[]#", c)
2877 && !(!first_in_list && c == '`')
2878 && !(new_backquote_flag && c == ','))))
2880 if (end - p < MAX_MULTIBYTE_LENGTH)
2882 int offset = p - read_buffer;
2883 read_buffer = (char *) xrealloc (read_buffer,
2884 read_buffer_size *= 2);
2885 p = read_buffer + offset;
2886 end = read_buffer + read_buffer_size;
2889 if (c == '\\')
2891 c = READCHAR;
2892 if (c == -1)
2893 end_of_file_error ();
2894 quoted = 1;
2897 if (multibyte)
2898 p += CHAR_STRING (c, p);
2899 else
2900 *p++ = c;
2901 c = READCHAR;
2904 if (p == end)
2906 int offset = p - read_buffer;
2907 read_buffer = (char *) xrealloc (read_buffer,
2908 read_buffer_size *= 2);
2909 p = read_buffer + offset;
2910 end = read_buffer + read_buffer_size;
2912 *p = 0;
2913 if (c >= 0)
2914 UNREAD (c);
2917 if (!quoted && !uninterned_symbol)
2919 register char *p1;
2920 register Lisp_Object val;
2921 p1 = read_buffer;
2922 if (*p1 == '+' || *p1 == '-') p1++;
2923 /* Is it an integer? */
2924 if (p1 != p)
2926 while (p1 != p && (c = *p1) >= '0' && c <= '9') p1++;
2927 /* Integers can have trailing decimal points. */
2928 if (p1 > read_buffer && p1 < p && *p1 == '.') p1++;
2929 if (p1 == p)
2930 /* It is an integer. */
2932 if (p1[-1] == '.')
2933 p1[-1] = '\0';
2934 /* Fixme: if we have strtol, use that, and check
2935 for overflow. */
2936 if (sizeof (int) == sizeof (EMACS_INT))
2937 XSETINT (val, atoi (read_buffer));
2938 else if (sizeof (long) == sizeof (EMACS_INT))
2939 XSETINT (val, atol (read_buffer));
2940 else
2941 abort ();
2942 return val;
2945 if (isfloat_string (read_buffer))
2947 /* Compute NaN and infinities using 0.0 in a variable,
2948 to cope with compilers that think they are smarter
2949 than we are. */
2950 double zero = 0.0;
2952 double value;
2954 /* Negate the value ourselves. This treats 0, NaNs,
2955 and infinity properly on IEEE floating point hosts,
2956 and works around a common bug where atof ("-0.0")
2957 drops the sign. */
2958 int negative = read_buffer[0] == '-';
2960 /* The only way p[-1] can be 'F' or 'N', after isfloat_string
2961 returns 1, is if the input ends in e+INF or e+NaN. */
2962 switch (p[-1])
2964 case 'F':
2965 value = 1.0 / zero;
2966 break;
2967 case 'N':
2968 value = zero / zero;
2970 /* If that made a "negative" NaN, negate it. */
2973 int i;
2974 union { double d; char c[sizeof (double)]; } u_data, u_minus_zero;
2976 u_data.d = value;
2977 u_minus_zero.d = - 0.0;
2978 for (i = 0; i < sizeof (double); i++)
2979 if (u_data.c[i] & u_minus_zero.c[i])
2981 value = - value;
2982 break;
2985 /* Now VALUE is a positive NaN. */
2986 break;
2987 default:
2988 value = atof (read_buffer + negative);
2989 break;
2992 return make_float (negative ? - value : value);
2996 Lisp_Object name, result;
2997 EMACS_INT nbytes = p - read_buffer;
2998 EMACS_INT nchars
2999 = (multibyte ? multibyte_chars_in_text (read_buffer, nbytes)
3000 : nbytes);
3002 if (uninterned_symbol && ! NILP (Vpurify_flag))
3003 name = make_pure_string (read_buffer, nchars, nbytes, multibyte);
3004 else
3005 name = make_specified_string (read_buffer, nchars, nbytes,multibyte);
3006 result = (uninterned_symbol ? Fmake_symbol (name)
3007 : Fintern (name, Qnil));
3009 if (EQ (Vread_with_symbol_positions, Qt)
3010 || EQ (Vread_with_symbol_positions, readcharfun))
3011 Vread_symbol_positions_list =
3012 /* Kind of a hack; this will probably fail if characters
3013 in the symbol name were escaped. Not really a big
3014 deal, though. */
3015 Fcons (Fcons (result,
3016 make_number (readchar_count
3017 - XFASTINT (Flength (Fsymbol_name (result))))),
3018 Vread_symbol_positions_list);
3019 return result;
3026 /* List of nodes we've seen during substitute_object_in_subtree. */
3027 static Lisp_Object seen_list;
3029 static void
3030 substitute_object_in_subtree (object, placeholder)
3031 Lisp_Object object;
3032 Lisp_Object placeholder;
3034 Lisp_Object check_object;
3036 /* We haven't seen any objects when we start. */
3037 seen_list = Qnil;
3039 /* Make all the substitutions. */
3040 check_object
3041 = substitute_object_recurse (object, placeholder, object);
3043 /* Clear seen_list because we're done with it. */
3044 seen_list = Qnil;
3046 /* The returned object here is expected to always eq the
3047 original. */
3048 if (!EQ (check_object, object))
3049 error ("Unexpected mutation error in reader");
3052 /* Feval doesn't get called from here, so no gc protection is needed. */
3053 #define SUBSTITUTE(get_val, set_val) \
3054 do { \
3055 Lisp_Object old_value = get_val; \
3056 Lisp_Object true_value \
3057 = substitute_object_recurse (object, placeholder, \
3058 old_value); \
3060 if (!EQ (old_value, true_value)) \
3062 set_val; \
3064 } while (0)
3066 static Lisp_Object
3067 substitute_object_recurse (object, placeholder, subtree)
3068 Lisp_Object object;
3069 Lisp_Object placeholder;
3070 Lisp_Object subtree;
3072 /* If we find the placeholder, return the target object. */
3073 if (EQ (placeholder, subtree))
3074 return object;
3076 /* If we've been to this node before, don't explore it again. */
3077 if (!EQ (Qnil, Fmemq (subtree, seen_list)))
3078 return subtree;
3080 /* If this node can be the entry point to a cycle, remember that
3081 we've seen it. It can only be such an entry point if it was made
3082 by #n=, which means that we can find it as a value in
3083 read_objects. */
3084 if (!EQ (Qnil, Frassq (subtree, read_objects)))
3085 seen_list = Fcons (subtree, seen_list);
3087 /* Recurse according to subtree's type.
3088 Every branch must return a Lisp_Object. */
3089 switch (XTYPE (subtree))
3091 case Lisp_Vectorlike:
3093 int i, length = 0;
3094 if (BOOL_VECTOR_P (subtree))
3095 return subtree; /* No sub-objects anyway. */
3096 else if (CHAR_TABLE_P (subtree) || SUB_CHAR_TABLE_P (subtree)
3097 || COMPILEDP (subtree))
3098 length = ASIZE (subtree) & PSEUDOVECTOR_SIZE_MASK;
3099 else if (VECTORP (subtree))
3100 length = ASIZE (subtree);
3101 else
3102 /* An unknown pseudovector may contain non-Lisp fields, so we
3103 can't just blindly traverse all its fields. We used to call
3104 `Flength' which signaled `sequencep', so I just preserved this
3105 behavior. */
3106 wrong_type_argument (Qsequencep, subtree);
3108 for (i = 0; i < length; i++)
3109 SUBSTITUTE (AREF (subtree, i),
3110 ASET (subtree, i, true_value));
3111 return subtree;
3114 case Lisp_Cons:
3116 SUBSTITUTE (XCAR (subtree),
3117 XSETCAR (subtree, true_value));
3118 SUBSTITUTE (XCDR (subtree),
3119 XSETCDR (subtree, true_value));
3120 return subtree;
3123 case Lisp_String:
3125 /* Check for text properties in each interval.
3126 substitute_in_interval contains part of the logic. */
3128 INTERVAL root_interval = STRING_INTERVALS (subtree);
3129 Lisp_Object arg = Fcons (object, placeholder);
3131 traverse_intervals_noorder (root_interval,
3132 &substitute_in_interval, arg);
3134 return subtree;
3137 /* Other types don't recurse any further. */
3138 default:
3139 return subtree;
3143 /* Helper function for substitute_object_recurse. */
3144 static void
3145 substitute_in_interval (interval, arg)
3146 INTERVAL interval;
3147 Lisp_Object arg;
3149 Lisp_Object object = Fcar (arg);
3150 Lisp_Object placeholder = Fcdr (arg);
3152 SUBSTITUTE(interval->plist, interval->plist = true_value);
3156 #define LEAD_INT 1
3157 #define DOT_CHAR 2
3158 #define TRAIL_INT 4
3159 #define E_CHAR 8
3160 #define EXP_INT 16
3163 isfloat_string (cp)
3164 register char *cp;
3166 register int state;
3168 char *start = cp;
3170 state = 0;
3171 if (*cp == '+' || *cp == '-')
3172 cp++;
3174 if (*cp >= '0' && *cp <= '9')
3176 state |= LEAD_INT;
3177 while (*cp >= '0' && *cp <= '9')
3178 cp++;
3180 if (*cp == '.')
3182 state |= DOT_CHAR;
3183 cp++;
3185 if (*cp >= '0' && *cp <= '9')
3187 state |= TRAIL_INT;
3188 while (*cp >= '0' && *cp <= '9')
3189 cp++;
3191 if (*cp == 'e' || *cp == 'E')
3193 state |= E_CHAR;
3194 cp++;
3195 if (*cp == '+' || *cp == '-')
3196 cp++;
3199 if (*cp >= '0' && *cp <= '9')
3201 state |= EXP_INT;
3202 while (*cp >= '0' && *cp <= '9')
3203 cp++;
3205 else if (cp == start)
3207 else if (cp[-1] == '+' && cp[0] == 'I' && cp[1] == 'N' && cp[2] == 'F')
3209 state |= EXP_INT;
3210 cp += 3;
3212 else if (cp[-1] == '+' && cp[0] == 'N' && cp[1] == 'a' && cp[2] == 'N')
3214 state |= EXP_INT;
3215 cp += 3;
3218 return (((*cp == 0) || (*cp == ' ') || (*cp == '\t') || (*cp == '\n') || (*cp == '\r') || (*cp == '\f'))
3219 && (state == (LEAD_INT|DOT_CHAR|TRAIL_INT)
3220 || state == (DOT_CHAR|TRAIL_INT)
3221 || state == (LEAD_INT|E_CHAR|EXP_INT)
3222 || state == (LEAD_INT|DOT_CHAR|TRAIL_INT|E_CHAR|EXP_INT)
3223 || state == (DOT_CHAR|TRAIL_INT|E_CHAR|EXP_INT)));
3227 static Lisp_Object
3228 read_vector (readcharfun, bytecodeflag)
3229 Lisp_Object readcharfun;
3230 int bytecodeflag;
3232 register int i;
3233 register int size;
3234 register Lisp_Object *ptr;
3235 register Lisp_Object tem, item, vector;
3236 register struct Lisp_Cons *otem;
3237 Lisp_Object len;
3239 tem = read_list (1, readcharfun);
3240 len = Flength (tem);
3241 vector = (read_pure ? make_pure_vector (XINT (len)) : Fmake_vector (len, Qnil));
3243 size = XVECTOR (vector)->size;
3244 ptr = XVECTOR (vector)->contents;
3245 for (i = 0; i < size; i++)
3247 item = Fcar (tem);
3248 /* If `load-force-doc-strings' is t when reading a lazily-loaded
3249 bytecode object, the docstring containing the bytecode and
3250 constants values must be treated as unibyte and passed to
3251 Fread, to get the actual bytecode string and constants vector. */
3252 if (bytecodeflag && load_force_doc_strings)
3254 if (i == COMPILED_BYTECODE)
3256 if (!STRINGP (item))
3257 error ("Invalid byte code");
3259 /* Delay handling the bytecode slot until we know whether
3260 it is lazily-loaded (we can tell by whether the
3261 constants slot is nil). */
3262 ptr[COMPILED_CONSTANTS] = item;
3263 item = Qnil;
3265 else if (i == COMPILED_CONSTANTS)
3267 Lisp_Object bytestr = ptr[COMPILED_CONSTANTS];
3269 if (NILP (item))
3271 /* Coerce string to unibyte (like string-as-unibyte,
3272 but without generating extra garbage and
3273 guaranteeing no change in the contents). */
3274 STRING_SET_CHARS (bytestr, SBYTES (bytestr));
3275 STRING_SET_UNIBYTE (bytestr);
3277 item = Fread (Fcons (bytestr, readcharfun));
3278 if (!CONSP (item))
3279 error ("Invalid byte code");
3281 otem = XCONS (item);
3282 bytestr = XCAR (item);
3283 item = XCDR (item);
3284 free_cons (otem);
3287 /* Now handle the bytecode slot. */
3288 ptr[COMPILED_BYTECODE] = read_pure ? Fpurecopy (bytestr) : bytestr;
3290 else if (i == COMPILED_DOC_STRING
3291 && STRINGP (item)
3292 && ! STRING_MULTIBYTE (item))
3294 if (EQ (readcharfun, Qget_emacs_mule_file_char))
3295 item = Fdecode_coding_string (item, Qemacs_mule, Qnil, Qnil);
3296 else
3297 item = Fstring_as_multibyte (item);
3300 ptr[i] = read_pure ? Fpurecopy (item) : item;
3301 otem = XCONS (tem);
3302 tem = Fcdr (tem);
3303 free_cons (otem);
3305 return vector;
3308 /* FLAG = 1 means check for ] to terminate rather than ) and .
3309 FLAG = -1 means check for starting with defun
3310 and make structure pure. */
3312 static Lisp_Object
3313 read_list (flag, readcharfun)
3314 int flag;
3315 register Lisp_Object readcharfun;
3317 /* -1 means check next element for defun,
3318 0 means don't check,
3319 1 means already checked and found defun. */
3320 int defunflag = flag < 0 ? -1 : 0;
3321 Lisp_Object val, tail;
3322 register Lisp_Object elt, tem;
3323 struct gcpro gcpro1, gcpro2;
3324 /* 0 is the normal case.
3325 1 means this list is a doc reference; replace it with the number 0.
3326 2 means this list is a doc reference; replace it with the doc string. */
3327 int doc_reference = 0;
3329 /* Initialize this to 1 if we are reading a list. */
3330 int first_in_list = flag <= 0;
3332 val = Qnil;
3333 tail = Qnil;
3335 while (1)
3337 int ch;
3338 GCPRO2 (val, tail);
3339 elt = read1 (readcharfun, &ch, first_in_list);
3340 UNGCPRO;
3342 first_in_list = 0;
3344 /* While building, if the list starts with #$, treat it specially. */
3345 if (EQ (elt, Vload_file_name)
3346 && ! NILP (elt)
3347 && !NILP (Vpurify_flag))
3349 if (NILP (Vdoc_file_name))
3350 /* We have not yet called Snarf-documentation, so assume
3351 this file is described in the DOC-MM.NN file
3352 and Snarf-documentation will fill in the right value later.
3353 For now, replace the whole list with 0. */
3354 doc_reference = 1;
3355 else
3356 /* We have already called Snarf-documentation, so make a relative
3357 file name for this file, so it can be found properly
3358 in the installed Lisp directory.
3359 We don't use Fexpand_file_name because that would make
3360 the directory absolute now. */
3361 elt = concat2 (build_string ("../lisp/"),
3362 Ffile_name_nondirectory (elt));
3364 else if (EQ (elt, Vload_file_name)
3365 && ! NILP (elt)
3366 && load_force_doc_strings)
3367 doc_reference = 2;
3369 if (ch)
3371 if (flag > 0)
3373 if (ch == ']')
3374 return val;
3375 invalid_syntax (") or . in a vector", 18);
3377 if (ch == ')')
3378 return val;
3379 if (ch == '.')
3381 GCPRO2 (val, tail);
3382 if (!NILP (tail))
3383 XSETCDR (tail, read0 (readcharfun));
3384 else
3385 val = read0 (readcharfun);
3386 read1 (readcharfun, &ch, 0);
3387 UNGCPRO;
3388 if (ch == ')')
3390 if (doc_reference == 1)
3391 return make_number (0);
3392 if (doc_reference == 2)
3394 /* Get a doc string from the file we are loading.
3395 If it's in saved_doc_string, get it from there.
3397 Here, we don't know if the string is a
3398 bytecode string or a doc string. As a
3399 bytecode string must be unibyte, we always
3400 return a unibyte string. If it is actually a
3401 doc string, caller must make it
3402 multibyte. */
3404 int pos = XINT (XCDR (val));
3405 /* Position is negative for user variables. */
3406 if (pos < 0) pos = -pos;
3407 if (pos >= saved_doc_string_position
3408 && pos < (saved_doc_string_position
3409 + saved_doc_string_length))
3411 int start = pos - saved_doc_string_position;
3412 int from, to;
3414 /* Process quoting with ^A,
3415 and find the end of the string,
3416 which is marked with ^_ (037). */
3417 for (from = start, to = start;
3418 saved_doc_string[from] != 037;)
3420 int c = saved_doc_string[from++];
3421 if (c == 1)
3423 c = saved_doc_string[from++];
3424 if (c == 1)
3425 saved_doc_string[to++] = c;
3426 else if (c == '0')
3427 saved_doc_string[to++] = 0;
3428 else if (c == '_')
3429 saved_doc_string[to++] = 037;
3431 else
3432 saved_doc_string[to++] = c;
3435 return make_unibyte_string (saved_doc_string + start,
3436 to - start);
3438 /* Look in prev_saved_doc_string the same way. */
3439 else if (pos >= prev_saved_doc_string_position
3440 && pos < (prev_saved_doc_string_position
3441 + prev_saved_doc_string_length))
3443 int start = pos - prev_saved_doc_string_position;
3444 int from, to;
3446 /* Process quoting with ^A,
3447 and find the end of the string,
3448 which is marked with ^_ (037). */
3449 for (from = start, to = start;
3450 prev_saved_doc_string[from] != 037;)
3452 int c = prev_saved_doc_string[from++];
3453 if (c == 1)
3455 c = prev_saved_doc_string[from++];
3456 if (c == 1)
3457 prev_saved_doc_string[to++] = c;
3458 else if (c == '0')
3459 prev_saved_doc_string[to++] = 0;
3460 else if (c == '_')
3461 prev_saved_doc_string[to++] = 037;
3463 else
3464 prev_saved_doc_string[to++] = c;
3467 return make_unibyte_string (prev_saved_doc_string
3468 + start,
3469 to - start);
3471 else
3472 return get_doc_string (val, 1, 0);
3475 return val;
3477 invalid_syntax (". in wrong context", 18);
3479 invalid_syntax ("] in a list", 11);
3481 tem = (read_pure && flag <= 0
3482 ? pure_cons (elt, Qnil)
3483 : Fcons (elt, Qnil));
3484 if (!NILP (tail))
3485 XSETCDR (tail, tem);
3486 else
3487 val = tem;
3488 tail = tem;
3489 if (defunflag < 0)
3490 defunflag = EQ (elt, Qdefun);
3491 else if (defunflag > 0)
3492 read_pure = 1;
3496 Lisp_Object Vobarray;
3497 Lisp_Object initial_obarray;
3499 /* oblookup stores the bucket number here, for the sake of Funintern. */
3501 int oblookup_last_bucket_number;
3503 static int hash_string ();
3505 /* Get an error if OBARRAY is not an obarray.
3506 If it is one, return it. */
3508 Lisp_Object
3509 check_obarray (obarray)
3510 Lisp_Object obarray;
3512 if (!VECTORP (obarray) || XVECTOR (obarray)->size == 0)
3514 /* If Vobarray is now invalid, force it to be valid. */
3515 if (EQ (Vobarray, obarray)) Vobarray = initial_obarray;
3516 wrong_type_argument (Qvectorp, obarray);
3518 return obarray;
3521 /* Intern the C string STR: return a symbol with that name,
3522 interned in the current obarray. */
3524 Lisp_Object
3525 intern (str)
3526 const char *str;
3528 Lisp_Object tem;
3529 int len = strlen (str);
3530 Lisp_Object obarray;
3532 obarray = Vobarray;
3533 if (!VECTORP (obarray) || XVECTOR (obarray)->size == 0)
3534 obarray = check_obarray (obarray);
3535 tem = oblookup (obarray, str, len, len);
3536 if (SYMBOLP (tem))
3537 return tem;
3538 return Fintern (make_string (str, len), obarray);
3541 /* Create an uninterned symbol with name STR. */
3543 Lisp_Object
3544 make_symbol (str)
3545 char *str;
3547 int len = strlen (str);
3549 return Fmake_symbol ((!NILP (Vpurify_flag)
3550 ? make_pure_string (str, len, len, 0)
3551 : make_string (str, len)));
3554 DEFUN ("intern", Fintern, Sintern, 1, 2, 0,
3555 doc: /* Return the canonical symbol whose name is STRING.
3556 If there is none, one is created by this function and returned.
3557 A second optional argument specifies the obarray to use;
3558 it defaults to the value of `obarray'. */)
3559 (string, obarray)
3560 Lisp_Object string, obarray;
3562 register Lisp_Object tem, sym, *ptr;
3564 if (NILP (obarray)) obarray = Vobarray;
3565 obarray = check_obarray (obarray);
3567 CHECK_STRING (string);
3569 tem = oblookup (obarray, SDATA (string),
3570 SCHARS (string),
3571 SBYTES (string));
3572 if (!INTEGERP (tem))
3573 return tem;
3575 if (!NILP (Vpurify_flag))
3576 string = Fpurecopy (string);
3577 sym = Fmake_symbol (string);
3579 if (EQ (obarray, initial_obarray))
3580 XSYMBOL (sym)->interned = SYMBOL_INTERNED_IN_INITIAL_OBARRAY;
3581 else
3582 XSYMBOL (sym)->interned = SYMBOL_INTERNED;
3584 if ((SREF (string, 0) == ':')
3585 && EQ (obarray, initial_obarray))
3587 XSYMBOL (sym)->constant = 1;
3588 XSYMBOL (sym)->value = sym;
3591 ptr = &XVECTOR (obarray)->contents[XINT (tem)];
3592 if (SYMBOLP (*ptr))
3593 XSYMBOL (sym)->next = XSYMBOL (*ptr);
3594 else
3595 XSYMBOL (sym)->next = 0;
3596 *ptr = sym;
3597 return sym;
3600 DEFUN ("intern-soft", Fintern_soft, Sintern_soft, 1, 2, 0,
3601 doc: /* Return the canonical symbol named NAME, or nil if none exists.
3602 NAME may be a string or a symbol. If it is a symbol, that exact
3603 symbol is searched for.
3604 A second optional argument specifies the obarray to use;
3605 it defaults to the value of `obarray'. */)
3606 (name, obarray)
3607 Lisp_Object name, obarray;
3609 register Lisp_Object tem, string;
3611 if (NILP (obarray)) obarray = Vobarray;
3612 obarray = check_obarray (obarray);
3614 if (!SYMBOLP (name))
3616 CHECK_STRING (name);
3617 string = name;
3619 else
3620 string = SYMBOL_NAME (name);
3622 tem = oblookup (obarray, SDATA (string), SCHARS (string), SBYTES (string));
3623 if (INTEGERP (tem) || (SYMBOLP (name) && !EQ (name, tem)))
3624 return Qnil;
3625 else
3626 return tem;
3629 DEFUN ("unintern", Funintern, Sunintern, 1, 2, 0,
3630 doc: /* Delete the symbol named NAME, if any, from OBARRAY.
3631 The value is t if a symbol was found and deleted, nil otherwise.
3632 NAME may be a string or a symbol. If it is a symbol, that symbol
3633 is deleted, if it belongs to OBARRAY--no other symbol is deleted.
3634 OBARRAY defaults to the value of the variable `obarray'. */)
3635 (name, obarray)
3636 Lisp_Object name, obarray;
3638 register Lisp_Object string, tem;
3639 int hash;
3641 if (NILP (obarray)) obarray = Vobarray;
3642 obarray = check_obarray (obarray);
3644 if (SYMBOLP (name))
3645 string = SYMBOL_NAME (name);
3646 else
3648 CHECK_STRING (name);
3649 string = name;
3652 tem = oblookup (obarray, SDATA (string),
3653 SCHARS (string),
3654 SBYTES (string));
3655 if (INTEGERP (tem))
3656 return Qnil;
3657 /* If arg was a symbol, don't delete anything but that symbol itself. */
3658 if (SYMBOLP (name) && !EQ (name, tem))
3659 return Qnil;
3661 XSYMBOL (tem)->interned = SYMBOL_UNINTERNED;
3662 XSYMBOL (tem)->constant = 0;
3663 XSYMBOL (tem)->indirect_variable = 0;
3665 hash = oblookup_last_bucket_number;
3667 if (EQ (XVECTOR (obarray)->contents[hash], tem))
3669 if (XSYMBOL (tem)->next)
3670 XSETSYMBOL (XVECTOR (obarray)->contents[hash], XSYMBOL (tem)->next);
3671 else
3672 XSETINT (XVECTOR (obarray)->contents[hash], 0);
3674 else
3676 Lisp_Object tail, following;
3678 for (tail = XVECTOR (obarray)->contents[hash];
3679 XSYMBOL (tail)->next;
3680 tail = following)
3682 XSETSYMBOL (following, XSYMBOL (tail)->next);
3683 if (EQ (following, tem))
3685 XSYMBOL (tail)->next = XSYMBOL (following)->next;
3686 break;
3691 return Qt;
3694 /* Return the symbol in OBARRAY whose names matches the string
3695 of SIZE characters (SIZE_BYTE bytes) at PTR.
3696 If there is no such symbol in OBARRAY, return nil.
3698 Also store the bucket number in oblookup_last_bucket_number. */
3700 Lisp_Object
3701 oblookup (obarray, ptr, size, size_byte)
3702 Lisp_Object obarray;
3703 register const char *ptr;
3704 int size, size_byte;
3706 int hash;
3707 int obsize;
3708 register Lisp_Object tail;
3709 Lisp_Object bucket, tem;
3711 if (!VECTORP (obarray)
3712 || (obsize = XVECTOR (obarray)->size) == 0)
3714 obarray = check_obarray (obarray);
3715 obsize = XVECTOR (obarray)->size;
3717 /* This is sometimes needed in the middle of GC. */
3718 obsize &= ~ARRAY_MARK_FLAG;
3719 hash = hash_string (ptr, size_byte) % obsize;
3720 bucket = XVECTOR (obarray)->contents[hash];
3721 oblookup_last_bucket_number = hash;
3722 if (EQ (bucket, make_number (0)))
3724 else if (!SYMBOLP (bucket))
3725 error ("Bad data in guts of obarray"); /* Like CADR error message */
3726 else
3727 for (tail = bucket; ; XSETSYMBOL (tail, XSYMBOL (tail)->next))
3729 if (SBYTES (SYMBOL_NAME (tail)) == size_byte
3730 && SCHARS (SYMBOL_NAME (tail)) == size
3731 && !bcmp (SDATA (SYMBOL_NAME (tail)), ptr, size_byte))
3732 return tail;
3733 else if (XSYMBOL (tail)->next == 0)
3734 break;
3736 XSETINT (tem, hash);
3737 return tem;
3740 static int
3741 hash_string (ptr, len)
3742 const unsigned char *ptr;
3743 int len;
3745 register const unsigned char *p = ptr;
3746 register const unsigned char *end = p + len;
3747 register unsigned char c;
3748 register int hash = 0;
3750 while (p != end)
3752 c = *p++;
3753 if (c >= 0140) c -= 40;
3754 hash = ((hash<<3) + (hash>>28) + c);
3756 return hash & 07777777777;
3759 void
3760 map_obarray (obarray, fn, arg)
3761 Lisp_Object obarray;
3762 void (*fn) P_ ((Lisp_Object, Lisp_Object));
3763 Lisp_Object arg;
3765 register int i;
3766 register Lisp_Object tail;
3767 CHECK_VECTOR (obarray);
3768 for (i = XVECTOR (obarray)->size - 1; i >= 0; i--)
3770 tail = XVECTOR (obarray)->contents[i];
3771 if (SYMBOLP (tail))
3772 while (1)
3774 (*fn) (tail, arg);
3775 if (XSYMBOL (tail)->next == 0)
3776 break;
3777 XSETSYMBOL (tail, XSYMBOL (tail)->next);
3782 void
3783 mapatoms_1 (sym, function)
3784 Lisp_Object sym, function;
3786 call1 (function, sym);
3789 DEFUN ("mapatoms", Fmapatoms, Smapatoms, 1, 2, 0,
3790 doc: /* Call FUNCTION on every symbol in OBARRAY.
3791 OBARRAY defaults to the value of `obarray'. */)
3792 (function, obarray)
3793 Lisp_Object function, obarray;
3795 if (NILP (obarray)) obarray = Vobarray;
3796 obarray = check_obarray (obarray);
3798 map_obarray (obarray, mapatoms_1, function);
3799 return Qnil;
3802 #define OBARRAY_SIZE 1511
3804 void
3805 init_obarray ()
3807 Lisp_Object oblength;
3808 int hash;
3809 Lisp_Object *tem;
3811 XSETFASTINT (oblength, OBARRAY_SIZE);
3813 Qnil = Fmake_symbol (make_pure_string ("nil", 3, 3, 0));
3814 Vobarray = Fmake_vector (oblength, make_number (0));
3815 initial_obarray = Vobarray;
3816 staticpro (&initial_obarray);
3817 /* Intern nil in the obarray */
3818 XSYMBOL (Qnil)->interned = SYMBOL_INTERNED_IN_INITIAL_OBARRAY;
3819 XSYMBOL (Qnil)->constant = 1;
3821 /* These locals are to kludge around a pyramid compiler bug. */
3822 hash = hash_string ("nil", 3);
3823 /* Separate statement here to avoid VAXC bug. */
3824 hash %= OBARRAY_SIZE;
3825 tem = &XVECTOR (Vobarray)->contents[hash];
3826 *tem = Qnil;
3828 Qunbound = Fmake_symbol (make_pure_string ("unbound", 7, 7, 0));
3829 XSYMBOL (Qnil)->function = Qunbound;
3830 XSYMBOL (Qunbound)->value = Qunbound;
3831 XSYMBOL (Qunbound)->function = Qunbound;
3833 Qt = intern ("t");
3834 XSYMBOL (Qnil)->value = Qnil;
3835 XSYMBOL (Qnil)->plist = Qnil;
3836 XSYMBOL (Qt)->value = Qt;
3837 XSYMBOL (Qt)->constant = 1;
3839 /* Qt is correct even if CANNOT_DUMP. loadup.el will set to nil at end. */
3840 Vpurify_flag = Qt;
3842 Qvariable_documentation = intern ("variable-documentation");
3843 staticpro (&Qvariable_documentation);
3845 read_buffer_size = 100 + MAX_MULTIBYTE_LENGTH;
3846 read_buffer = (char *) xmalloc (read_buffer_size);
3849 void
3850 defsubr (sname)
3851 struct Lisp_Subr *sname;
3853 Lisp_Object sym;
3854 sym = intern (sname->symbol_name);
3855 XSETPVECTYPE (sname, PVEC_SUBR);
3856 XSETSUBR (XSYMBOL (sym)->function, sname);
3859 #ifdef NOTDEF /* use fset in subr.el now */
3860 void
3861 defalias (sname, string)
3862 struct Lisp_Subr *sname;
3863 char *string;
3865 Lisp_Object sym;
3866 sym = intern (string);
3867 XSETSUBR (XSYMBOL (sym)->function, sname);
3869 #endif /* NOTDEF */
3871 /* Define an "integer variable"; a symbol whose value is forwarded
3872 to a C variable of type int. Sample call:
3873 DEFVAR_INT ("emacs-priority", &emacs_priority, "Documentation"); */
3874 void
3875 defvar_int (namestring, address)
3876 char *namestring;
3877 EMACS_INT *address;
3879 Lisp_Object sym, val;
3880 sym = intern (namestring);
3881 val = allocate_misc ();
3882 XMISCTYPE (val) = Lisp_Misc_Intfwd;
3883 XINTFWD (val)->intvar = address;
3884 SET_SYMBOL_VALUE (sym, val);
3887 /* Similar but define a variable whose value is t if address contains 1,
3888 nil if address contains 0. */
3889 void
3890 defvar_bool (namestring, address)
3891 char *namestring;
3892 int *address;
3894 Lisp_Object sym, val;
3895 sym = intern (namestring);
3896 val = allocate_misc ();
3897 XMISCTYPE (val) = Lisp_Misc_Boolfwd;
3898 XBOOLFWD (val)->boolvar = address;
3899 SET_SYMBOL_VALUE (sym, val);
3900 Vbyte_boolean_vars = Fcons (sym, Vbyte_boolean_vars);
3903 /* Similar but define a variable whose value is the Lisp Object stored
3904 at address. Two versions: with and without gc-marking of the C
3905 variable. The nopro version is used when that variable will be
3906 gc-marked for some other reason, since marking the same slot twice
3907 can cause trouble with strings. */
3908 void
3909 defvar_lisp_nopro (namestring, address)
3910 char *namestring;
3911 Lisp_Object *address;
3913 Lisp_Object sym, val;
3914 sym = intern (namestring);
3915 val = allocate_misc ();
3916 XMISCTYPE (val) = Lisp_Misc_Objfwd;
3917 XOBJFWD (val)->objvar = address;
3918 SET_SYMBOL_VALUE (sym, val);
3921 void
3922 defvar_lisp (namestring, address)
3923 char *namestring;
3924 Lisp_Object *address;
3926 defvar_lisp_nopro (namestring, address);
3927 staticpro (address);
3930 /* Similar but define a variable whose value is the Lisp Object stored
3931 at a particular offset in the current kboard object. */
3933 void
3934 defvar_kboard (namestring, offset)
3935 char *namestring;
3936 int offset;
3938 Lisp_Object sym, val;
3939 sym = intern (namestring);
3940 val = allocate_misc ();
3941 XMISCTYPE (val) = Lisp_Misc_Kboard_Objfwd;
3942 XKBOARD_OBJFWD (val)->offset = offset;
3943 SET_SYMBOL_VALUE (sym, val);
3946 /* Record the value of load-path used at the start of dumping
3947 so we can see if the site changed it later during dumping. */
3948 static Lisp_Object dump_path;
3950 void
3951 init_lread ()
3953 char *normal;
3954 int turn_off_warning = 0;
3956 /* Compute the default load-path. */
3957 #ifdef CANNOT_DUMP
3958 normal = PATH_LOADSEARCH;
3959 Vload_path = decode_env_path (0, normal);
3960 #else
3961 if (NILP (Vpurify_flag))
3962 normal = PATH_LOADSEARCH;
3963 else
3964 normal = PATH_DUMPLOADSEARCH;
3966 /* In a dumped Emacs, we normally have to reset the value of
3967 Vload_path from PATH_LOADSEARCH, since the value that was dumped
3968 uses ../lisp, instead of the path of the installed elisp
3969 libraries. However, if it appears that Vload_path was changed
3970 from the default before dumping, don't override that value. */
3971 if (initialized)
3973 if (! NILP (Fequal (dump_path, Vload_path)))
3975 Vload_path = decode_env_path (0, normal);
3976 if (!NILP (Vinstallation_directory))
3978 Lisp_Object tem, tem1, sitelisp;
3980 /* Remove site-lisp dirs from path temporarily and store
3981 them in sitelisp, then conc them on at the end so
3982 they're always first in path. */
3983 sitelisp = Qnil;
3984 while (1)
3986 tem = Fcar (Vload_path);
3987 tem1 = Fstring_match (build_string ("site-lisp"),
3988 tem, Qnil);
3989 if (!NILP (tem1))
3991 Vload_path = Fcdr (Vload_path);
3992 sitelisp = Fcons (tem, sitelisp);
3994 else
3995 break;
3998 /* Add to the path the lisp subdir of the
3999 installation dir, if it exists. */
4000 tem = Fexpand_file_name (build_string ("lisp"),
4001 Vinstallation_directory);
4002 tem1 = Ffile_exists_p (tem);
4003 if (!NILP (tem1))
4005 if (NILP (Fmember (tem, Vload_path)))
4007 turn_off_warning = 1;
4008 Vload_path = Fcons (tem, Vload_path);
4011 else
4012 /* That dir doesn't exist, so add the build-time
4013 Lisp dirs instead. */
4014 Vload_path = nconc2 (Vload_path, dump_path);
4016 /* Add leim under the installation dir, if it exists. */
4017 tem = Fexpand_file_name (build_string ("leim"),
4018 Vinstallation_directory);
4019 tem1 = Ffile_exists_p (tem);
4020 if (!NILP (tem1))
4022 if (NILP (Fmember (tem, Vload_path)))
4023 Vload_path = Fcons (tem, Vload_path);
4026 /* Add site-lisp under the installation dir, if it exists. */
4027 tem = Fexpand_file_name (build_string ("site-lisp"),
4028 Vinstallation_directory);
4029 tem1 = Ffile_exists_p (tem);
4030 if (!NILP (tem1))
4032 if (NILP (Fmember (tem, Vload_path)))
4033 Vload_path = Fcons (tem, Vload_path);
4036 /* If Emacs was not built in the source directory,
4037 and it is run from where it was built, add to load-path
4038 the lisp, leim and site-lisp dirs under that directory. */
4040 if (NILP (Fequal (Vinstallation_directory, Vsource_directory)))
4042 Lisp_Object tem2;
4044 tem = Fexpand_file_name (build_string ("src/Makefile"),
4045 Vinstallation_directory);
4046 tem1 = Ffile_exists_p (tem);
4048 /* Don't be fooled if they moved the entire source tree
4049 AFTER dumping Emacs. If the build directory is indeed
4050 different from the source dir, src/Makefile.in and
4051 src/Makefile will not be found together. */
4052 tem = Fexpand_file_name (build_string ("src/Makefile.in"),
4053 Vinstallation_directory);
4054 tem2 = Ffile_exists_p (tem);
4055 if (!NILP (tem1) && NILP (tem2))
4057 tem = Fexpand_file_name (build_string ("lisp"),
4058 Vsource_directory);
4060 if (NILP (Fmember (tem, Vload_path)))
4061 Vload_path = Fcons (tem, Vload_path);
4063 tem = Fexpand_file_name (build_string ("leim"),
4064 Vsource_directory);
4066 if (NILP (Fmember (tem, Vload_path)))
4067 Vload_path = Fcons (tem, Vload_path);
4069 tem = Fexpand_file_name (build_string ("site-lisp"),
4070 Vsource_directory);
4072 if (NILP (Fmember (tem, Vload_path)))
4073 Vload_path = Fcons (tem, Vload_path);
4076 if (!NILP (sitelisp))
4077 Vload_path = nconc2 (Fnreverse (sitelisp), Vload_path);
4081 else
4083 /* NORMAL refers to the lisp dir in the source directory. */
4084 /* We used to add ../lisp at the front here, but
4085 that caused trouble because it was copied from dump_path
4086 into Vload_path, above, when Vinstallation_directory was non-nil.
4087 It should be unnecessary. */
4088 Vload_path = decode_env_path (0, normal);
4089 dump_path = Vload_path;
4091 #endif
4093 #if (!(defined(WINDOWSNT) || (defined(HAVE_NS))))
4094 /* When Emacs is invoked over network shares on NT, PATH_LOADSEARCH is
4095 almost never correct, thereby causing a warning to be printed out that
4096 confuses users. Since PATH_LOADSEARCH is always overridden by the
4097 EMACSLOADPATH environment variable below, disable the warning on NT. */
4099 /* Warn if dirs in the *standard* path don't exist. */
4100 if (!turn_off_warning)
4102 Lisp_Object path_tail;
4104 for (path_tail = Vload_path;
4105 !NILP (path_tail);
4106 path_tail = XCDR (path_tail))
4108 Lisp_Object dirfile;
4109 dirfile = Fcar (path_tail);
4110 if (STRINGP (dirfile))
4112 dirfile = Fdirectory_file_name (dirfile);
4113 if (access (SDATA (dirfile), 0) < 0)
4114 dir_warning ("Warning: Lisp directory `%s' does not exist.\n",
4115 XCAR (path_tail));
4119 #endif /* !(WINDOWSNT || HAVE_NS) */
4121 /* If the EMACSLOADPATH environment variable is set, use its value.
4122 This doesn't apply if we're dumping. */
4123 #ifndef CANNOT_DUMP
4124 if (NILP (Vpurify_flag)
4125 && egetenv ("EMACSLOADPATH"))
4126 #endif
4127 Vload_path = decode_env_path ("EMACSLOADPATH", normal);
4129 Vvalues = Qnil;
4131 load_in_progress = 0;
4132 Vload_file_name = Qnil;
4134 load_descriptor_list = Qnil;
4136 Vstandard_input = Qt;
4137 Vloads_in_progress = Qnil;
4140 /* Print a warning, using format string FORMAT, that directory DIRNAME
4141 does not exist. Print it on stderr and put it in *Messages*. */
4143 void
4144 dir_warning (format, dirname)
4145 char *format;
4146 Lisp_Object dirname;
4148 char *buffer
4149 = (char *) alloca (SCHARS (dirname) + strlen (format) + 5);
4151 fprintf (stderr, format, SDATA (dirname));
4152 sprintf (buffer, format, SDATA (dirname));
4153 /* Don't log the warning before we've initialized!! */
4154 if (initialized)
4155 message_dolog (buffer, strlen (buffer), 0, STRING_MULTIBYTE (dirname));
4158 void
4159 syms_of_lread ()
4161 defsubr (&Sread);
4162 defsubr (&Sread_from_string);
4163 defsubr (&Sintern);
4164 defsubr (&Sintern_soft);
4165 defsubr (&Sunintern);
4166 defsubr (&Sget_load_suffixes);
4167 defsubr (&Sload);
4168 defsubr (&Seval_buffer);
4169 defsubr (&Seval_region);
4170 defsubr (&Sread_char);
4171 defsubr (&Sread_char_exclusive);
4172 defsubr (&Sread_event);
4173 defsubr (&Sget_file_char);
4174 defsubr (&Smapatoms);
4175 defsubr (&Slocate_file_internal);
4177 DEFVAR_LISP ("obarray", &Vobarray,
4178 doc: /* Symbol table for use by `intern' and `read'.
4179 It is a vector whose length ought to be prime for best results.
4180 The vector's contents don't make sense if examined from Lisp programs;
4181 to find all the symbols in an obarray, use `mapatoms'. */);
4183 DEFVAR_LISP ("values", &Vvalues,
4184 doc: /* List of values of all expressions which were read, evaluated and printed.
4185 Order is reverse chronological. */);
4187 DEFVAR_LISP ("standard-input", &Vstandard_input,
4188 doc: /* Stream for read to get input from.
4189 See documentation of `read' for possible values. */);
4190 Vstandard_input = Qt;
4192 DEFVAR_LISP ("read-with-symbol-positions", &Vread_with_symbol_positions,
4193 doc: /* If non-nil, add position of read symbols to `read-symbol-positions-list'.
4195 If this variable is a buffer, then only forms read from that buffer
4196 will be added to `read-symbol-positions-list'.
4197 If this variable is t, then all read forms will be added.
4198 The effect of all other values other than nil are not currently
4199 defined, although they may be in the future.
4201 The positions are relative to the last call to `read' or
4202 `read-from-string'. It is probably a bad idea to set this variable at
4203 the toplevel; bind it instead. */);
4204 Vread_with_symbol_positions = Qnil;
4206 DEFVAR_LISP ("read-symbol-positions-list", &Vread_symbol_positions_list,
4207 doc: /* A list mapping read symbols to their positions.
4208 This variable is modified during calls to `read' or
4209 `read-from-string', but only when `read-with-symbol-positions' is
4210 non-nil.
4212 Each element of the list looks like (SYMBOL . CHAR-POSITION), where
4213 CHAR-POSITION is an integer giving the offset of that occurrence of the
4214 symbol from the position where `read' or `read-from-string' started.
4216 Note that a symbol will appear multiple times in this list, if it was
4217 read multiple times. The list is in the same order as the symbols
4218 were read in. */);
4219 Vread_symbol_positions_list = Qnil;
4221 DEFVAR_LISP ("read-circle", &Vread_circle,
4222 doc: /* Non-nil means read recursive structures using #N= and #N# syntax. */);
4223 Vread_circle = Qt;
4225 DEFVAR_LISP ("load-path", &Vload_path,
4226 doc: /* *List of directories to search for files to load.
4227 Each element is a string (directory name) or nil (try default directory).
4228 Initialized based on EMACSLOADPATH environment variable, if any,
4229 otherwise to default specified by file `epaths.h' when Emacs was built. */);
4231 DEFVAR_LISP ("load-suffixes", &Vload_suffixes,
4232 doc: /* List of suffixes for (compiled or source) Emacs Lisp files.
4233 This list should not include the empty string.
4234 `load' and related functions try to append these suffixes, in order,
4235 to the specified file name if a Lisp suffix is allowed or required. */);
4236 Vload_suffixes = Fcons (build_string (".elc"),
4237 Fcons (build_string (".el"), Qnil));
4238 DEFVAR_LISP ("load-file-rep-suffixes", &Vload_file_rep_suffixes,
4239 doc: /* List of suffixes that indicate representations of \
4240 the same file.
4241 This list should normally start with the empty string.
4243 Enabling Auto Compression mode appends the suffixes in
4244 `jka-compr-load-suffixes' to this list and disabling Auto Compression
4245 mode removes them again. `load' and related functions use this list to
4246 determine whether they should look for compressed versions of a file
4247 and, if so, which suffixes they should try to append to the file name
4248 in order to do so. However, if you want to customize which suffixes
4249 the loading functions recognize as compression suffixes, you should
4250 customize `jka-compr-load-suffixes' rather than the present variable. */);
4251 Vload_file_rep_suffixes = Fcons (empty_unibyte_string, Qnil);
4253 DEFVAR_BOOL ("load-in-progress", &load_in_progress,
4254 doc: /* Non-nil if inside of `load'. */);
4256 DEFVAR_LISP ("after-load-alist", &Vafter_load_alist,
4257 doc: /* An alist of expressions to be evalled when particular files are loaded.
4258 Each element looks like (REGEXP-OR-FEATURE FORMS...).
4260 REGEXP-OR-FEATURE is either a regular expression to match file names, or
4261 a symbol \(a feature name).
4263 When `load' is run and the file-name argument matches an element's
4264 REGEXP-OR-FEATURE, or when `provide' is run and provides the symbol
4265 REGEXP-OR-FEATURE, the FORMS in the element are executed.
4267 An error in FORMS does not undo the load, but does prevent execution of
4268 the rest of the FORMS. */);
4269 Vafter_load_alist = Qnil;
4271 DEFVAR_LISP ("load-history", &Vload_history,
4272 doc: /* Alist mapping file names to symbols and features.
4273 Each alist element is a list that starts with a file name,
4274 except for one element (optional) that starts with nil and describes
4275 definitions evaluated from buffers not visiting files.
4277 The file name is absolute and is the true file name (i.e. it doesn't
4278 contain symbolic links) of the loaded file.
4280 The remaining elements of each list are symbols defined as variables
4281 and cons cells of the form `(provide . FEATURE)', `(require . FEATURE)',
4282 `(defun . FUNCTION)', `(autoload . SYMBOL)', `(defface . SYMBOL)'
4283 and `(t . SYMBOL)'. An element `(t . SYMBOL)' precedes an entry
4284 `(defun . FUNCTION)', and means that SYMBOL was an autoload before
4285 this file redefined it as a function.
4287 During preloading, the file name recorded is relative to the main Lisp
4288 directory. These file names are converted to absolute at startup. */);
4289 Vload_history = Qnil;
4291 DEFVAR_LISP ("load-file-name", &Vload_file_name,
4292 doc: /* Full name of file being loaded by `load'. */);
4293 Vload_file_name = Qnil;
4295 DEFVAR_LISP ("user-init-file", &Vuser_init_file,
4296 doc: /* File name, including directory, of user's initialization file.
4297 If the file loaded had extension `.elc', and the corresponding source file
4298 exists, this variable contains the name of source file, suitable for use
4299 by functions like `custom-save-all' which edit the init file.
4300 While Emacs loads and evaluates the init file, value is the real name
4301 of the file, regardless of whether or not it has the `.elc' extension. */);
4302 Vuser_init_file = Qnil;
4304 DEFVAR_LISP ("current-load-list", &Vcurrent_load_list,
4305 doc: /* Used for internal purposes by `load'. */);
4306 Vcurrent_load_list = Qnil;
4308 DEFVAR_LISP ("load-read-function", &Vload_read_function,
4309 doc: /* Function used by `load' and `eval-region' for reading expressions.
4310 The default is nil, which means use the function `read'. */);
4311 Vload_read_function = Qnil;
4313 DEFVAR_LISP ("load-source-file-function", &Vload_source_file_function,
4314 doc: /* Function called in `load' for loading an Emacs Lisp source file.
4315 This function is for doing code conversion before reading the source file.
4316 If nil, loading is done without any code conversion.
4317 Arguments are FULLNAME, FILE, NOERROR, NOMESSAGE, where
4318 FULLNAME is the full name of FILE.
4319 See `load' for the meaning of the remaining arguments. */);
4320 Vload_source_file_function = Qnil;
4322 DEFVAR_BOOL ("load-force-doc-strings", &load_force_doc_strings,
4323 doc: /* Non-nil means `load' should force-load all dynamic doc strings.
4324 This is useful when the file being loaded is a temporary copy. */);
4325 load_force_doc_strings = 0;
4327 DEFVAR_BOOL ("load-convert-to-unibyte", &load_convert_to_unibyte,
4328 doc: /* Non-nil means `read' converts strings to unibyte whenever possible.
4329 This is normally bound by `load' and `eval-buffer' to control `read',
4330 and is not meant for users to change. */);
4331 load_convert_to_unibyte = 0;
4333 DEFVAR_LISP ("source-directory", &Vsource_directory,
4334 doc: /* Directory in which Emacs sources were found when Emacs was built.
4335 You cannot count on them to still be there! */);
4336 Vsource_directory
4337 = Fexpand_file_name (build_string ("../"),
4338 Fcar (decode_env_path (0, PATH_DUMPLOADSEARCH)));
4340 DEFVAR_LISP ("preloaded-file-list", &Vpreloaded_file_list,
4341 doc: /* List of files that were preloaded (when dumping Emacs). */);
4342 Vpreloaded_file_list = Qnil;
4344 DEFVAR_LISP ("byte-boolean-vars", &Vbyte_boolean_vars,
4345 doc: /* List of all DEFVAR_BOOL variables, used by the byte code optimizer. */);
4346 Vbyte_boolean_vars = Qnil;
4348 DEFVAR_BOOL ("load-dangerous-libraries", &load_dangerous_libraries,
4349 doc: /* Non-nil means load dangerous compiled Lisp files.
4350 Some versions of XEmacs use different byte codes than Emacs. These
4351 incompatible byte codes can make Emacs crash when it tries to execute
4352 them. */);
4353 load_dangerous_libraries = 0;
4355 DEFVAR_LISP ("bytecomp-version-regexp", &Vbytecomp_version_regexp,
4356 doc: /* Regular expression matching safe to load compiled Lisp files.
4357 When Emacs loads a compiled Lisp file, it reads the first 512 bytes
4358 from the file, and matches them against this regular expression.
4359 When the regular expression matches, the file is considered to be safe
4360 to load. See also `load-dangerous-libraries'. */);
4361 Vbytecomp_version_regexp
4362 = build_string ("^;;;.\\(in Emacs version\\|bytecomp version FSF\\)");
4364 DEFVAR_LISP ("eval-buffer-list", &Veval_buffer_list,
4365 doc: /* List of buffers being read from by calls to `eval-buffer' and `eval-region'. */);
4366 Veval_buffer_list = Qnil;
4368 DEFVAR_LISP ("old-style-backquotes", &Vold_style_backquotes,
4369 doc: /* Set to non-nil when `read' encounters an old-style backquote. */);
4370 Vold_style_backquotes = Qnil;
4371 Qold_style_backquotes = intern ("old-style-backquotes");
4372 staticpro (&Qold_style_backquotes);
4374 /* Vsource_directory was initialized in init_lread. */
4376 load_descriptor_list = Qnil;
4377 staticpro (&load_descriptor_list);
4379 Qcurrent_load_list = intern ("current-load-list");
4380 staticpro (&Qcurrent_load_list);
4382 Qstandard_input = intern ("standard-input");
4383 staticpro (&Qstandard_input);
4385 Qread_char = intern ("read-char");
4386 staticpro (&Qread_char);
4388 Qget_file_char = intern ("get-file-char");
4389 staticpro (&Qget_file_char);
4391 Qget_emacs_mule_file_char = intern ("get-emacs-mule-file-char");
4392 staticpro (&Qget_emacs_mule_file_char);
4394 Qload_force_doc_strings = intern ("load-force-doc-strings");
4395 staticpro (&Qload_force_doc_strings);
4397 Qbackquote = intern ("`");
4398 staticpro (&Qbackquote);
4399 Qcomma = intern (",");
4400 staticpro (&Qcomma);
4401 Qcomma_at = intern (",@");
4402 staticpro (&Qcomma_at);
4403 Qcomma_dot = intern (",.");
4404 staticpro (&Qcomma_dot);
4406 Qinhibit_file_name_operation = intern ("inhibit-file-name-operation");
4407 staticpro (&Qinhibit_file_name_operation);
4409 Qascii_character = intern ("ascii-character");
4410 staticpro (&Qascii_character);
4412 Qfunction = intern ("function");
4413 staticpro (&Qfunction);
4415 Qload = intern ("load");
4416 staticpro (&Qload);
4418 Qload_file_name = intern ("load-file-name");
4419 staticpro (&Qload_file_name);
4421 Qeval_buffer_list = intern ("eval-buffer-list");
4422 staticpro (&Qeval_buffer_list);
4424 Qfile_truename = intern ("file-truename");
4425 staticpro (&Qfile_truename) ;
4427 Qdo_after_load_evaluation = intern ("do-after-load-evaluation");
4428 staticpro (&Qdo_after_load_evaluation) ;
4430 staticpro (&dump_path);
4432 staticpro (&read_objects);
4433 read_objects = Qnil;
4434 staticpro (&seen_list);
4435 seen_list = Qnil;
4437 Vloads_in_progress = Qnil;
4438 staticpro (&Vloads_in_progress);
4441 /* arch-tag: a0d02733-0f96-4844-a659-9fd53c4f414d
4442 (do not change this comment) */