Switch to recommended form of GPLv3 permissions notice.
[emacs.git] / src / lread.c
blob1bc9ec3ee0d08f9527c0ac91df89506ac2352810
1 /* Lisp parsing and input streams.
2 Copyright (C) 1985, 1986, 1987, 1988, 1989, 1993, 1994, 1995,
3 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
4 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
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 /* The association list of objects read with the #n=object form.
129 Each member of the list has the form (n . object), and is used to
130 look up the object for the corresponding #n# construct.
131 It must be set to nil before all top-level calls to read0. */
132 Lisp_Object read_objects;
134 /* Nonzero means load should forcibly load all dynamic doc strings. */
135 static int load_force_doc_strings;
137 /* Nonzero means read should convert strings to unibyte. */
138 static int load_convert_to_unibyte;
140 /* Nonzero means READCHAR should read bytes one by one (not character)
141 when READCHARFUN is Qget_file_char or Qget_emacs_mule_file_char.
142 This is set to 1 by read1 temporarily while handling #@NUMBER. */
143 static int load_each_byte;
145 /* Function to use for loading an Emacs Lisp source file (not
146 compiled) instead of readevalloop. */
147 Lisp_Object Vload_source_file_function;
149 /* List of all DEFVAR_BOOL variables. Used by the byte optimizer. */
150 Lisp_Object Vbyte_boolean_vars;
152 /* Whether or not to add a `read-positions' property to symbols
153 read. */
154 Lisp_Object Vread_with_symbol_positions;
156 /* List of (SYMBOL . POSITION) accumulated so far. */
157 Lisp_Object Vread_symbol_positions_list;
159 /* List of descriptors now open for Fload. */
160 static Lisp_Object load_descriptor_list;
162 /* File for get_file_char to read from. Use by load. */
163 static FILE *instream;
165 /* When nonzero, read conses in pure space */
166 static int read_pure;
168 /* For use within read-from-string (this reader is non-reentrant!!) */
169 static int read_from_string_index;
170 static int read_from_string_index_byte;
171 static int read_from_string_limit;
173 /* Number of characters read in the current call to Fread or
174 Fread_from_string. */
175 static int readchar_count;
177 /* This contains the last string skipped with #@. */
178 static char *saved_doc_string;
179 /* Length of buffer allocated in saved_doc_string. */
180 static int saved_doc_string_size;
181 /* Length of actual data in saved_doc_string. */
182 static int saved_doc_string_length;
183 /* This is the file position that string came from. */
184 static file_offset saved_doc_string_position;
186 /* This contains the previous string skipped with #@.
187 We copy it from saved_doc_string when a new string
188 is put in saved_doc_string. */
189 static char *prev_saved_doc_string;
190 /* Length of buffer allocated in prev_saved_doc_string. */
191 static int prev_saved_doc_string_size;
192 /* Length of actual data in prev_saved_doc_string. */
193 static int prev_saved_doc_string_length;
194 /* This is the file position that string came from. */
195 static file_offset prev_saved_doc_string_position;
197 /* Nonzero means inside a new-style backquote
198 with no surrounding parentheses.
199 Fread initializes this to zero, so we need not specbind it
200 or worry about what happens to it when there is an error. */
201 static int new_backquote_flag;
202 static Lisp_Object Vold_style_backquotes, Qold_style_backquotes;
204 /* A list of file names for files being loaded in Fload. Used to
205 check for recursive loads. */
207 static Lisp_Object Vloads_in_progress;
209 /* Non-zero means load dangerous compiled Lisp files. */
211 int load_dangerous_libraries;
213 /* A regular expression used to detect files compiled with Emacs. */
215 static Lisp_Object Vbytecomp_version_regexp;
217 static int read_emacs_mule_char P_ ((int, int (*) (int, Lisp_Object),
218 Lisp_Object));
220 static void readevalloop P_ ((Lisp_Object, FILE*, Lisp_Object,
221 Lisp_Object (*) (), int,
222 Lisp_Object, Lisp_Object,
223 Lisp_Object, Lisp_Object));
224 static Lisp_Object load_unwind P_ ((Lisp_Object));
225 static Lisp_Object load_descriptor_unwind P_ ((Lisp_Object));
227 static void invalid_syntax P_ ((const char *, int)) NO_RETURN;
228 static void end_of_file_error P_ (()) NO_RETURN;
231 /* Functions that read one byte from the current source READCHARFUN
232 or unreads one byte. If the integer argument C is -1, it returns
233 one read byte, or -1 when there's no more byte in the source. If C
234 is 0 or positive, it unreads C, and the return value is not
235 interesting. */
237 static int readbyte_for_lambda P_ ((int, Lisp_Object));
238 static int readbyte_from_file P_ ((int, Lisp_Object));
239 static int readbyte_from_string P_ ((int, Lisp_Object));
241 /* Handle unreading and rereading of characters.
242 Write READCHAR to read a character,
243 UNREAD(c) to unread c to be read again.
245 These macros correctly read/unread multibyte characters. */
247 #define READCHAR readchar (readcharfun, NULL)
248 #define UNREAD(c) unreadchar (readcharfun, c)
250 /* Same as READCHAR but set *MULTIBYTE to the multibyteness of the source. */
251 #define READCHAR_REPORT_MULTIBYTE(multibyte) readchar (readcharfun, multibyte)
253 /* When READCHARFUN is Qget_file_char, Qget_emacs_mule_file_char,
254 Qlambda, or a cons, we use this to keep an unread character because
255 a file stream can't handle multibyte-char unreading. The value -1
256 means that there's no unread character. */
257 static int unread_char;
259 static int
260 readchar (readcharfun, multibyte)
261 Lisp_Object readcharfun;
262 int *multibyte;
264 Lisp_Object tem;
265 register int c;
266 int (*readbyte) P_ ((int, Lisp_Object));
267 unsigned char buf[MAX_MULTIBYTE_LENGTH];
268 int i, len;
269 int emacs_mule_encoding = 0;
271 if (multibyte)
272 *multibyte = 0;
274 readchar_count++;
276 if (BUFFERP (readcharfun))
278 register struct buffer *inbuffer = XBUFFER (readcharfun);
280 int pt_byte = BUF_PT_BYTE (inbuffer);
282 if (pt_byte >= BUF_ZV_BYTE (inbuffer))
283 return -1;
285 if (! NILP (inbuffer->enable_multibyte_characters))
287 /* Fetch the character code from the buffer. */
288 unsigned char *p = BUF_BYTE_ADDRESS (inbuffer, pt_byte);
289 BUF_INC_POS (inbuffer, pt_byte);
290 c = STRING_CHAR (p, pt_byte - orig_pt_byte);
291 if (multibyte)
292 *multibyte = 1;
294 else
296 c = BUF_FETCH_BYTE (inbuffer, pt_byte);
297 if (! ASCII_BYTE_P (c))
298 c = BYTE8_TO_CHAR (c);
299 pt_byte++;
301 SET_BUF_PT_BOTH (inbuffer, BUF_PT (inbuffer) + 1, pt_byte);
303 return c;
305 if (MARKERP (readcharfun))
307 register struct buffer *inbuffer = XMARKER (readcharfun)->buffer;
309 int bytepos = marker_byte_position (readcharfun);
311 if (bytepos >= BUF_ZV_BYTE (inbuffer))
312 return -1;
314 if (! NILP (inbuffer->enable_multibyte_characters))
316 /* Fetch the character code from the buffer. */
317 unsigned char *p = BUF_BYTE_ADDRESS (inbuffer, bytepos);
318 BUF_INC_POS (inbuffer, bytepos);
319 c = STRING_CHAR (p, bytepos - orig_bytepos);
320 if (multibyte)
321 *multibyte = 1;
323 else
325 c = BUF_FETCH_BYTE (inbuffer, bytepos);
326 if (! ASCII_BYTE_P (c))
327 c = BYTE8_TO_CHAR (c);
328 bytepos++;
331 XMARKER (readcharfun)->bytepos = bytepos;
332 XMARKER (readcharfun)->charpos++;
334 return c;
337 if (EQ (readcharfun, Qlambda))
339 readbyte = readbyte_for_lambda;
340 goto read_multibyte;
343 if (EQ (readcharfun, Qget_file_char))
345 readbyte = readbyte_from_file;
346 goto read_multibyte;
349 if (STRINGP (readcharfun))
351 if (read_from_string_index >= read_from_string_limit)
352 c = -1;
353 else if (STRING_MULTIBYTE (readcharfun))
355 if (multibyte)
356 *multibyte = 1;
357 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c, readcharfun,
358 read_from_string_index,
359 read_from_string_index_byte);
361 else
363 c = SREF (readcharfun, read_from_string_index_byte);
364 read_from_string_index++;
365 read_from_string_index_byte++;
367 return c;
370 if (CONSP (readcharfun))
372 /* This is the case that read_vector is reading from a unibyte
373 string that contains a byte sequence previously skipped
374 because of #@NUMBER. The car part of readcharfun is that
375 string, and the cdr part is a value of readcharfun given to
376 read_vector. */
377 readbyte = readbyte_from_string;
378 if (EQ (XCDR (readcharfun), Qget_emacs_mule_file_char))
379 emacs_mule_encoding = 1;
380 goto read_multibyte;
383 if (EQ (readcharfun, Qget_emacs_mule_file_char))
385 readbyte = readbyte_from_file;
386 emacs_mule_encoding = 1;
387 goto read_multibyte;
390 tem = call0 (readcharfun);
392 if (NILP (tem))
393 return -1;
394 return XINT (tem);
396 read_multibyte:
397 if (unread_char >= 0)
399 c = unread_char;
400 unread_char = -1;
401 return c;
403 c = (*readbyte) (-1, readcharfun);
404 if (c < 0 || load_each_byte)
405 return c;
406 if (multibyte)
407 *multibyte = 1;
408 if (ASCII_BYTE_P (c))
409 return c;
410 if (emacs_mule_encoding)
411 return read_emacs_mule_char (c, readbyte, readcharfun);
412 i = 0;
413 buf[i++] = c;
414 len = BYTES_BY_CHAR_HEAD (c);
415 while (i < len)
417 c = (*readbyte) (-1, readcharfun);
418 if (c < 0 || ! TRAILING_CODE_P (c))
420 while (--i > 1)
421 (*readbyte) (buf[i], readcharfun);
422 return BYTE8_TO_CHAR (buf[0]);
424 buf[i++] = c;
426 return STRING_CHAR (buf, i);
429 /* Unread the character C in the way appropriate for the stream READCHARFUN.
430 If the stream is a user function, call it with the char as argument. */
432 static void
433 unreadchar (readcharfun, c)
434 Lisp_Object readcharfun;
435 int c;
437 readchar_count--;
438 if (c == -1)
439 /* Don't back up the pointer if we're unreading the end-of-input mark,
440 since readchar didn't advance it when we read it. */
442 else if (BUFFERP (readcharfun))
444 struct buffer *b = XBUFFER (readcharfun);
445 int bytepos = BUF_PT_BYTE (b);
447 BUF_PT (b)--;
448 if (! NILP (b->enable_multibyte_characters))
449 BUF_DEC_POS (b, bytepos);
450 else
451 bytepos--;
453 BUF_PT_BYTE (b) = bytepos;
455 else if (MARKERP (readcharfun))
457 struct buffer *b = XMARKER (readcharfun)->buffer;
458 int bytepos = XMARKER (readcharfun)->bytepos;
460 XMARKER (readcharfun)->charpos--;
461 if (! NILP (b->enable_multibyte_characters))
462 BUF_DEC_POS (b, bytepos);
463 else
464 bytepos--;
466 XMARKER (readcharfun)->bytepos = bytepos;
468 else if (STRINGP (readcharfun))
470 read_from_string_index--;
471 read_from_string_index_byte
472 = string_char_to_byte (readcharfun, read_from_string_index);
474 else if (CONSP (readcharfun))
476 unread_char = c;
478 else if (EQ (readcharfun, Qlambda))
480 unread_char = c;
482 else if (EQ (readcharfun, Qget_file_char)
483 || EQ (readcharfun, Qget_emacs_mule_file_char))
485 if (load_each_byte)
487 BLOCK_INPUT;
488 ungetc (c, instream);
489 UNBLOCK_INPUT;
491 else
492 unread_char = c;
494 else
495 call1 (readcharfun, make_number (c));
498 static int
499 readbyte_for_lambda (c, readcharfun)
500 int c;
501 Lisp_Object readcharfun;
503 return read_bytecode_char (c >= 0);
507 static int
508 readbyte_from_file (c, readcharfun)
509 int c;
510 Lisp_Object readcharfun;
512 if (c >= 0)
514 BLOCK_INPUT;
515 ungetc (c, instream);
516 UNBLOCK_INPUT;
517 return 0;
520 BLOCK_INPUT;
521 c = getc (instream);
523 #ifdef EINTR
524 /* Interrupted reads have been observed while reading over the network */
525 while (c == EOF && ferror (instream) && errno == EINTR)
527 UNBLOCK_INPUT;
528 QUIT;
529 BLOCK_INPUT;
530 clearerr (instream);
531 c = getc (instream);
533 #endif
535 UNBLOCK_INPUT;
537 return (c == EOF ? -1 : c);
540 static int
541 readbyte_from_string (c, readcharfun)
542 int c;
543 Lisp_Object readcharfun;
545 Lisp_Object string = XCAR (readcharfun);
547 if (c >= 0)
549 read_from_string_index--;
550 read_from_string_index_byte
551 = string_char_to_byte (string, read_from_string_index);
554 if (read_from_string_index >= read_from_string_limit)
555 c = -1;
556 else
557 FETCH_STRING_CHAR_ADVANCE (c, string,
558 read_from_string_index,
559 read_from_string_index_byte);
560 return c;
564 /* Read one non-ASCII character from INSTREAM. The character is
565 encoded in `emacs-mule' and the first byte is already read in
566 C. */
568 extern char emacs_mule_bytes[256];
570 static int
571 read_emacs_mule_char (c, readbyte, readcharfun)
572 int c;
573 int (*readbyte) P_ ((int, Lisp_Object));
574 Lisp_Object readcharfun;
576 /* Emacs-mule coding uses at most 4-byte for one character. */
577 unsigned char buf[4];
578 int len = emacs_mule_bytes[c];
579 struct charset *charset;
580 int i;
581 unsigned code;
583 if (len == 1)
584 /* C is not a valid leading-code of `emacs-mule'. */
585 return BYTE8_TO_CHAR (c);
587 i = 0;
588 buf[i++] = c;
589 while (i < len)
591 c = (*readbyte) (-1, readcharfun);
592 if (c < 0xA0)
594 while (--i > 1)
595 (*readbyte) (buf[i], readcharfun);
596 return BYTE8_TO_CHAR (buf[0]);
598 buf[i++] = c;
601 if (len == 2)
603 charset = emacs_mule_charset[buf[0]];
604 code = buf[1] & 0x7F;
606 else if (len == 3)
608 if (buf[0] == EMACS_MULE_LEADING_CODE_PRIVATE_11
609 || buf[0] == EMACS_MULE_LEADING_CODE_PRIVATE_12)
611 charset = emacs_mule_charset[buf[1]];
612 code = buf[2] & 0x7F;
614 else
616 charset = emacs_mule_charset[buf[0]];
617 code = ((buf[1] << 8) | buf[2]) & 0x7F7F;
620 else
622 charset = emacs_mule_charset[buf[1]];
623 code = ((buf[2] << 8) | buf[3]) & 0x7F7F;
625 c = DECODE_CHAR (charset, code);
626 if (c < 0)
627 Fsignal (Qinvalid_read_syntax,
628 Fcons (build_string ("invalid multibyte form"), Qnil));
629 return c;
633 static Lisp_Object read_internal_start P_ ((Lisp_Object, Lisp_Object,
634 Lisp_Object));
635 static Lisp_Object read0 P_ ((Lisp_Object));
636 static Lisp_Object read1 P_ ((Lisp_Object, int *, int));
638 static Lisp_Object read_list P_ ((int, Lisp_Object));
639 static Lisp_Object read_vector P_ ((Lisp_Object, int));
641 static Lisp_Object substitute_object_recurse P_ ((Lisp_Object, Lisp_Object,
642 Lisp_Object));
643 static void substitute_object_in_subtree P_ ((Lisp_Object,
644 Lisp_Object));
645 static void substitute_in_interval P_ ((INTERVAL, Lisp_Object));
648 /* Get a character from the tty. */
650 /* Read input events until we get one that's acceptable for our purposes.
652 If NO_SWITCH_FRAME is non-zero, switch-frame events are stashed
653 until we get a character we like, and then stuffed into
654 unread_switch_frame.
656 If ASCII_REQUIRED is non-zero, we check function key events to see
657 if the unmodified version of the symbol has a Qascii_character
658 property, and use that character, if present.
660 If ERROR_NONASCII is non-zero, we signal an error if the input we
661 get isn't an ASCII character with modifiers. If it's zero but
662 ASCII_REQUIRED is non-zero, we just re-read until we get an ASCII
663 character.
665 If INPUT_METHOD is nonzero, we invoke the current input method
666 if the character warrants that.
668 If SECONDS is a number, we wait that many seconds for input, and
669 return Qnil if no input arrives within that time. */
671 Lisp_Object
672 read_filtered_event (no_switch_frame, ascii_required, error_nonascii,
673 input_method, seconds)
674 int no_switch_frame, ascii_required, error_nonascii, input_method;
675 Lisp_Object seconds;
677 Lisp_Object val, delayed_switch_frame;
678 EMACS_TIME end_time;
680 #ifdef HAVE_WINDOW_SYSTEM
681 if (display_hourglass_p)
682 cancel_hourglass ();
683 #endif
685 delayed_switch_frame = Qnil;
687 /* Compute timeout. */
688 if (NUMBERP (seconds))
690 EMACS_TIME wait_time;
691 int sec, usec;
692 double duration = extract_float (seconds);
694 sec = (int) duration;
695 usec = (duration - sec) * 1000000;
696 EMACS_GET_TIME (end_time);
697 EMACS_SET_SECS_USECS (wait_time, sec, usec);
698 EMACS_ADD_TIME (end_time, end_time, wait_time);
701 /* Read until we get an acceptable event. */
702 retry:
704 val = read_char (0, 0, 0, (input_method ? Qnil : Qt), 0,
705 NUMBERP (seconds) ? &end_time : NULL);
706 while (INTEGERP (val) && XINT (val) == -2); /* wrong_kboard_jmpbuf */
708 if (BUFFERP (val))
709 goto retry;
711 /* switch-frame events are put off until after the next ASCII
712 character. This is better than signaling an error just because
713 the last characters were typed to a separate minibuffer frame,
714 for example. Eventually, some code which can deal with
715 switch-frame events will read it and process it. */
716 if (no_switch_frame
717 && EVENT_HAS_PARAMETERS (val)
718 && EQ (EVENT_HEAD_KIND (EVENT_HEAD (val)), Qswitch_frame))
720 delayed_switch_frame = val;
721 goto retry;
724 if (ascii_required && !(NUMBERP (seconds) && NILP (val)))
726 /* Convert certain symbols to their ASCII equivalents. */
727 if (SYMBOLP (val))
729 Lisp_Object tem, tem1;
730 tem = Fget (val, Qevent_symbol_element_mask);
731 if (!NILP (tem))
733 tem1 = Fget (Fcar (tem), Qascii_character);
734 /* Merge this symbol's modifier bits
735 with the ASCII equivalent of its basic code. */
736 if (!NILP (tem1))
737 XSETFASTINT (val, XINT (tem1) | XINT (Fcar (Fcdr (tem))));
741 /* If we don't have a character now, deal with it appropriately. */
742 if (!INTEGERP (val))
744 if (error_nonascii)
746 Vunread_command_events = Fcons (val, Qnil);
747 error ("Non-character input-event");
749 else
750 goto retry;
754 if (! NILP (delayed_switch_frame))
755 unread_switch_frame = delayed_switch_frame;
757 #if 0
759 #ifdef HAVE_WINDOW_SYSTEM
760 if (display_hourglass_p)
761 start_hourglass ();
762 #endif
764 #endif
766 return val;
769 DEFUN ("read-char", Fread_char, Sread_char, 0, 3, 0,
770 doc: /* Read a character from the command input (keyboard or macro).
771 It is returned as a number.
772 If the character has modifiers, they are resolved and reflected to the
773 character code if possible (e.g. C-SPC -> 0).
775 If the user generates an event which is not a character (i.e. a mouse
776 click or function key event), `read-char' signals an error. As an
777 exception, switch-frame events are put off until non-character events
778 can be read.
779 If you want to read non-character events, or ignore them, call
780 `read-event' or `read-char-exclusive' instead.
782 If the optional argument PROMPT is non-nil, display that as a prompt.
783 If the optional argument INHERIT-INPUT-METHOD is non-nil and some
784 input method is turned on in the current buffer, that input method
785 is used for reading a character.
786 If the optional argument SECONDS is non-nil, it should be a number
787 specifying the maximum number of seconds to wait for input. If no
788 input arrives in that time, return nil. SECONDS may be a
789 floating-point value. */)
790 (prompt, inherit_input_method, seconds)
791 Lisp_Object prompt, inherit_input_method, seconds;
793 Lisp_Object val;
794 int c;
796 if (! NILP (prompt))
797 message_with_string ("%s", prompt, 0);
798 val = read_filtered_event (1, 1, 1, ! NILP (inherit_input_method), seconds);
799 c = XINT (val);
800 return make_number (char_resolve_modifier_mask (c));
803 DEFUN ("read-event", Fread_event, Sread_event, 0, 3, 0,
804 doc: /* Read an event object from the input stream.
805 If the optional argument PROMPT is non-nil, display that as a prompt.
806 If the optional argument INHERIT-INPUT-METHOD is non-nil and some
807 input method is turned on in the current buffer, that input method
808 is used for reading a character.
809 If the optional argument SECONDS is non-nil, it should be a number
810 specifying the maximum number of seconds to wait for input. If no
811 input arrives in that time, return nil. SECONDS may be a
812 floating-point value. */)
813 (prompt, inherit_input_method, seconds)
814 Lisp_Object prompt, inherit_input_method, seconds;
816 if (! NILP (prompt))
817 message_with_string ("%s", prompt, 0);
818 return read_filtered_event (0, 0, 0, ! NILP (inherit_input_method), seconds);
821 DEFUN ("read-char-exclusive", Fread_char_exclusive, Sread_char_exclusive, 0, 3, 0,
822 doc: /* Read a character from the command input (keyboard or macro).
823 It is returned as a number. Non-character events are ignored.
824 If the character has modifiers, they are resolved and reflected to the
825 character code if possible (e.g. C-SPC -> 0).
827 If the optional argument PROMPT is non-nil, display that as a prompt.
828 If the optional argument INHERIT-INPUT-METHOD is non-nil and some
829 input method is turned on in the current buffer, that input method
830 is used for reading a character.
831 If the optional argument SECONDS is non-nil, it should be a number
832 specifying the maximum number of seconds to wait for input. If no
833 input arrives in that time, return nil. SECONDS may be a
834 floating-point value. */)
835 (prompt, inherit_input_method, seconds)
836 Lisp_Object prompt, inherit_input_method, seconds;
838 Lisp_Object val;
839 int c;
841 if (! NILP (prompt))
842 message_with_string ("%s", prompt, 0);
843 val = read_filtered_event (1, 1, 0, ! NILP (inherit_input_method), seconds);
844 c = XINT (val);
845 return make_number (char_resolve_modifier_mask (c));
848 DEFUN ("get-file-char", Fget_file_char, Sget_file_char, 0, 0, 0,
849 doc: /* Don't use this yourself. */)
852 register Lisp_Object val;
853 BLOCK_INPUT;
854 XSETINT (val, getc (instream));
855 UNBLOCK_INPUT;
856 return val;
861 /* Value is a version number of byte compiled code if the file
862 associated with file descriptor FD is a compiled Lisp file that's
863 safe to load. Only files compiled with Emacs are safe to load.
864 Files compiled with XEmacs can lead to a crash in Fbyte_code
865 because of an incompatible change in the byte compiler. */
867 static int
868 safe_to_load_p (fd)
869 int fd;
871 char buf[512];
872 int nbytes, i;
873 int safe_p = 1;
874 int version = 1;
876 /* Read the first few bytes from the file, and look for a line
877 specifying the byte compiler version used. */
878 nbytes = emacs_read (fd, buf, sizeof buf - 1);
879 if (nbytes > 0)
881 buf[nbytes] = '\0';
883 /* Skip to the next newline, skipping over the initial `ELC'
884 with NUL bytes following it, but note the version. */
885 for (i = 0; i < nbytes && buf[i] != '\n'; ++i)
886 if (i == 4)
887 version = buf[i];
889 if (i == nbytes
890 || fast_c_string_match_ignore_case (Vbytecomp_version_regexp,
891 buf + i) < 0)
892 safe_p = 0;
894 if (safe_p)
895 safe_p = version;
897 lseek (fd, 0, SEEK_SET);
898 return safe_p;
902 /* Callback for record_unwind_protect. Restore the old load list OLD,
903 after loading a file successfully. */
905 static Lisp_Object
906 record_load_unwind (old)
907 Lisp_Object old;
909 return Vloads_in_progress = old;
912 /* This handler function is used via internal_condition_case_1. */
914 static Lisp_Object
915 load_error_handler (data)
916 Lisp_Object data;
918 return Qnil;
921 static Lisp_Object
922 load_warn_old_style_backquotes (file)
923 Lisp_Object file;
925 if (!NILP (Vold_style_backquotes))
927 Lisp_Object args[2];
928 args[0] = build_string ("Loading `%s': old-style backquotes detected!");
929 args[1] = file;
930 Fmessage (2, args);
932 return Qnil;
935 DEFUN ("get-load-suffixes", Fget_load_suffixes, Sget_load_suffixes, 0, 0, 0,
936 doc: /* Return the suffixes that `load' should try if a suffix is \
937 required.
938 This uses the variables `load-suffixes' and `load-file-rep-suffixes'. */)
941 Lisp_Object lst = Qnil, suffixes = Vload_suffixes, suffix, ext;
942 while (CONSP (suffixes))
944 Lisp_Object exts = Vload_file_rep_suffixes;
945 suffix = XCAR (suffixes);
946 suffixes = XCDR (suffixes);
947 while (CONSP (exts))
949 ext = XCAR (exts);
950 exts = XCDR (exts);
951 lst = Fcons (concat2 (suffix, ext), lst);
954 return Fnreverse (lst);
957 DEFUN ("load", Fload, Sload, 1, 5, 0,
958 doc: /* Execute a file of Lisp code named FILE.
959 First try FILE with `.elc' appended, then try with `.el',
960 then try FILE unmodified (the exact suffixes in the exact order are
961 determined by `load-suffixes'). Environment variable references in
962 FILE are replaced with their values by calling `substitute-in-file-name'.
963 This function searches the directories in `load-path'.
965 If optional second arg NOERROR is non-nil,
966 report no error if FILE doesn't exist.
967 Print messages at start and end of loading unless
968 optional third arg NOMESSAGE is non-nil.
969 If optional fourth arg NOSUFFIX is non-nil, don't try adding
970 suffixes `.elc' or `.el' to the specified name FILE.
971 If optional fifth arg MUST-SUFFIX is non-nil, insist on
972 the suffix `.elc' or `.el'; don't accept just FILE unless
973 it ends in one of those suffixes or includes a directory name.
975 If this function fails to find a file, it may look for different
976 representations of that file before trying another file.
977 It does so by adding the non-empty suffixes in `load-file-rep-suffixes'
978 to the file name. Emacs uses this feature mainly to find compressed
979 versions of files when Auto Compression mode is enabled.
981 The exact suffixes that this function tries out, in the exact order,
982 are given by the value of the variable `load-file-rep-suffixes' if
983 NOSUFFIX is non-nil and by the return value of the function
984 `get-load-suffixes' if MUST-SUFFIX is non-nil. If both NOSUFFIX and
985 MUST-SUFFIX are nil, this function first tries out the latter suffixes
986 and then the former.
988 Loading a file records its definitions, and its `provide' and
989 `require' calls, in an element of `load-history' whose
990 car is the file name loaded. See `load-history'.
992 Return t if the file exists and loads successfully. */)
993 (file, noerror, nomessage, nosuffix, must_suffix)
994 Lisp_Object file, noerror, nomessage, nosuffix, must_suffix;
996 register FILE *stream;
997 register int fd = -1;
998 int count = SPECPDL_INDEX ();
999 struct gcpro gcpro1, gcpro2, gcpro3;
1000 Lisp_Object found, efound, hist_file_name;
1001 /* 1 means we printed the ".el is newer" message. */
1002 int newer = 0;
1003 /* 1 means we are loading a compiled file. */
1004 int compiled = 0;
1005 Lisp_Object handler;
1006 int safe_p = 1;
1007 char *fmode = "r";
1008 Lisp_Object tmp[2];
1009 int version;
1011 #ifdef DOS_NT
1012 fmode = "rt";
1013 #endif /* DOS_NT */
1015 CHECK_STRING (file);
1017 /* If file name is magic, call the handler. */
1018 /* This shouldn't be necessary any more now that `openp' handles it right.
1019 handler = Ffind_file_name_handler (file, Qload);
1020 if (!NILP (handler))
1021 return call5 (handler, Qload, file, noerror, nomessage, nosuffix); */
1023 /* Do this after the handler to avoid
1024 the need to gcpro noerror, nomessage and nosuffix.
1025 (Below here, we care only whether they are nil or not.)
1026 The presence of this call is the result of a historical accident:
1027 it used to be in every file-operation and when it got removed
1028 everywhere, it accidentally stayed here. Since then, enough people
1029 supposedly have things like (load "$PROJECT/foo.el") in their .emacs
1030 that it seemed risky to remove. */
1031 if (! NILP (noerror))
1033 file = internal_condition_case_1 (Fsubstitute_in_file_name, file,
1034 Qt, load_error_handler);
1035 if (NILP (file))
1036 return Qnil;
1038 else
1039 file = Fsubstitute_in_file_name (file);
1042 /* Avoid weird lossage with null string as arg,
1043 since it would try to load a directory as a Lisp file */
1044 if (SCHARS (file) > 0)
1046 int size = SBYTES (file);
1048 found = Qnil;
1049 GCPRO2 (file, found);
1051 if (! NILP (must_suffix))
1053 /* Don't insist on adding a suffix if FILE already ends with one. */
1054 if (size > 3
1055 && !strcmp (SDATA (file) + size - 3, ".el"))
1056 must_suffix = Qnil;
1057 else if (size > 4
1058 && !strcmp (SDATA (file) + size - 4, ".elc"))
1059 must_suffix = Qnil;
1060 /* Don't insist on adding a suffix
1061 if the argument includes a directory name. */
1062 else if (! NILP (Ffile_name_directory (file)))
1063 must_suffix = Qnil;
1066 fd = openp (Vload_path, file,
1067 (!NILP (nosuffix) ? Qnil
1068 : !NILP (must_suffix) ? Fget_load_suffixes ()
1069 : Fappend (2, (tmp[0] = Fget_load_suffixes (),
1070 tmp[1] = Vload_file_rep_suffixes,
1071 tmp))),
1072 &found, Qnil);
1073 UNGCPRO;
1076 if (fd == -1)
1078 if (NILP (noerror))
1079 xsignal2 (Qfile_error, build_string ("Cannot open load file"), file);
1080 return Qnil;
1083 /* Tell startup.el whether or not we found the user's init file. */
1084 if (EQ (Qt, Vuser_init_file))
1085 Vuser_init_file = found;
1087 /* If FD is -2, that means openp found a magic file. */
1088 if (fd == -2)
1090 if (NILP (Fequal (found, file)))
1091 /* If FOUND is a different file name from FILE,
1092 find its handler even if we have already inhibited
1093 the `load' operation on FILE. */
1094 handler = Ffind_file_name_handler (found, Qt);
1095 else
1096 handler = Ffind_file_name_handler (found, Qload);
1097 if (! NILP (handler))
1098 return call5 (handler, Qload, found, noerror, nomessage, Qt);
1101 /* Check if we're stuck in a recursive load cycle.
1103 2000-09-21: It's not possible to just check for the file loaded
1104 being a member of Vloads_in_progress. This fails because of the
1105 way the byte compiler currently works; `provide's are not
1106 evaluted, see font-lock.el/jit-lock.el as an example. This
1107 leads to a certain amount of ``normal'' recursion.
1109 Also, just loading a file recursively is not always an error in
1110 the general case; the second load may do something different. */
1112 int count = 0;
1113 Lisp_Object tem;
1114 for (tem = Vloads_in_progress; CONSP (tem); tem = XCDR (tem))
1115 if (!NILP (Fequal (found, XCAR (tem))))
1116 count++;
1117 if (count > 3)
1119 if (fd >= 0)
1120 emacs_close (fd);
1121 signal_error ("Recursive load", Fcons (found, Vloads_in_progress));
1123 record_unwind_protect (record_load_unwind, Vloads_in_progress);
1124 Vloads_in_progress = Fcons (found, Vloads_in_progress);
1127 /* Get the name for load-history. */
1128 hist_file_name = (! NILP (Vpurify_flag)
1129 ? Fconcat (2, (tmp[0] = Ffile_name_directory (file),
1130 tmp[1] = Ffile_name_nondirectory (found),
1131 tmp))
1132 : found) ;
1134 version = -1;
1136 /* Check for the presence of old-style quotes and warn about them. */
1137 specbind (Qold_style_backquotes, Qnil);
1138 record_unwind_protect (load_warn_old_style_backquotes, file);
1140 if (!bcmp (SDATA (found) + SBYTES (found) - 4,
1141 ".elc", 4)
1142 || (version = safe_to_load_p (fd)) > 0)
1143 /* Load .elc files directly, but not when they are
1144 remote and have no handler! */
1146 if (fd != -2)
1148 struct stat s1, s2;
1149 int result;
1151 GCPRO3 (file, found, hist_file_name);
1153 if (version < 0
1154 && ! (version = safe_to_load_p (fd)))
1156 safe_p = 0;
1157 if (!load_dangerous_libraries)
1159 if (fd >= 0)
1160 emacs_close (fd);
1161 error ("File `%s' was not compiled in Emacs",
1162 SDATA (found));
1164 else if (!NILP (nomessage))
1165 message_with_string ("File `%s' not compiled in Emacs", found, 1);
1168 compiled = 1;
1170 efound = ENCODE_FILE (found);
1172 #ifdef DOS_NT
1173 fmode = "rb";
1174 #endif /* DOS_NT */
1175 stat ((char *)SDATA (efound), &s1);
1176 SSET (efound, SBYTES (efound) - 1, 0);
1177 result = stat ((char *)SDATA (efound), &s2);
1178 SSET (efound, SBYTES (efound) - 1, 'c');
1180 if (result >= 0 && (unsigned) s1.st_mtime < (unsigned) s2.st_mtime)
1182 /* Make the progress messages mention that source is newer. */
1183 newer = 1;
1185 /* If we won't print another message, mention this anyway. */
1186 if (!NILP (nomessage))
1188 Lisp_Object msg_file;
1189 msg_file = Fsubstring (found, make_number (0), make_number (-1));
1190 message_with_string ("Source file `%s' newer than byte-compiled file",
1191 msg_file, 1);
1194 UNGCPRO;
1197 else
1199 /* We are loading a source file (*.el). */
1200 if (!NILP (Vload_source_file_function))
1202 Lisp_Object val;
1204 if (fd >= 0)
1205 emacs_close (fd);
1206 val = call4 (Vload_source_file_function, found, hist_file_name,
1207 NILP (noerror) ? Qnil : Qt,
1208 NILP (nomessage) ? Qnil : Qt);
1209 return unbind_to (count, val);
1213 GCPRO3 (file, found, hist_file_name);
1215 #ifdef WINDOWSNT
1216 emacs_close (fd);
1217 efound = ENCODE_FILE (found);
1218 stream = fopen ((char *) SDATA (efound), fmode);
1219 #else /* not WINDOWSNT */
1220 stream = fdopen (fd, fmode);
1221 #endif /* not WINDOWSNT */
1222 if (stream == 0)
1224 emacs_close (fd);
1225 error ("Failure to create stdio stream for %s", SDATA (file));
1228 if (! NILP (Vpurify_flag))
1229 Vpreloaded_file_list = Fcons (file, Vpreloaded_file_list);
1231 if (NILP (nomessage))
1233 if (!safe_p)
1234 message_with_string ("Loading %s (compiled; note unsafe, not compiled in Emacs)...",
1235 file, 1);
1236 else if (!compiled)
1237 message_with_string ("Loading %s (source)...", file, 1);
1238 else if (newer)
1239 message_with_string ("Loading %s (compiled; note, source file is newer)...",
1240 file, 1);
1241 else /* The typical case; compiled file newer than source file. */
1242 message_with_string ("Loading %s...", file, 1);
1245 record_unwind_protect (load_unwind, make_save_value (stream, 0));
1246 record_unwind_protect (load_descriptor_unwind, load_descriptor_list);
1247 specbind (Qload_file_name, found);
1248 specbind (Qinhibit_file_name_operation, Qnil);
1249 load_descriptor_list
1250 = Fcons (make_number (fileno (stream)), load_descriptor_list);
1251 load_in_progress++;
1252 if (! version || version >= 22)
1253 readevalloop (Qget_file_char, stream, hist_file_name,
1254 Feval, 0, Qnil, Qnil, Qnil, Qnil);
1255 else
1257 /* We can't handle a file which was compiled with
1258 byte-compile-dynamic by older version of Emacs. */
1259 specbind (Qload_force_doc_strings, Qt);
1260 readevalloop (Qget_emacs_mule_file_char, stream, hist_file_name, Feval,
1261 0, Qnil, Qnil, Qnil, Qnil);
1263 unbind_to (count, Qnil);
1265 /* Run any eval-after-load forms for this file */
1266 if (NILP (Vpurify_flag)
1267 && (!NILP (Ffboundp (Qdo_after_load_evaluation))))
1268 call1 (Qdo_after_load_evaluation, hist_file_name) ;
1270 UNGCPRO;
1272 if (saved_doc_string)
1273 free (saved_doc_string);
1274 saved_doc_string = 0;
1275 saved_doc_string_size = 0;
1277 if (prev_saved_doc_string)
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]))
1348 #ifdef VMS
1349 || index (s, ':')
1350 #endif /* VMS */
1354 DEFUN ("locate-file-internal", Flocate_file_internal, Slocate_file_internal, 2, 4, 0,
1355 doc: /* Search for FILENAME through PATH.
1356 Returns the file's name in absolute form, or nil if not found.
1357 If SUFFIXES is non-nil, it should be a list of suffixes to append to
1358 file name when searching.
1359 If non-nil, PREDICATE is used instead of `file-readable-p'.
1360 PREDICATE can also be an integer to pass to the access(2) function,
1361 in which case file-name-handlers are ignored. */)
1362 (filename, path, suffixes, predicate)
1363 Lisp_Object filename, path, suffixes, predicate;
1365 Lisp_Object file;
1366 int fd = openp (path, filename, suffixes, &file, predicate);
1367 if (NILP (predicate) && fd > 0)
1368 close (fd);
1369 return file;
1373 /* Search for a file whose name is STR, looking in directories
1374 in the Lisp list PATH, and trying suffixes from SUFFIX.
1375 On success, returns a file descriptor. On failure, returns -1.
1377 SUFFIXES is a list of strings containing possible suffixes.
1378 The empty suffix is automatically added if the list is empty.
1380 PREDICATE non-nil means don't open the files,
1381 just look for one that satisfies the predicate. In this case,
1382 returns 1 on success. The predicate can be a lisp function or
1383 an integer to pass to `access' (in which case file-name-handlers
1384 are ignored).
1386 If STOREPTR is nonzero, it points to a slot where the name of
1387 the file actually found should be stored as a Lisp string.
1388 nil is stored there on failure.
1390 If the file we find is remote, return -2
1391 but store the found remote file name in *STOREPTR. */
1394 openp (path, str, suffixes, storeptr, predicate)
1395 Lisp_Object path, str;
1396 Lisp_Object suffixes;
1397 Lisp_Object *storeptr;
1398 Lisp_Object predicate;
1400 register int fd;
1401 int fn_size = 100;
1402 char buf[100];
1403 register char *fn = buf;
1404 int absolute = 0;
1405 int want_size;
1406 Lisp_Object filename;
1407 struct stat st;
1408 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5, gcpro6;
1409 Lisp_Object string, tail, encoded_fn;
1410 int max_suffix_len = 0;
1412 CHECK_STRING (str);
1414 for (tail = suffixes; CONSP (tail); tail = XCDR (tail))
1416 CHECK_STRING_CAR (tail);
1417 max_suffix_len = max (max_suffix_len,
1418 SBYTES (XCAR (tail)));
1421 string = filename = encoded_fn = Qnil;
1422 GCPRO6 (str, string, filename, path, suffixes, encoded_fn);
1424 if (storeptr)
1425 *storeptr = Qnil;
1427 if (complete_filename_p (str))
1428 absolute = 1;
1430 for (; CONSP (path); path = XCDR (path))
1432 filename = Fexpand_file_name (str, XCAR (path));
1433 if (!complete_filename_p (filename))
1434 /* If there are non-absolute elts in PATH (eg ".") */
1435 /* Of course, this could conceivably lose if luser sets
1436 default-directory to be something non-absolute... */
1438 filename = Fexpand_file_name (filename, current_buffer->directory);
1439 if (!complete_filename_p (filename))
1440 /* Give up on this path element! */
1441 continue;
1444 /* Calculate maximum size of any filename made from
1445 this path element/specified file name and any possible suffix. */
1446 want_size = max_suffix_len + SBYTES (filename) + 1;
1447 if (fn_size < want_size)
1448 fn = (char *) alloca (fn_size = 100 + want_size);
1450 /* Loop over suffixes. */
1451 for (tail = NILP (suffixes) ? Fcons (empty_unibyte_string, Qnil) : suffixes;
1452 CONSP (tail); tail = XCDR (tail))
1454 int lsuffix = SBYTES (XCAR (tail));
1455 Lisp_Object handler;
1456 int exists;
1458 /* Concatenate path element/specified name with the suffix.
1459 If the directory starts with /:, remove that. */
1460 if (SCHARS (filename) > 2
1461 && SREF (filename, 0) == '/'
1462 && SREF (filename, 1) == ':')
1464 strncpy (fn, SDATA (filename) + 2,
1465 SBYTES (filename) - 2);
1466 fn[SBYTES (filename) - 2] = 0;
1468 else
1470 strncpy (fn, SDATA (filename),
1471 SBYTES (filename));
1472 fn[SBYTES (filename)] = 0;
1475 if (lsuffix != 0) /* Bug happens on CCI if lsuffix is 0. */
1476 strncat (fn, SDATA (XCAR (tail)), lsuffix);
1478 /* Check that the file exists and is not a directory. */
1479 /* We used to only check for handlers on non-absolute file names:
1480 if (absolute)
1481 handler = Qnil;
1482 else
1483 handler = Ffind_file_name_handler (filename, Qfile_exists_p);
1484 It's not clear why that was the case and it breaks things like
1485 (load "/bar.el") where the file is actually "/bar.el.gz". */
1486 string = build_string (fn);
1487 handler = Ffind_file_name_handler (string, Qfile_exists_p);
1488 if ((!NILP (handler) || !NILP (predicate)) && !NATNUMP (predicate))
1490 if (NILP (predicate))
1491 exists = !NILP (Ffile_readable_p (string));
1492 else
1493 exists = !NILP (call1 (predicate, string));
1494 if (exists && !NILP (Ffile_directory_p (string)))
1495 exists = 0;
1497 if (exists)
1499 /* We succeeded; return this descriptor and filename. */
1500 if (storeptr)
1501 *storeptr = string;
1502 UNGCPRO;
1503 return -2;
1506 else
1508 const char *pfn;
1510 encoded_fn = ENCODE_FILE (string);
1511 pfn = SDATA (encoded_fn);
1512 exists = (stat (pfn, &st) >= 0
1513 && (st.st_mode & S_IFMT) != S_IFDIR);
1514 if (exists)
1516 /* Check that we can access or open it. */
1517 if (NATNUMP (predicate))
1518 fd = (access (pfn, XFASTINT (predicate)) == 0) ? 1 : -1;
1519 else
1520 fd = emacs_open (pfn, O_RDONLY, 0);
1522 if (fd >= 0)
1524 /* We succeeded; return this descriptor and filename. */
1525 if (storeptr)
1526 *storeptr = string;
1527 UNGCPRO;
1528 return fd;
1533 if (absolute)
1534 break;
1537 UNGCPRO;
1538 return -1;
1542 /* Merge the list we've accumulated of globals from the current input source
1543 into the load_history variable. The details depend on whether
1544 the source has an associated file name or not.
1546 FILENAME is the file name that we are loading from.
1547 ENTIRE is 1 if loading that entire file, 0 if evaluating part of it. */
1549 static void
1550 build_load_history (filename, entire)
1551 Lisp_Object filename;
1552 int entire;
1554 register Lisp_Object tail, prev, newelt;
1555 register Lisp_Object tem, tem2;
1556 register int foundit = 0;
1558 tail = Vload_history;
1559 prev = Qnil;
1561 while (CONSP (tail))
1563 tem = XCAR (tail);
1565 /* Find the feature's previous assoc list... */
1566 if (!NILP (Fequal (filename, Fcar (tem))))
1568 foundit = 1;
1570 /* If we're loading the entire file, remove old data. */
1571 if (entire)
1573 if (NILP (prev))
1574 Vload_history = XCDR (tail);
1575 else
1576 Fsetcdr (prev, XCDR (tail));
1579 /* Otherwise, cons on new symbols that are not already members. */
1580 else
1582 tem2 = Vcurrent_load_list;
1584 while (CONSP (tem2))
1586 newelt = XCAR (tem2);
1588 if (NILP (Fmember (newelt, tem)))
1589 Fsetcar (tail, Fcons (XCAR (tem),
1590 Fcons (newelt, XCDR (tem))));
1592 tem2 = XCDR (tem2);
1593 QUIT;
1597 else
1598 prev = tail;
1599 tail = XCDR (tail);
1600 QUIT;
1603 /* If we're loading an entire file, cons the new assoc onto the
1604 front of load-history, the most-recently-loaded position. Also
1605 do this if we didn't find an existing member for the file. */
1606 if (entire || !foundit)
1607 Vload_history = Fcons (Fnreverse (Vcurrent_load_list),
1608 Vload_history);
1611 Lisp_Object
1612 unreadpure (junk) /* Used as unwind-protect function in readevalloop */
1613 Lisp_Object junk;
1615 read_pure = 0;
1616 return Qnil;
1619 static Lisp_Object
1620 readevalloop_1 (old)
1621 Lisp_Object old;
1623 load_convert_to_unibyte = ! NILP (old);
1624 return Qnil;
1627 /* Signal an `end-of-file' error, if possible with file name
1628 information. */
1630 static void
1631 end_of_file_error ()
1633 if (STRINGP (Vload_file_name))
1634 xsignal1 (Qend_of_file, Vload_file_name);
1636 xsignal0 (Qend_of_file);
1639 /* UNIBYTE specifies how to set load_convert_to_unibyte
1640 for this invocation.
1641 READFUN, if non-nil, is used instead of `read'.
1643 START, END specify region to read in current buffer (from eval-region).
1644 If the input is not from a buffer, they must be nil. */
1646 static void
1647 readevalloop (readcharfun, stream, sourcename, evalfun,
1648 printflag, unibyte, readfun, start, end)
1649 Lisp_Object readcharfun;
1650 FILE *stream;
1651 Lisp_Object sourcename;
1652 Lisp_Object (*evalfun) ();
1653 int printflag;
1654 Lisp_Object unibyte, readfun;
1655 Lisp_Object start, end;
1657 register int c;
1658 register Lisp_Object val;
1659 int count = SPECPDL_INDEX ();
1660 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
1661 struct buffer *b = 0;
1662 int continue_reading_p;
1663 /* Nonzero if reading an entire buffer. */
1664 int whole_buffer = 0;
1665 /* 1 on the first time around. */
1666 int first_sexp = 1;
1668 if (MARKERP (readcharfun))
1670 if (NILP (start))
1671 start = readcharfun;
1674 if (BUFFERP (readcharfun))
1675 b = XBUFFER (readcharfun);
1676 else if (MARKERP (readcharfun))
1677 b = XMARKER (readcharfun)->buffer;
1679 /* We assume START is nil when input is not from a buffer. */
1680 if (! NILP (start) && !b)
1681 abort ();
1683 specbind (Qstandard_input, readcharfun); /* GCPROs readcharfun. */
1684 specbind (Qcurrent_load_list, Qnil);
1685 record_unwind_protect (readevalloop_1, load_convert_to_unibyte ? Qt : Qnil);
1686 load_convert_to_unibyte = !NILP (unibyte);
1688 GCPRO4 (sourcename, readfun, start, end);
1690 /* Try to ensure sourcename is a truename, except whilst preloading. */
1691 if (NILP (Vpurify_flag)
1692 && !NILP (sourcename) && !NILP (Ffile_name_absolute_p (sourcename))
1693 && !NILP (Ffboundp (Qfile_truename)))
1694 sourcename = call1 (Qfile_truename, sourcename) ;
1696 LOADHIST_ATTACH (sourcename);
1698 continue_reading_p = 1;
1699 while (continue_reading_p)
1701 int count1 = SPECPDL_INDEX ();
1703 if (b != 0 && NILP (b->name))
1704 error ("Reading from killed buffer");
1706 if (!NILP (start))
1708 /* Switch to the buffer we are reading from. */
1709 record_unwind_protect (save_excursion_restore, save_excursion_save ());
1710 set_buffer_internal (b);
1712 /* Save point in it. */
1713 record_unwind_protect (save_excursion_restore, save_excursion_save ());
1714 /* Save ZV in it. */
1715 record_unwind_protect (save_restriction_restore, save_restriction_save ());
1716 /* Those get unbound after we read one expression. */
1718 /* Set point and ZV around stuff to be read. */
1719 Fgoto_char (start);
1720 if (!NILP (end))
1721 Fnarrow_to_region (make_number (BEGV), end);
1723 /* Just for cleanliness, convert END to a marker
1724 if it is an integer. */
1725 if (INTEGERP (end))
1726 end = Fpoint_max_marker ();
1729 /* On the first cycle, we can easily test here
1730 whether we are reading the whole buffer. */
1731 if (b && first_sexp)
1732 whole_buffer = (PT == BEG && ZV == Z);
1734 instream = stream;
1735 read_next:
1736 c = READCHAR;
1737 if (c == ';')
1739 while ((c = READCHAR) != '\n' && c != -1);
1740 goto read_next;
1742 if (c < 0)
1744 unbind_to (count1, Qnil);
1745 break;
1748 /* Ignore whitespace here, so we can detect eof. */
1749 if (c == ' ' || c == '\t' || c == '\n' || c == '\f' || c == '\r'
1750 || c == 0x8a0) /* NBSP */
1751 goto read_next;
1753 if (!NILP (Vpurify_flag) && c == '(')
1755 record_unwind_protect (unreadpure, Qnil);
1756 val = read_list (-1, readcharfun);
1758 else
1760 UNREAD (c);
1761 read_objects = Qnil;
1762 if (!NILP (readfun))
1764 val = call1 (readfun, readcharfun);
1766 /* If READCHARFUN has set point to ZV, we should
1767 stop reading, even if the form read sets point
1768 to a different value when evaluated. */
1769 if (BUFFERP (readcharfun))
1771 struct buffer *b = XBUFFER (readcharfun);
1772 if (BUF_PT (b) == BUF_ZV (b))
1773 continue_reading_p = 0;
1776 else if (! NILP (Vload_read_function))
1777 val = call1 (Vload_read_function, readcharfun);
1778 else
1779 val = read_internal_start (readcharfun, Qnil, Qnil);
1782 if (!NILP (start) && continue_reading_p)
1783 start = Fpoint_marker ();
1785 /* Restore saved point and BEGV. */
1786 unbind_to (count1, Qnil);
1788 /* Now eval what we just read. */
1789 val = (*evalfun) (val);
1791 if (printflag)
1793 Vvalues = Fcons (val, Vvalues);
1794 if (EQ (Vstandard_output, Qt))
1795 Fprin1 (val, Qnil);
1796 else
1797 Fprint (val, Qnil);
1800 first_sexp = 0;
1803 build_load_history (sourcename,
1804 stream || whole_buffer);
1806 UNGCPRO;
1808 unbind_to (count, Qnil);
1811 DEFUN ("eval-buffer", Feval_buffer, Seval_buffer, 0, 5, "",
1812 doc: /* Execute the current buffer as Lisp code.
1813 Programs can pass two arguments, BUFFER and PRINTFLAG.
1814 BUFFER is the buffer to evaluate (nil means use current buffer).
1815 PRINTFLAG controls printing of output:
1816 A value of nil means discard it; anything else is stream for print.
1818 If the optional third argument FILENAME is non-nil,
1819 it specifies the file name to use for `load-history'.
1820 The optional fourth argument UNIBYTE specifies `load-convert-to-unibyte'
1821 for this invocation.
1823 The optional fifth argument DO-ALLOW-PRINT, if non-nil, specifies that
1824 `print' and related functions should work normally even if PRINTFLAG is nil.
1826 This function preserves the position of point. */)
1827 (buffer, printflag, filename, unibyte, do_allow_print)
1828 Lisp_Object buffer, printflag, filename, unibyte, do_allow_print;
1830 int count = SPECPDL_INDEX ();
1831 Lisp_Object tem, buf;
1833 if (NILP (buffer))
1834 buf = Fcurrent_buffer ();
1835 else
1836 buf = Fget_buffer (buffer);
1837 if (NILP (buf))
1838 error ("No such buffer");
1840 if (NILP (printflag) && NILP (do_allow_print))
1841 tem = Qsymbolp;
1842 else
1843 tem = printflag;
1845 if (NILP (filename))
1846 filename = XBUFFER (buf)->filename;
1848 specbind (Qeval_buffer_list, Fcons (buf, Veval_buffer_list));
1849 specbind (Qstandard_output, tem);
1850 record_unwind_protect (save_excursion_restore, save_excursion_save ());
1851 BUF_TEMP_SET_PT (XBUFFER (buf), BUF_BEGV (XBUFFER (buf)));
1852 readevalloop (buf, 0, filename, Feval,
1853 !NILP (printflag), unibyte, Qnil, Qnil, Qnil);
1854 unbind_to (count, Qnil);
1856 return Qnil;
1859 DEFUN ("eval-region", Feval_region, Seval_region, 2, 4, "r",
1860 doc: /* Execute the region as Lisp code.
1861 When called from programs, expects two arguments,
1862 giving starting and ending indices in the current buffer
1863 of the text to be executed.
1864 Programs can pass third argument PRINTFLAG which controls output:
1865 A value of nil means discard it; anything else is stream for printing it.
1866 Also the fourth argument READ-FUNCTION, if non-nil, is used
1867 instead of `read' to read each expression. It gets one argument
1868 which is the input stream for reading characters.
1870 This function does not move point. */)
1871 (start, end, printflag, read_function)
1872 Lisp_Object start, end, printflag, read_function;
1874 int count = SPECPDL_INDEX ();
1875 Lisp_Object tem, cbuf;
1877 cbuf = Fcurrent_buffer ();
1879 if (NILP (printflag))
1880 tem = Qsymbolp;
1881 else
1882 tem = printflag;
1883 specbind (Qstandard_output, tem);
1884 specbind (Qeval_buffer_list, Fcons (cbuf, Veval_buffer_list));
1886 /* readevalloop calls functions which check the type of start and end. */
1887 readevalloop (cbuf, 0, XBUFFER (cbuf)->filename, Feval,
1888 !NILP (printflag), Qnil, read_function,
1889 start, end);
1891 return unbind_to (count, Qnil);
1895 DEFUN ("read", Fread, Sread, 0, 1, 0,
1896 doc: /* Read one Lisp expression as text from STREAM, return as Lisp object.
1897 If STREAM is nil, use the value of `standard-input' (which see).
1898 STREAM or the value of `standard-input' may be:
1899 a buffer (read from point and advance it)
1900 a marker (read from where it points and advance it)
1901 a function (call it with no arguments for each character,
1902 call it with a char as argument to push a char back)
1903 a string (takes text from string, starting at the beginning)
1904 t (read text line using minibuffer and use it, or read from
1905 standard input in batch mode). */)
1906 (stream)
1907 Lisp_Object stream;
1909 if (NILP (stream))
1910 stream = Vstandard_input;
1911 if (EQ (stream, Qt))
1912 stream = Qread_char;
1913 if (EQ (stream, Qread_char))
1914 return Fread_minibuffer (build_string ("Lisp expression: "), Qnil);
1916 return read_internal_start (stream, Qnil, Qnil);
1919 DEFUN ("read-from-string", Fread_from_string, Sread_from_string, 1, 3, 0,
1920 doc: /* Read one Lisp expression which is represented as text by STRING.
1921 Returns a cons: (OBJECT-READ . FINAL-STRING-INDEX).
1922 START and END optionally delimit a substring of STRING from which to read;
1923 they default to 0 and (length STRING) respectively. */)
1924 (string, start, end)
1925 Lisp_Object string, start, end;
1927 Lisp_Object ret;
1928 CHECK_STRING (string);
1929 /* read_internal_start sets read_from_string_index. */
1930 ret = read_internal_start (string, start, end);
1931 return Fcons (ret, make_number (read_from_string_index));
1934 /* Function to set up the global context we need in toplevel read
1935 calls. */
1936 static Lisp_Object
1937 read_internal_start (stream, start, end)
1938 Lisp_Object stream;
1939 Lisp_Object start; /* Only used when stream is a string. */
1940 Lisp_Object end; /* Only used when stream is a string. */
1942 Lisp_Object retval;
1944 readchar_count = 0;
1945 new_backquote_flag = 0;
1946 read_objects = Qnil;
1947 if (EQ (Vread_with_symbol_positions, Qt)
1948 || EQ (Vread_with_symbol_positions, stream))
1949 Vread_symbol_positions_list = Qnil;
1951 if (STRINGP (stream)
1952 || ((CONSP (stream) && STRINGP (XCAR (stream)))))
1954 int startval, endval;
1955 Lisp_Object string;
1957 if (STRINGP (stream))
1958 string = stream;
1959 else
1960 string = XCAR (stream);
1962 if (NILP (end))
1963 endval = SCHARS (string);
1964 else
1966 CHECK_NUMBER (end);
1967 endval = XINT (end);
1968 if (endval < 0 || endval > SCHARS (string))
1969 args_out_of_range (string, end);
1972 if (NILP (start))
1973 startval = 0;
1974 else
1976 CHECK_NUMBER (start);
1977 startval = XINT (start);
1978 if (startval < 0 || startval > endval)
1979 args_out_of_range (string, start);
1981 read_from_string_index = startval;
1982 read_from_string_index_byte = string_char_to_byte (string, startval);
1983 read_from_string_limit = endval;
1986 retval = read0 (stream);
1987 if (EQ (Vread_with_symbol_positions, Qt)
1988 || EQ (Vread_with_symbol_positions, stream))
1989 Vread_symbol_positions_list = Fnreverse (Vread_symbol_positions_list);
1990 return retval;
1994 /* Signal Qinvalid_read_syntax error.
1995 S is error string of length N (if > 0) */
1997 static void
1998 invalid_syntax (s, n)
1999 const char *s;
2000 int n;
2002 if (!n)
2003 n = strlen (s);
2004 xsignal1 (Qinvalid_read_syntax, make_string (s, n));
2008 /* Use this for recursive reads, in contexts where internal tokens
2009 are not allowed. */
2011 static Lisp_Object
2012 read0 (readcharfun)
2013 Lisp_Object readcharfun;
2015 register Lisp_Object val;
2016 int c;
2018 val = read1 (readcharfun, &c, 0);
2019 if (!c)
2020 return val;
2022 xsignal1 (Qinvalid_read_syntax,
2023 Fmake_string (make_number (1), make_number (c)));
2026 static int read_buffer_size;
2027 static char *read_buffer;
2029 /* Read a \-escape sequence, assuming we already read the `\'.
2030 If the escape sequence forces unibyte, return eight-bit char. */
2032 static int
2033 read_escape (readcharfun, stringp)
2034 Lisp_Object readcharfun;
2035 int stringp;
2037 register int c = READCHAR;
2038 /* \u allows up to four hex digits, \U up to eight. Default to the
2039 behaviour for \u, and change this value in the case that \U is seen. */
2040 int unicode_hex_count = 4;
2042 switch (c)
2044 case -1:
2045 end_of_file_error ();
2047 case 'a':
2048 return '\007';
2049 case 'b':
2050 return '\b';
2051 case 'd':
2052 return 0177;
2053 case 'e':
2054 return 033;
2055 case 'f':
2056 return '\f';
2057 case 'n':
2058 return '\n';
2059 case 'r':
2060 return '\r';
2061 case 't':
2062 return '\t';
2063 case 'v':
2064 return '\v';
2065 case '\n':
2066 return -1;
2067 case ' ':
2068 if (stringp)
2069 return -1;
2070 return ' ';
2072 case 'M':
2073 c = READCHAR;
2074 if (c != '-')
2075 error ("Invalid escape character syntax");
2076 c = READCHAR;
2077 if (c == '\\')
2078 c = read_escape (readcharfun, 0);
2079 return c | meta_modifier;
2081 case 'S':
2082 c = READCHAR;
2083 if (c != '-')
2084 error ("Invalid escape character syntax");
2085 c = READCHAR;
2086 if (c == '\\')
2087 c = read_escape (readcharfun, 0);
2088 return c | shift_modifier;
2090 case 'H':
2091 c = READCHAR;
2092 if (c != '-')
2093 error ("Invalid escape character syntax");
2094 c = READCHAR;
2095 if (c == '\\')
2096 c = read_escape (readcharfun, 0);
2097 return c | hyper_modifier;
2099 case 'A':
2100 c = READCHAR;
2101 if (c != '-')
2102 error ("Invalid escape character syntax");
2103 c = READCHAR;
2104 if (c == '\\')
2105 c = read_escape (readcharfun, 0);
2106 return c | alt_modifier;
2108 case 's':
2109 c = READCHAR;
2110 if (stringp || c != '-')
2112 UNREAD (c);
2113 return ' ';
2115 c = READCHAR;
2116 if (c == '\\')
2117 c = read_escape (readcharfun, 0);
2118 return c | super_modifier;
2120 case 'C':
2121 c = READCHAR;
2122 if (c != '-')
2123 error ("Invalid escape character syntax");
2124 case '^':
2125 c = READCHAR;
2126 if (c == '\\')
2127 c = read_escape (readcharfun, 0);
2128 if ((c & ~CHAR_MODIFIER_MASK) == '?')
2129 return 0177 | (c & CHAR_MODIFIER_MASK);
2130 else if (! SINGLE_BYTE_CHAR_P ((c & ~CHAR_MODIFIER_MASK)))
2131 return c | ctrl_modifier;
2132 /* ASCII control chars are made from letters (both cases),
2133 as well as the non-letters within 0100...0137. */
2134 else if ((c & 0137) >= 0101 && (c & 0137) <= 0132)
2135 return (c & (037 | ~0177));
2136 else if ((c & 0177) >= 0100 && (c & 0177) <= 0137)
2137 return (c & (037 | ~0177));
2138 else
2139 return c | ctrl_modifier;
2141 case '0':
2142 case '1':
2143 case '2':
2144 case '3':
2145 case '4':
2146 case '5':
2147 case '6':
2148 case '7':
2149 /* An octal escape, as in ANSI C. */
2151 register int i = c - '0';
2152 register int count = 0;
2153 while (++count < 3)
2155 if ((c = READCHAR) >= '0' && c <= '7')
2157 i *= 8;
2158 i += c - '0';
2160 else
2162 UNREAD (c);
2163 break;
2167 if (i >= 0x80 && i < 0x100)
2168 i = BYTE8_TO_CHAR (i);
2169 return i;
2172 case 'x':
2173 /* A hex escape, as in ANSI C. */
2175 int i = 0;
2176 int count = 0;
2177 while (1)
2179 c = READCHAR;
2180 if (c >= '0' && c <= '9')
2182 i *= 16;
2183 i += c - '0';
2185 else if ((c >= 'a' && c <= 'f')
2186 || (c >= 'A' && c <= 'F'))
2188 i *= 16;
2189 if (c >= 'a' && c <= 'f')
2190 i += c - 'a' + 10;
2191 else
2192 i += c - 'A' + 10;
2194 else
2196 UNREAD (c);
2197 break;
2199 count++;
2202 if (count < 3 && i >= 0x80)
2203 return BYTE8_TO_CHAR (i);
2204 return i;
2207 case 'U':
2208 /* Post-Unicode-2.0: Up to eight hex chars. */
2209 unicode_hex_count = 8;
2210 case 'u':
2212 /* A Unicode escape. We only permit them in strings and characters,
2213 not arbitrarily in the source code, as in some other languages. */
2215 int i = 0;
2216 int count = 0;
2218 while (++count <= unicode_hex_count)
2220 c = READCHAR;
2221 /* isdigit and isalpha may be locale-specific, which we don't
2222 want. */
2223 if (c >= '0' && c <= '9') i = (i << 4) + (c - '0');
2224 else if (c >= 'a' && c <= 'f') i = (i << 4) + (c - 'a') + 10;
2225 else if (c >= 'A' && c <= 'F') i = (i << 4) + (c - 'A') + 10;
2226 else
2228 error ("Non-hex digit used for Unicode escape");
2229 break;
2233 return i;
2236 default:
2237 return c;
2241 /* Read an integer in radix RADIX using READCHARFUN to read
2242 characters. RADIX must be in the interval [2..36]; if it isn't, a
2243 read error is signaled . Value is the integer read. Signals an
2244 error if encountering invalid read syntax or if RADIX is out of
2245 range. */
2247 static Lisp_Object
2248 read_integer (readcharfun, radix)
2249 Lisp_Object readcharfun;
2250 int radix;
2252 int ndigits = 0, invalid_p, c, sign = 0;
2253 EMACS_INT number = 0;
2255 if (radix < 2 || radix > 36)
2256 invalid_p = 1;
2257 else
2259 number = ndigits = invalid_p = 0;
2260 sign = 1;
2262 c = READCHAR;
2263 if (c == '-')
2265 c = READCHAR;
2266 sign = -1;
2268 else if (c == '+')
2269 c = READCHAR;
2271 while (c >= 0)
2273 int digit;
2275 if (c >= '0' && c <= '9')
2276 digit = c - '0';
2277 else if (c >= 'a' && c <= 'z')
2278 digit = c - 'a' + 10;
2279 else if (c >= 'A' && c <= 'Z')
2280 digit = c - 'A' + 10;
2281 else
2283 UNREAD (c);
2284 break;
2287 if (digit < 0 || digit >= radix)
2288 invalid_p = 1;
2290 number = radix * number + digit;
2291 ++ndigits;
2292 c = READCHAR;
2296 if (ndigits == 0 || invalid_p)
2298 char buf[50];
2299 sprintf (buf, "integer, radix %d", radix);
2300 invalid_syntax (buf, 0);
2303 return make_number (sign * number);
2307 /* If the next token is ')' or ']' or '.', we store that character
2308 in *PCH and the return value is not interesting. Else, we store
2309 zero in *PCH and we read and return one lisp object.
2311 FIRST_IN_LIST is nonzero if this is the first element of a list. */
2313 static Lisp_Object
2314 read1 (readcharfun, pch, first_in_list)
2315 register Lisp_Object readcharfun;
2316 int *pch;
2317 int first_in_list;
2319 register int c;
2320 int uninterned_symbol = 0;
2321 int multibyte;
2323 *pch = 0;
2324 load_each_byte = 0;
2326 retry:
2328 c = READCHAR_REPORT_MULTIBYTE (&multibyte);
2329 if (c < 0)
2330 end_of_file_error ();
2332 switch (c)
2334 case '(':
2335 return read_list (0, readcharfun);
2337 case '[':
2338 return read_vector (readcharfun, 0);
2340 case ')':
2341 case ']':
2343 *pch = c;
2344 return Qnil;
2347 case '#':
2348 c = READCHAR;
2349 if (c == '^')
2351 c = READCHAR;
2352 if (c == '[')
2354 Lisp_Object tmp;
2355 tmp = read_vector (readcharfun, 0);
2356 if (XVECTOR (tmp)->size < CHAR_TABLE_STANDARD_SLOTS)
2357 error ("Invalid size char-table");
2358 XSETPVECTYPE (XVECTOR (tmp), PVEC_CHAR_TABLE);
2359 return tmp;
2361 else if (c == '^')
2363 c = READCHAR;
2364 if (c == '[')
2366 Lisp_Object tmp;
2367 int depth, size;
2369 tmp = read_vector (readcharfun, 0);
2370 if (!INTEGERP (AREF (tmp, 0)))
2371 error ("Invalid depth in char-table");
2372 depth = XINT (AREF (tmp, 0));
2373 if (depth < 1 || depth > 3)
2374 error ("Invalid depth in char-table");
2375 size = XVECTOR (tmp)->size - 2;
2376 if (chartab_size [depth] != size)
2377 error ("Invalid size char-table");
2378 XSETPVECTYPE (XVECTOR (tmp), PVEC_SUB_CHAR_TABLE);
2379 return tmp;
2381 invalid_syntax ("#^^", 3);
2383 invalid_syntax ("#^", 2);
2385 if (c == '&')
2387 Lisp_Object length;
2388 length = read1 (readcharfun, pch, first_in_list);
2389 c = READCHAR;
2390 if (c == '"')
2392 Lisp_Object tmp, val;
2393 int size_in_chars
2394 = ((XFASTINT (length) + BOOL_VECTOR_BITS_PER_CHAR - 1)
2395 / BOOL_VECTOR_BITS_PER_CHAR);
2397 UNREAD (c);
2398 tmp = read1 (readcharfun, pch, first_in_list);
2399 if (STRING_MULTIBYTE (tmp)
2400 || (size_in_chars != SCHARS (tmp)
2401 /* We used to print 1 char too many
2402 when the number of bits was a multiple of 8.
2403 Accept such input in case it came from an old
2404 version. */
2405 && ! (XFASTINT (length)
2406 == (SCHARS (tmp) - 1) * BOOL_VECTOR_BITS_PER_CHAR)))
2407 invalid_syntax ("#&...", 5);
2409 val = Fmake_bool_vector (length, Qnil);
2410 bcopy (SDATA (tmp), XBOOL_VECTOR (val)->data,
2411 size_in_chars);
2412 /* Clear the extraneous bits in the last byte. */
2413 if (XINT (length) != size_in_chars * BOOL_VECTOR_BITS_PER_CHAR)
2414 XBOOL_VECTOR (val)->data[size_in_chars - 1]
2415 &= (1 << (XINT (length) % BOOL_VECTOR_BITS_PER_CHAR)) - 1;
2416 return val;
2418 invalid_syntax ("#&...", 5);
2420 if (c == '[')
2422 /* Accept compiled functions at read-time so that we don't have to
2423 build them using function calls. */
2424 Lisp_Object tmp;
2425 tmp = read_vector (readcharfun, 1);
2426 return Fmake_byte_code (XVECTOR (tmp)->size,
2427 XVECTOR (tmp)->contents);
2429 if (c == '(')
2431 Lisp_Object tmp;
2432 struct gcpro gcpro1;
2433 int ch;
2435 /* Read the string itself. */
2436 tmp = read1 (readcharfun, &ch, 0);
2437 if (ch != 0 || !STRINGP (tmp))
2438 invalid_syntax ("#", 1);
2439 GCPRO1 (tmp);
2440 /* Read the intervals and their properties. */
2441 while (1)
2443 Lisp_Object beg, end, plist;
2445 beg = read1 (readcharfun, &ch, 0);
2446 end = plist = Qnil;
2447 if (ch == ')')
2448 break;
2449 if (ch == 0)
2450 end = read1 (readcharfun, &ch, 0);
2451 if (ch == 0)
2452 plist = read1 (readcharfun, &ch, 0);
2453 if (ch)
2454 invalid_syntax ("Invalid string property list", 0);
2455 Fset_text_properties (beg, end, plist, tmp);
2457 UNGCPRO;
2458 return tmp;
2461 /* #@NUMBER is used to skip NUMBER following characters.
2462 That's used in .elc files to skip over doc strings
2463 and function definitions. */
2464 if (c == '@')
2466 int i, nskip = 0;
2468 load_each_byte = 1;
2469 /* Read a decimal integer. */
2470 while ((c = READCHAR) >= 0
2471 && c >= '0' && c <= '9')
2473 nskip *= 10;
2474 nskip += c - '0';
2476 if (c >= 0)
2477 UNREAD (c);
2479 if (load_force_doc_strings
2480 && (EQ (readcharfun, Qget_file_char)
2481 || EQ (readcharfun, Qget_emacs_mule_file_char)))
2483 /* If we are supposed to force doc strings into core right now,
2484 record the last string that we skipped,
2485 and record where in the file it comes from. */
2487 /* But first exchange saved_doc_string
2488 with prev_saved_doc_string, so we save two strings. */
2490 char *temp = saved_doc_string;
2491 int temp_size = saved_doc_string_size;
2492 file_offset temp_pos = saved_doc_string_position;
2493 int temp_len = saved_doc_string_length;
2495 saved_doc_string = prev_saved_doc_string;
2496 saved_doc_string_size = prev_saved_doc_string_size;
2497 saved_doc_string_position = prev_saved_doc_string_position;
2498 saved_doc_string_length = prev_saved_doc_string_length;
2500 prev_saved_doc_string = temp;
2501 prev_saved_doc_string_size = temp_size;
2502 prev_saved_doc_string_position = temp_pos;
2503 prev_saved_doc_string_length = temp_len;
2506 if (saved_doc_string_size == 0)
2508 saved_doc_string_size = nskip + 100;
2509 saved_doc_string = (char *) xmalloc (saved_doc_string_size);
2511 if (nskip > saved_doc_string_size)
2513 saved_doc_string_size = nskip + 100;
2514 saved_doc_string = (char *) xrealloc (saved_doc_string,
2515 saved_doc_string_size);
2518 saved_doc_string_position = file_tell (instream);
2520 /* Copy that many characters into saved_doc_string. */
2521 for (i = 0; i < nskip && c >= 0; i++)
2522 saved_doc_string[i] = c = READCHAR;
2524 saved_doc_string_length = i;
2526 else
2528 /* Skip that many characters. */
2529 for (i = 0; i < nskip && c >= 0; i++)
2530 c = READCHAR;
2533 load_each_byte = 0;
2534 goto retry;
2536 if (c == '!')
2538 /* #! appears at the beginning of an executable file.
2539 Skip the first line. */
2540 while (c != '\n' && c >= 0)
2541 c = READCHAR;
2542 goto retry;
2544 if (c == '$')
2545 return Vload_file_name;
2546 if (c == '\'')
2547 return Fcons (Qfunction, Fcons (read0 (readcharfun), Qnil));
2548 /* #:foo is the uninterned symbol named foo. */
2549 if (c == ':')
2551 uninterned_symbol = 1;
2552 c = READCHAR;
2553 goto default_label;
2555 /* Reader forms that can reuse previously read objects. */
2556 if (c >= '0' && c <= '9')
2558 int n = 0;
2559 Lisp_Object tem;
2561 /* Read a non-negative integer. */
2562 while (c >= '0' && c <= '9')
2564 n *= 10;
2565 n += c - '0';
2566 c = READCHAR;
2568 /* #n=object returns object, but associates it with n for #n#. */
2569 if (c == '=')
2571 /* Make a placeholder for #n# to use temporarily */
2572 Lisp_Object placeholder;
2573 Lisp_Object cell;
2575 placeholder = Fcons(Qnil, Qnil);
2576 cell = Fcons (make_number (n), placeholder);
2577 read_objects = Fcons (cell, read_objects);
2579 /* Read the object itself. */
2580 tem = read0 (readcharfun);
2582 /* Now put it everywhere the placeholder was... */
2583 substitute_object_in_subtree (tem, placeholder);
2585 /* ...and #n# will use the real value from now on. */
2586 Fsetcdr (cell, tem);
2588 return tem;
2590 /* #n# returns a previously read object. */
2591 if (c == '#')
2593 tem = Fassq (make_number (n), read_objects);
2594 if (CONSP (tem))
2595 return XCDR (tem);
2596 /* Fall through to error message. */
2598 else if (c == 'r' || c == 'R')
2599 return read_integer (readcharfun, n);
2601 /* Fall through to error message. */
2603 else if (c == 'x' || c == 'X')
2604 return read_integer (readcharfun, 16);
2605 else if (c == 'o' || c == 'O')
2606 return read_integer (readcharfun, 8);
2607 else if (c == 'b' || c == 'B')
2608 return read_integer (readcharfun, 2);
2610 UNREAD (c);
2611 invalid_syntax ("#", 1);
2613 case ';':
2614 while ((c = READCHAR) >= 0 && c != '\n');
2615 goto retry;
2617 case '\'':
2619 return Fcons (Qquote, Fcons (read0 (readcharfun), Qnil));
2622 case '`':
2623 if (first_in_list)
2625 Vold_style_backquotes = Qt;
2626 goto default_label;
2628 else
2630 Lisp_Object value;
2632 new_backquote_flag++;
2633 value = read0 (readcharfun);
2634 new_backquote_flag--;
2636 return Fcons (Qbackquote, Fcons (value, Qnil));
2639 case ',':
2640 if (new_backquote_flag)
2642 Lisp_Object comma_type = Qnil;
2643 Lisp_Object value;
2644 int ch = READCHAR;
2646 if (ch == '@')
2647 comma_type = Qcomma_at;
2648 else if (ch == '.')
2649 comma_type = Qcomma_dot;
2650 else
2652 if (ch >= 0) UNREAD (ch);
2653 comma_type = Qcomma;
2656 new_backquote_flag--;
2657 value = read0 (readcharfun);
2658 new_backquote_flag++;
2659 return Fcons (comma_type, Fcons (value, Qnil));
2661 else
2663 Vold_style_backquotes = Qt;
2664 goto default_label;
2667 case '?':
2669 int modifiers;
2670 int next_char;
2671 int ok;
2673 c = READCHAR;
2674 if (c < 0)
2675 end_of_file_error ();
2677 /* Accept `single space' syntax like (list ? x) where the
2678 whitespace character is SPC or TAB.
2679 Other literal whitespace like NL, CR, and FF are not accepted,
2680 as there are well-established escape sequences for these. */
2681 if (c == ' ' || c == '\t')
2682 return make_number (c);
2684 if (c == '\\')
2685 c = read_escape (readcharfun, 0);
2686 modifiers = c & CHAR_MODIFIER_MASK;
2687 c &= ~CHAR_MODIFIER_MASK;
2688 if (CHAR_BYTE8_P (c))
2689 c = CHAR_TO_BYTE8 (c);
2690 c |= modifiers;
2692 next_char = READCHAR;
2693 if (next_char == '.')
2695 /* Only a dotted-pair dot is valid after a char constant. */
2696 int next_next_char = READCHAR;
2697 UNREAD (next_next_char);
2699 ok = (next_next_char <= 040
2700 || (next_next_char < 0200
2701 && (index ("\"';([#?", next_next_char)
2702 || (!first_in_list && next_next_char == '`')
2703 || (new_backquote_flag && next_next_char == ','))));
2705 else
2707 ok = (next_char <= 040
2708 || (next_char < 0200
2709 && (index ("\"';()[]#?", next_char)
2710 || (!first_in_list && next_char == '`')
2711 || (new_backquote_flag && next_char == ','))));
2713 UNREAD (next_char);
2714 if (ok)
2715 return make_number (c);
2717 invalid_syntax ("?", 1);
2720 case '"':
2722 char *p = read_buffer;
2723 char *end = read_buffer + read_buffer_size;
2724 register int c;
2725 /* Nonzero if we saw an escape sequence specifying
2726 a multibyte character. */
2727 int force_multibyte = 0;
2728 /* Nonzero if we saw an escape sequence specifying
2729 a single-byte character. */
2730 int force_singlebyte = 0;
2731 int cancel = 0;
2732 int nchars = 0;
2734 while ((c = READCHAR) >= 0
2735 && c != '\"')
2737 if (end - p < MAX_MULTIBYTE_LENGTH)
2739 int offset = p - read_buffer;
2740 read_buffer = (char *) xrealloc (read_buffer,
2741 read_buffer_size *= 2);
2742 p = read_buffer + offset;
2743 end = read_buffer + read_buffer_size;
2746 if (c == '\\')
2748 int modifiers;
2750 c = read_escape (readcharfun, 1);
2752 /* C is -1 if \ newline has just been seen */
2753 if (c == -1)
2755 if (p == read_buffer)
2756 cancel = 1;
2757 continue;
2760 modifiers = c & CHAR_MODIFIER_MASK;
2761 c = c & ~CHAR_MODIFIER_MASK;
2763 if (CHAR_BYTE8_P (c))
2764 force_singlebyte = 1;
2765 else if (! ASCII_CHAR_P (c))
2766 force_multibyte = 1;
2767 else /* i.e. ASCII_CHAR_P (c) */
2769 /* Allow `\C- ' and `\C-?'. */
2770 if (modifiers == CHAR_CTL)
2772 if (c == ' ')
2773 c = 0, modifiers = 0;
2774 else if (c == '?')
2775 c = 127, modifiers = 0;
2777 if (modifiers & CHAR_SHIFT)
2779 /* Shift modifier is valid only with [A-Za-z]. */
2780 if (c >= 'A' && c <= 'Z')
2781 modifiers &= ~CHAR_SHIFT;
2782 else if (c >= 'a' && c <= 'z')
2783 c -= ('a' - 'A'), modifiers &= ~CHAR_SHIFT;
2786 if (modifiers & CHAR_META)
2788 /* Move the meta bit to the right place for a
2789 string. */
2790 modifiers &= ~CHAR_META;
2791 c = BYTE8_TO_CHAR (c | 0x80);
2792 force_singlebyte = 1;
2796 /* Any modifiers remaining are invalid. */
2797 if (modifiers)
2798 error ("Invalid modifier in string");
2799 p += CHAR_STRING (c, (unsigned char *) p);
2801 else
2803 p += CHAR_STRING (c, (unsigned char *) p);
2804 if (CHAR_BYTE8_P (c))
2805 force_singlebyte = 1;
2806 else if (! ASCII_CHAR_P (c))
2807 force_multibyte = 1;
2809 nchars++;
2812 if (c < 0)
2813 end_of_file_error ();
2815 /* If purifying, and string starts with \ newline,
2816 return zero instead. This is for doc strings
2817 that we are really going to find in etc/DOC.nn.nn */
2818 if (!NILP (Vpurify_flag) && NILP (Vdoc_file_name) && cancel)
2819 return make_number (0);
2821 if (force_multibyte)
2822 /* READ_BUFFER already contains valid multibyte forms. */
2824 else if (force_singlebyte)
2826 nchars = str_as_unibyte (read_buffer, p - read_buffer);
2827 p = read_buffer + nchars;
2829 else
2830 /* Otherwise, READ_BUFFER contains only ASCII. */
2833 /* We want readchar_count to be the number of characters, not
2834 bytes. Hence we adjust for multibyte characters in the
2835 string. ... But it doesn't seem to be necessary, because
2836 READCHAR *does* read multibyte characters from buffers. */
2837 /* readchar_count -= (p - read_buffer) - nchars; */
2838 if (read_pure)
2839 return make_pure_string (read_buffer, nchars, p - read_buffer,
2840 (force_multibyte
2841 || (p - read_buffer != nchars)));
2842 return make_specified_string (read_buffer, nchars, p - read_buffer,
2843 (force_multibyte
2844 || (p - read_buffer != nchars)));
2847 case '.':
2849 int next_char = READCHAR;
2850 UNREAD (next_char);
2852 if (next_char <= 040
2853 || (next_char < 0200
2854 && (index ("\"';([#?", next_char)
2855 || (!first_in_list && next_char == '`')
2856 || (new_backquote_flag && next_char == ','))))
2858 *pch = c;
2859 return Qnil;
2862 /* Otherwise, we fall through! Note that the atom-reading loop
2863 below will now loop at least once, assuring that we will not
2864 try to UNREAD two characters in a row. */
2866 default:
2867 default_label:
2868 if (c <= 040) goto retry;
2869 if (c == 0x8a0) /* NBSP */
2870 goto retry;
2872 char *p = read_buffer;
2873 int quoted = 0;
2876 char *end = read_buffer + read_buffer_size;
2878 while (c > 040
2879 && c != 0x8a0 /* NBSP */
2880 && (c >= 0200
2881 || (!index ("\"';()[]#", c)
2882 && !(!first_in_list && c == '`')
2883 && !(new_backquote_flag && c == ','))))
2885 if (end - p < MAX_MULTIBYTE_LENGTH)
2887 int offset = p - read_buffer;
2888 read_buffer = (char *) xrealloc (read_buffer,
2889 read_buffer_size *= 2);
2890 p = read_buffer + offset;
2891 end = read_buffer + read_buffer_size;
2894 if (c == '\\')
2896 c = READCHAR;
2897 if (c == -1)
2898 end_of_file_error ();
2899 quoted = 1;
2902 if (multibyte)
2903 p += CHAR_STRING (c, p);
2904 else
2905 *p++ = c;
2906 c = READCHAR;
2909 if (p == end)
2911 int offset = p - read_buffer;
2912 read_buffer = (char *) xrealloc (read_buffer,
2913 read_buffer_size *= 2);
2914 p = read_buffer + offset;
2915 end = read_buffer + read_buffer_size;
2917 *p = 0;
2918 if (c >= 0)
2919 UNREAD (c);
2922 if (!quoted && !uninterned_symbol)
2924 register char *p1;
2925 register Lisp_Object val;
2926 p1 = read_buffer;
2927 if (*p1 == '+' || *p1 == '-') p1++;
2928 /* Is it an integer? */
2929 if (p1 != p)
2931 while (p1 != p && (c = *p1) >= '0' && c <= '9') p1++;
2932 /* Integers can have trailing decimal points. */
2933 if (p1 > read_buffer && p1 < p && *p1 == '.') p1++;
2934 if (p1 == p)
2935 /* It is an integer. */
2937 if (p1[-1] == '.')
2938 p1[-1] = '\0';
2939 /* Fixme: if we have strtol, use that, and check
2940 for overflow. */
2941 if (sizeof (int) == sizeof (EMACS_INT))
2942 XSETINT (val, atoi (read_buffer));
2943 else if (sizeof (long) == sizeof (EMACS_INT))
2944 XSETINT (val, atol (read_buffer));
2945 else
2946 abort ();
2947 return val;
2950 if (isfloat_string (read_buffer))
2952 /* Compute NaN and infinities using 0.0 in a variable,
2953 to cope with compilers that think they are smarter
2954 than we are. */
2955 double zero = 0.0;
2957 double value;
2959 /* Negate the value ourselves. This treats 0, NaNs,
2960 and infinity properly on IEEE floating point hosts,
2961 and works around a common bug where atof ("-0.0")
2962 drops the sign. */
2963 int negative = read_buffer[0] == '-';
2965 /* The only way p[-1] can be 'F' or 'N', after isfloat_string
2966 returns 1, is if the input ends in e+INF or e+NaN. */
2967 switch (p[-1])
2969 case 'F':
2970 value = 1.0 / zero;
2971 break;
2972 case 'N':
2973 value = zero / zero;
2975 /* If that made a "negative" NaN, negate it. */
2978 int i;
2979 union { double d; char c[sizeof (double)]; } u_data, u_minus_zero;
2981 u_data.d = value;
2982 u_minus_zero.d = - 0.0;
2983 for (i = 0; i < sizeof (double); i++)
2984 if (u_data.c[i] & u_minus_zero.c[i])
2986 value = - value;
2987 break;
2990 /* Now VALUE is a positive NaN. */
2991 break;
2992 default:
2993 value = atof (read_buffer + negative);
2994 break;
2997 return make_float (negative ? - value : value);
3001 Lisp_Object name, result;
3002 EMACS_INT nbytes = p - read_buffer;
3003 EMACS_INT nchars
3004 = (multibyte ? multibyte_chars_in_text (read_buffer, nbytes)
3005 : nbytes);
3007 if (uninterned_symbol && ! NILP (Vpurify_flag))
3008 name = make_pure_string (read_buffer, nchars, nbytes, multibyte);
3009 else
3010 name = make_specified_string (read_buffer, nchars, nbytes,multibyte);
3011 result = (uninterned_symbol ? Fmake_symbol (name)
3012 : Fintern (name, Qnil));
3014 if (EQ (Vread_with_symbol_positions, Qt)
3015 || EQ (Vread_with_symbol_positions, readcharfun))
3016 Vread_symbol_positions_list =
3017 /* Kind of a hack; this will probably fail if characters
3018 in the symbol name were escaped. Not really a big
3019 deal, though. */
3020 Fcons (Fcons (result,
3021 make_number (readchar_count
3022 - XFASTINT (Flength (Fsymbol_name (result))))),
3023 Vread_symbol_positions_list);
3024 return result;
3031 /* List of nodes we've seen during substitute_object_in_subtree. */
3032 static Lisp_Object seen_list;
3034 static void
3035 substitute_object_in_subtree (object, placeholder)
3036 Lisp_Object object;
3037 Lisp_Object placeholder;
3039 Lisp_Object check_object;
3041 /* We haven't seen any objects when we start. */
3042 seen_list = Qnil;
3044 /* Make all the substitutions. */
3045 check_object
3046 = substitute_object_recurse (object, placeholder, object);
3048 /* Clear seen_list because we're done with it. */
3049 seen_list = Qnil;
3051 /* The returned object here is expected to always eq the
3052 original. */
3053 if (!EQ (check_object, object))
3054 error ("Unexpected mutation error in reader");
3057 /* Feval doesn't get called from here, so no gc protection is needed. */
3058 #define SUBSTITUTE(get_val, set_val) \
3059 do { \
3060 Lisp_Object old_value = get_val; \
3061 Lisp_Object true_value \
3062 = substitute_object_recurse (object, placeholder, \
3063 old_value); \
3065 if (!EQ (old_value, true_value)) \
3067 set_val; \
3069 } while (0)
3071 static Lisp_Object
3072 substitute_object_recurse (object, placeholder, subtree)
3073 Lisp_Object object;
3074 Lisp_Object placeholder;
3075 Lisp_Object subtree;
3077 /* If we find the placeholder, return the target object. */
3078 if (EQ (placeholder, subtree))
3079 return object;
3081 /* If we've been to this node before, don't explore it again. */
3082 if (!EQ (Qnil, Fmemq (subtree, seen_list)))
3083 return subtree;
3085 /* If this node can be the entry point to a cycle, remember that
3086 we've seen it. It can only be such an entry point if it was made
3087 by #n=, which means that we can find it as a value in
3088 read_objects. */
3089 if (!EQ (Qnil, Frassq (subtree, read_objects)))
3090 seen_list = Fcons (subtree, seen_list);
3092 /* Recurse according to subtree's type.
3093 Every branch must return a Lisp_Object. */
3094 switch (XTYPE (subtree))
3096 case Lisp_Vectorlike:
3098 int i, length = 0;
3099 if (BOOL_VECTOR_P (subtree))
3100 return subtree; /* No sub-objects anyway. */
3101 else if (CHAR_TABLE_P (subtree) || SUB_CHAR_TABLE_P (subtree)
3102 || COMPILEDP (subtree))
3103 length = ASIZE (subtree) & PSEUDOVECTOR_SIZE_MASK;
3104 else if (VECTORP (subtree))
3105 length = ASIZE (subtree);
3106 else
3107 /* An unknown pseudovector may contain non-Lisp fields, so we
3108 can't just blindly traverse all its fields. We used to call
3109 `Flength' which signalled `sequencep', so I just preserved this
3110 behavior. */
3111 wrong_type_argument (Qsequencep, subtree);
3113 for (i = 0; i < length; i++)
3114 SUBSTITUTE (AREF (subtree, i),
3115 ASET (subtree, i, true_value));
3116 return subtree;
3119 case Lisp_Cons:
3121 SUBSTITUTE (XCAR (subtree),
3122 XSETCAR (subtree, true_value));
3123 SUBSTITUTE (XCDR (subtree),
3124 XSETCDR (subtree, true_value));
3125 return subtree;
3128 case Lisp_String:
3130 /* Check for text properties in each interval.
3131 substitute_in_interval contains part of the logic. */
3133 INTERVAL root_interval = STRING_INTERVALS (subtree);
3134 Lisp_Object arg = Fcons (object, placeholder);
3136 traverse_intervals_noorder (root_interval,
3137 &substitute_in_interval, arg);
3139 return subtree;
3142 /* Other types don't recurse any further. */
3143 default:
3144 return subtree;
3148 /* Helper function for substitute_object_recurse. */
3149 static void
3150 substitute_in_interval (interval, arg)
3151 INTERVAL interval;
3152 Lisp_Object arg;
3154 Lisp_Object object = Fcar (arg);
3155 Lisp_Object placeholder = Fcdr (arg);
3157 SUBSTITUTE(interval->plist, interval->plist = true_value);
3161 #define LEAD_INT 1
3162 #define DOT_CHAR 2
3163 #define TRAIL_INT 4
3164 #define E_CHAR 8
3165 #define EXP_INT 16
3168 isfloat_string (cp)
3169 register char *cp;
3171 register int state;
3173 char *start = cp;
3175 state = 0;
3176 if (*cp == '+' || *cp == '-')
3177 cp++;
3179 if (*cp >= '0' && *cp <= '9')
3181 state |= LEAD_INT;
3182 while (*cp >= '0' && *cp <= '9')
3183 cp++;
3185 if (*cp == '.')
3187 state |= DOT_CHAR;
3188 cp++;
3190 if (*cp >= '0' && *cp <= '9')
3192 state |= TRAIL_INT;
3193 while (*cp >= '0' && *cp <= '9')
3194 cp++;
3196 if (*cp == 'e' || *cp == 'E')
3198 state |= E_CHAR;
3199 cp++;
3200 if (*cp == '+' || *cp == '-')
3201 cp++;
3204 if (*cp >= '0' && *cp <= '9')
3206 state |= EXP_INT;
3207 while (*cp >= '0' && *cp <= '9')
3208 cp++;
3210 else if (cp == start)
3212 else if (cp[-1] == '+' && cp[0] == 'I' && cp[1] == 'N' && cp[2] == 'F')
3214 state |= EXP_INT;
3215 cp += 3;
3217 else if (cp[-1] == '+' && cp[0] == 'N' && cp[1] == 'a' && cp[2] == 'N')
3219 state |= EXP_INT;
3220 cp += 3;
3223 return (((*cp == 0) || (*cp == ' ') || (*cp == '\t') || (*cp == '\n') || (*cp == '\r') || (*cp == '\f'))
3224 && (state == (LEAD_INT|DOT_CHAR|TRAIL_INT)
3225 || state == (DOT_CHAR|TRAIL_INT)
3226 || state == (LEAD_INT|E_CHAR|EXP_INT)
3227 || state == (LEAD_INT|DOT_CHAR|TRAIL_INT|E_CHAR|EXP_INT)
3228 || state == (DOT_CHAR|TRAIL_INT|E_CHAR|EXP_INT)));
3232 static Lisp_Object
3233 read_vector (readcharfun, bytecodeflag)
3234 Lisp_Object readcharfun;
3235 int bytecodeflag;
3237 register int i;
3238 register int size;
3239 register Lisp_Object *ptr;
3240 register Lisp_Object tem, item, vector;
3241 register struct Lisp_Cons *otem;
3242 Lisp_Object len;
3244 tem = read_list (1, readcharfun);
3245 len = Flength (tem);
3246 vector = (read_pure ? make_pure_vector (XINT (len)) : Fmake_vector (len, Qnil));
3248 size = XVECTOR (vector)->size;
3249 ptr = XVECTOR (vector)->contents;
3250 for (i = 0; i < size; i++)
3252 item = Fcar (tem);
3253 /* If `load-force-doc-strings' is t when reading a lazily-loaded
3254 bytecode object, the docstring containing the bytecode and
3255 constants values must be treated as unibyte and passed to
3256 Fread, to get the actual bytecode string and constants vector. */
3257 if (bytecodeflag && load_force_doc_strings)
3259 if (i == COMPILED_BYTECODE)
3261 if (!STRINGP (item))
3262 error ("Invalid byte code");
3264 /* Delay handling the bytecode slot until we know whether
3265 it is lazily-loaded (we can tell by whether the
3266 constants slot is nil). */
3267 ptr[COMPILED_CONSTANTS] = item;
3268 item = Qnil;
3270 else if (i == COMPILED_CONSTANTS)
3272 Lisp_Object bytestr = ptr[COMPILED_CONSTANTS];
3274 if (NILP (item))
3276 /* Coerce string to unibyte (like string-as-unibyte,
3277 but without generating extra garbage and
3278 guaranteeing no change in the contents). */
3279 STRING_SET_CHARS (bytestr, SBYTES (bytestr));
3280 STRING_SET_UNIBYTE (bytestr);
3282 item = Fread (Fcons (bytestr, readcharfun));
3283 if (!CONSP (item))
3284 error ("Invalid byte code");
3286 otem = XCONS (item);
3287 bytestr = XCAR (item);
3288 item = XCDR (item);
3289 free_cons (otem);
3292 /* Now handle the bytecode slot. */
3293 ptr[COMPILED_BYTECODE] = read_pure ? Fpurecopy (bytestr) : bytestr;
3295 else if (i == COMPILED_DOC_STRING
3296 && STRINGP (item)
3297 && ! STRING_MULTIBYTE (item))
3299 if (EQ (readcharfun, Qget_emacs_mule_file_char))
3300 item = Fdecode_coding_string (item, Qemacs_mule, Qnil, Qnil);
3301 else
3302 item = Fstring_as_multibyte (item);
3305 ptr[i] = read_pure ? Fpurecopy (item) : item;
3306 otem = XCONS (tem);
3307 tem = Fcdr (tem);
3308 free_cons (otem);
3310 return vector;
3313 /* FLAG = 1 means check for ] to terminate rather than ) and .
3314 FLAG = -1 means check for starting with defun
3315 and make structure pure. */
3317 static Lisp_Object
3318 read_list (flag, readcharfun)
3319 int flag;
3320 register Lisp_Object readcharfun;
3322 /* -1 means check next element for defun,
3323 0 means don't check,
3324 1 means already checked and found defun. */
3325 int defunflag = flag < 0 ? -1 : 0;
3326 Lisp_Object val, tail;
3327 register Lisp_Object elt, tem;
3328 struct gcpro gcpro1, gcpro2;
3329 /* 0 is the normal case.
3330 1 means this list is a doc reference; replace it with the number 0.
3331 2 means this list is a doc reference; replace it with the doc string. */
3332 int doc_reference = 0;
3334 /* Initialize this to 1 if we are reading a list. */
3335 int first_in_list = flag <= 0;
3337 val = Qnil;
3338 tail = Qnil;
3340 while (1)
3342 int ch;
3343 GCPRO2 (val, tail);
3344 elt = read1 (readcharfun, &ch, first_in_list);
3345 UNGCPRO;
3347 first_in_list = 0;
3349 /* While building, if the list starts with #$, treat it specially. */
3350 if (EQ (elt, Vload_file_name)
3351 && ! NILP (elt)
3352 && !NILP (Vpurify_flag))
3354 if (NILP (Vdoc_file_name))
3355 /* We have not yet called Snarf-documentation, so assume
3356 this file is described in the DOC-MM.NN file
3357 and Snarf-documentation will fill in the right value later.
3358 For now, replace the whole list with 0. */
3359 doc_reference = 1;
3360 else
3361 /* We have already called Snarf-documentation, so make a relative
3362 file name for this file, so it can be found properly
3363 in the installed Lisp directory.
3364 We don't use Fexpand_file_name because that would make
3365 the directory absolute now. */
3366 elt = concat2 (build_string ("../lisp/"),
3367 Ffile_name_nondirectory (elt));
3369 else if (EQ (elt, Vload_file_name)
3370 && ! NILP (elt)
3371 && load_force_doc_strings)
3372 doc_reference = 2;
3374 if (ch)
3376 if (flag > 0)
3378 if (ch == ']')
3379 return val;
3380 invalid_syntax (") or . in a vector", 18);
3382 if (ch == ')')
3383 return val;
3384 if (ch == '.')
3386 GCPRO2 (val, tail);
3387 if (!NILP (tail))
3388 XSETCDR (tail, read0 (readcharfun));
3389 else
3390 val = read0 (readcharfun);
3391 read1 (readcharfun, &ch, 0);
3392 UNGCPRO;
3393 if (ch == ')')
3395 if (doc_reference == 1)
3396 return make_number (0);
3397 if (doc_reference == 2)
3399 /* Get a doc string from the file we are loading.
3400 If it's in saved_doc_string, get it from there.
3402 Here, we don't know if the string is a
3403 bytecode string or a doc string. As a
3404 bytecode string must be unibyte, we always
3405 return a unibyte string. If it is actually a
3406 doc string, caller must make it
3407 multibyte. */
3409 int pos = XINT (XCDR (val));
3410 /* Position is negative for user variables. */
3411 if (pos < 0) pos = -pos;
3412 if (pos >= saved_doc_string_position
3413 && pos < (saved_doc_string_position
3414 + saved_doc_string_length))
3416 int start = pos - saved_doc_string_position;
3417 int from, to;
3419 /* Process quoting with ^A,
3420 and find the end of the string,
3421 which is marked with ^_ (037). */
3422 for (from = start, to = start;
3423 saved_doc_string[from] != 037;)
3425 int c = saved_doc_string[from++];
3426 if (c == 1)
3428 c = saved_doc_string[from++];
3429 if (c == 1)
3430 saved_doc_string[to++] = c;
3431 else if (c == '0')
3432 saved_doc_string[to++] = 0;
3433 else if (c == '_')
3434 saved_doc_string[to++] = 037;
3436 else
3437 saved_doc_string[to++] = c;
3440 return make_unibyte_string (saved_doc_string + start,
3441 to - start);
3443 /* Look in prev_saved_doc_string the same way. */
3444 else if (pos >= prev_saved_doc_string_position
3445 && pos < (prev_saved_doc_string_position
3446 + prev_saved_doc_string_length))
3448 int start = pos - prev_saved_doc_string_position;
3449 int from, to;
3451 /* Process quoting with ^A,
3452 and find the end of the string,
3453 which is marked with ^_ (037). */
3454 for (from = start, to = start;
3455 prev_saved_doc_string[from] != 037;)
3457 int c = prev_saved_doc_string[from++];
3458 if (c == 1)
3460 c = prev_saved_doc_string[from++];
3461 if (c == 1)
3462 prev_saved_doc_string[to++] = c;
3463 else if (c == '0')
3464 prev_saved_doc_string[to++] = 0;
3465 else if (c == '_')
3466 prev_saved_doc_string[to++] = 037;
3468 else
3469 prev_saved_doc_string[to++] = c;
3472 return make_unibyte_string (prev_saved_doc_string
3473 + start,
3474 to - start);
3476 else
3477 return get_doc_string (val, 1, 0);
3480 return val;
3482 invalid_syntax (". in wrong context", 18);
3484 invalid_syntax ("] in a list", 11);
3486 tem = (read_pure && flag <= 0
3487 ? pure_cons (elt, Qnil)
3488 : Fcons (elt, Qnil));
3489 if (!NILP (tail))
3490 XSETCDR (tail, tem);
3491 else
3492 val = tem;
3493 tail = tem;
3494 if (defunflag < 0)
3495 defunflag = EQ (elt, Qdefun);
3496 else if (defunflag > 0)
3497 read_pure = 1;
3501 Lisp_Object Vobarray;
3502 Lisp_Object initial_obarray;
3504 /* oblookup stores the bucket number here, for the sake of Funintern. */
3506 int oblookup_last_bucket_number;
3508 static int hash_string ();
3510 /* Get an error if OBARRAY is not an obarray.
3511 If it is one, return it. */
3513 Lisp_Object
3514 check_obarray (obarray)
3515 Lisp_Object obarray;
3517 if (!VECTORP (obarray) || XVECTOR (obarray)->size == 0)
3519 /* If Vobarray is now invalid, force it to be valid. */
3520 if (EQ (Vobarray, obarray)) Vobarray = initial_obarray;
3521 wrong_type_argument (Qvectorp, obarray);
3523 return obarray;
3526 /* Intern the C string STR: return a symbol with that name,
3527 interned in the current obarray. */
3529 Lisp_Object
3530 intern (str)
3531 const char *str;
3533 Lisp_Object tem;
3534 int len = strlen (str);
3535 Lisp_Object obarray;
3537 obarray = Vobarray;
3538 if (!VECTORP (obarray) || XVECTOR (obarray)->size == 0)
3539 obarray = check_obarray (obarray);
3540 tem = oblookup (obarray, str, len, len);
3541 if (SYMBOLP (tem))
3542 return tem;
3543 return Fintern (make_string (str, len), obarray);
3546 /* Create an uninterned symbol with name STR. */
3548 Lisp_Object
3549 make_symbol (str)
3550 char *str;
3552 int len = strlen (str);
3554 return Fmake_symbol ((!NILP (Vpurify_flag)
3555 ? make_pure_string (str, len, len, 0)
3556 : make_string (str, len)));
3559 DEFUN ("intern", Fintern, Sintern, 1, 2, 0,
3560 doc: /* Return the canonical symbol whose name is STRING.
3561 If there is none, one is created by this function and returned.
3562 A second optional argument specifies the obarray to use;
3563 it defaults to the value of `obarray'. */)
3564 (string, obarray)
3565 Lisp_Object string, obarray;
3567 register Lisp_Object tem, sym, *ptr;
3569 if (NILP (obarray)) obarray = Vobarray;
3570 obarray = check_obarray (obarray);
3572 CHECK_STRING (string);
3574 tem = oblookup (obarray, SDATA (string),
3575 SCHARS (string),
3576 SBYTES (string));
3577 if (!INTEGERP (tem))
3578 return tem;
3580 if (!NILP (Vpurify_flag))
3581 string = Fpurecopy (string);
3582 sym = Fmake_symbol (string);
3584 if (EQ (obarray, initial_obarray))
3585 XSYMBOL (sym)->interned = SYMBOL_INTERNED_IN_INITIAL_OBARRAY;
3586 else
3587 XSYMBOL (sym)->interned = SYMBOL_INTERNED;
3589 if ((SREF (string, 0) == ':')
3590 && EQ (obarray, initial_obarray))
3592 XSYMBOL (sym)->constant = 1;
3593 XSYMBOL (sym)->value = sym;
3596 ptr = &XVECTOR (obarray)->contents[XINT (tem)];
3597 if (SYMBOLP (*ptr))
3598 XSYMBOL (sym)->next = XSYMBOL (*ptr);
3599 else
3600 XSYMBOL (sym)->next = 0;
3601 *ptr = sym;
3602 return sym;
3605 DEFUN ("intern-soft", Fintern_soft, Sintern_soft, 1, 2, 0,
3606 doc: /* Return the canonical symbol named NAME, or nil if none exists.
3607 NAME may be a string or a symbol. If it is a symbol, that exact
3608 symbol is searched for.
3609 A second optional argument specifies the obarray to use;
3610 it defaults to the value of `obarray'. */)
3611 (name, obarray)
3612 Lisp_Object name, obarray;
3614 register Lisp_Object tem, string;
3616 if (NILP (obarray)) obarray = Vobarray;
3617 obarray = check_obarray (obarray);
3619 if (!SYMBOLP (name))
3621 CHECK_STRING (name);
3622 string = name;
3624 else
3625 string = SYMBOL_NAME (name);
3627 tem = oblookup (obarray, SDATA (string), SCHARS (string), SBYTES (string));
3628 if (INTEGERP (tem) || (SYMBOLP (name) && !EQ (name, tem)))
3629 return Qnil;
3630 else
3631 return tem;
3634 DEFUN ("unintern", Funintern, Sunintern, 1, 2, 0,
3635 doc: /* Delete the symbol named NAME, if any, from OBARRAY.
3636 The value is t if a symbol was found and deleted, nil otherwise.
3637 NAME may be a string or a symbol. If it is a symbol, that symbol
3638 is deleted, if it belongs to OBARRAY--no other symbol is deleted.
3639 OBARRAY defaults to the value of the variable `obarray'. */)
3640 (name, obarray)
3641 Lisp_Object name, obarray;
3643 register Lisp_Object string, tem;
3644 int hash;
3646 if (NILP (obarray)) obarray = Vobarray;
3647 obarray = check_obarray (obarray);
3649 if (SYMBOLP (name))
3650 string = SYMBOL_NAME (name);
3651 else
3653 CHECK_STRING (name);
3654 string = name;
3657 tem = oblookup (obarray, SDATA (string),
3658 SCHARS (string),
3659 SBYTES (string));
3660 if (INTEGERP (tem))
3661 return Qnil;
3662 /* If arg was a symbol, don't delete anything but that symbol itself. */
3663 if (SYMBOLP (name) && !EQ (name, tem))
3664 return Qnil;
3666 XSYMBOL (tem)->interned = SYMBOL_UNINTERNED;
3667 XSYMBOL (tem)->constant = 0;
3668 XSYMBOL (tem)->indirect_variable = 0;
3670 hash = oblookup_last_bucket_number;
3672 if (EQ (XVECTOR (obarray)->contents[hash], tem))
3674 if (XSYMBOL (tem)->next)
3675 XSETSYMBOL (XVECTOR (obarray)->contents[hash], XSYMBOL (tem)->next);
3676 else
3677 XSETINT (XVECTOR (obarray)->contents[hash], 0);
3679 else
3681 Lisp_Object tail, following;
3683 for (tail = XVECTOR (obarray)->contents[hash];
3684 XSYMBOL (tail)->next;
3685 tail = following)
3687 XSETSYMBOL (following, XSYMBOL (tail)->next);
3688 if (EQ (following, tem))
3690 XSYMBOL (tail)->next = XSYMBOL (following)->next;
3691 break;
3696 return Qt;
3699 /* Return the symbol in OBARRAY whose names matches the string
3700 of SIZE characters (SIZE_BYTE bytes) at PTR.
3701 If there is no such symbol in OBARRAY, return nil.
3703 Also store the bucket number in oblookup_last_bucket_number. */
3705 Lisp_Object
3706 oblookup (obarray, ptr, size, size_byte)
3707 Lisp_Object obarray;
3708 register const char *ptr;
3709 int size, size_byte;
3711 int hash;
3712 int obsize;
3713 register Lisp_Object tail;
3714 Lisp_Object bucket, tem;
3716 if (!VECTORP (obarray)
3717 || (obsize = XVECTOR (obarray)->size) == 0)
3719 obarray = check_obarray (obarray);
3720 obsize = XVECTOR (obarray)->size;
3722 /* This is sometimes needed in the middle of GC. */
3723 obsize &= ~ARRAY_MARK_FLAG;
3724 /* Combining next two lines breaks VMS C 2.3. */
3725 hash = hash_string (ptr, size_byte);
3726 hash %= obsize;
3727 bucket = XVECTOR (obarray)->contents[hash];
3728 oblookup_last_bucket_number = hash;
3729 if (EQ (bucket, make_number (0)))
3731 else if (!SYMBOLP (bucket))
3732 error ("Bad data in guts of obarray"); /* Like CADR error message */
3733 else
3734 for (tail = bucket; ; XSETSYMBOL (tail, XSYMBOL (tail)->next))
3736 if (SBYTES (SYMBOL_NAME (tail)) == size_byte
3737 && SCHARS (SYMBOL_NAME (tail)) == size
3738 && !bcmp (SDATA (SYMBOL_NAME (tail)), ptr, size_byte))
3739 return tail;
3740 else if (XSYMBOL (tail)->next == 0)
3741 break;
3743 XSETINT (tem, hash);
3744 return tem;
3747 static int
3748 hash_string (ptr, len)
3749 const unsigned char *ptr;
3750 int len;
3752 register const unsigned char *p = ptr;
3753 register const unsigned char *end = p + len;
3754 register unsigned char c;
3755 register int hash = 0;
3757 while (p != end)
3759 c = *p++;
3760 if (c >= 0140) c -= 40;
3761 hash = ((hash<<3) + (hash>>28) + c);
3763 return hash & 07777777777;
3766 void
3767 map_obarray (obarray, fn, arg)
3768 Lisp_Object obarray;
3769 void (*fn) P_ ((Lisp_Object, Lisp_Object));
3770 Lisp_Object arg;
3772 register int i;
3773 register Lisp_Object tail;
3774 CHECK_VECTOR (obarray);
3775 for (i = XVECTOR (obarray)->size - 1; i >= 0; i--)
3777 tail = XVECTOR (obarray)->contents[i];
3778 if (SYMBOLP (tail))
3779 while (1)
3781 (*fn) (tail, arg);
3782 if (XSYMBOL (tail)->next == 0)
3783 break;
3784 XSETSYMBOL (tail, XSYMBOL (tail)->next);
3789 void
3790 mapatoms_1 (sym, function)
3791 Lisp_Object sym, function;
3793 call1 (function, sym);
3796 DEFUN ("mapatoms", Fmapatoms, Smapatoms, 1, 2, 0,
3797 doc: /* Call FUNCTION on every symbol in OBARRAY.
3798 OBARRAY defaults to the value of `obarray'. */)
3799 (function, obarray)
3800 Lisp_Object function, obarray;
3802 if (NILP (obarray)) obarray = Vobarray;
3803 obarray = check_obarray (obarray);
3805 map_obarray (obarray, mapatoms_1, function);
3806 return Qnil;
3809 #define OBARRAY_SIZE 1511
3811 void
3812 init_obarray ()
3814 Lisp_Object oblength;
3815 int hash;
3816 Lisp_Object *tem;
3818 XSETFASTINT (oblength, OBARRAY_SIZE);
3820 Qnil = Fmake_symbol (make_pure_string ("nil", 3, 3, 0));
3821 Vobarray = Fmake_vector (oblength, make_number (0));
3822 initial_obarray = Vobarray;
3823 staticpro (&initial_obarray);
3824 /* Intern nil in the obarray */
3825 XSYMBOL (Qnil)->interned = SYMBOL_INTERNED_IN_INITIAL_OBARRAY;
3826 XSYMBOL (Qnil)->constant = 1;
3828 /* These locals are to kludge around a pyramid compiler bug. */
3829 hash = hash_string ("nil", 3);
3830 /* Separate statement here to avoid VAXC bug. */
3831 hash %= OBARRAY_SIZE;
3832 tem = &XVECTOR (Vobarray)->contents[hash];
3833 *tem = Qnil;
3835 Qunbound = Fmake_symbol (make_pure_string ("unbound", 7, 7, 0));
3836 XSYMBOL (Qnil)->function = Qunbound;
3837 XSYMBOL (Qunbound)->value = Qunbound;
3838 XSYMBOL (Qunbound)->function = Qunbound;
3840 Qt = intern ("t");
3841 XSYMBOL (Qnil)->value = Qnil;
3842 XSYMBOL (Qnil)->plist = Qnil;
3843 XSYMBOL (Qt)->value = Qt;
3844 XSYMBOL (Qt)->constant = 1;
3846 /* Qt is correct even if CANNOT_DUMP. loadup.el will set to nil at end. */
3847 Vpurify_flag = Qt;
3849 Qvariable_documentation = intern ("variable-documentation");
3850 staticpro (&Qvariable_documentation);
3852 read_buffer_size = 100 + MAX_MULTIBYTE_LENGTH;
3853 read_buffer = (char *) xmalloc (read_buffer_size);
3856 void
3857 defsubr (sname)
3858 struct Lisp_Subr *sname;
3860 Lisp_Object sym;
3861 sym = intern (sname->symbol_name);
3862 XSETPVECTYPE (sname, PVEC_SUBR);
3863 XSETSUBR (XSYMBOL (sym)->function, sname);
3866 #ifdef NOTDEF /* use fset in subr.el now */
3867 void
3868 defalias (sname, string)
3869 struct Lisp_Subr *sname;
3870 char *string;
3872 Lisp_Object sym;
3873 sym = intern (string);
3874 XSETSUBR (XSYMBOL (sym)->function, sname);
3876 #endif /* NOTDEF */
3878 /* Define an "integer variable"; a symbol whose value is forwarded
3879 to a C variable of type int. Sample call:
3880 DEFVAR_INT ("emacs-priority", &emacs_priority, "Documentation"); */
3881 void
3882 defvar_int (namestring, address)
3883 char *namestring;
3884 EMACS_INT *address;
3886 Lisp_Object sym, val;
3887 sym = intern (namestring);
3888 val = allocate_misc ();
3889 XMISCTYPE (val) = Lisp_Misc_Intfwd;
3890 XINTFWD (val)->intvar = address;
3891 SET_SYMBOL_VALUE (sym, val);
3894 /* Similar but define a variable whose value is t if address contains 1,
3895 nil if address contains 0. */
3896 void
3897 defvar_bool (namestring, address)
3898 char *namestring;
3899 int *address;
3901 Lisp_Object sym, val;
3902 sym = intern (namestring);
3903 val = allocate_misc ();
3904 XMISCTYPE (val) = Lisp_Misc_Boolfwd;
3905 XBOOLFWD (val)->boolvar = address;
3906 SET_SYMBOL_VALUE (sym, val);
3907 Vbyte_boolean_vars = Fcons (sym, Vbyte_boolean_vars);
3910 /* Similar but define a variable whose value is the Lisp Object stored
3911 at address. Two versions: with and without gc-marking of the C
3912 variable. The nopro version is used when that variable will be
3913 gc-marked for some other reason, since marking the same slot twice
3914 can cause trouble with strings. */
3915 void
3916 defvar_lisp_nopro (namestring, address)
3917 char *namestring;
3918 Lisp_Object *address;
3920 Lisp_Object sym, val;
3921 sym = intern (namestring);
3922 val = allocate_misc ();
3923 XMISCTYPE (val) = Lisp_Misc_Objfwd;
3924 XOBJFWD (val)->objvar = address;
3925 SET_SYMBOL_VALUE (sym, val);
3928 void
3929 defvar_lisp (namestring, address)
3930 char *namestring;
3931 Lisp_Object *address;
3933 defvar_lisp_nopro (namestring, address);
3934 staticpro (address);
3937 /* Similar but define a variable whose value is the Lisp Object stored
3938 at a particular offset in the current kboard object. */
3940 void
3941 defvar_kboard (namestring, offset)
3942 char *namestring;
3943 int offset;
3945 Lisp_Object sym, val;
3946 sym = intern (namestring);
3947 val = allocate_misc ();
3948 XMISCTYPE (val) = Lisp_Misc_Kboard_Objfwd;
3949 XKBOARD_OBJFWD (val)->offset = offset;
3950 SET_SYMBOL_VALUE (sym, val);
3953 /* Record the value of load-path used at the start of dumping
3954 so we can see if the site changed it later during dumping. */
3955 static Lisp_Object dump_path;
3957 void
3958 init_lread ()
3960 char *normal;
3961 int turn_off_warning = 0;
3963 /* Compute the default load-path. */
3964 #ifdef CANNOT_DUMP
3965 normal = PATH_LOADSEARCH;
3966 Vload_path = decode_env_path (0, normal);
3967 #else
3968 if (NILP (Vpurify_flag))
3969 normal = PATH_LOADSEARCH;
3970 else
3971 normal = PATH_DUMPLOADSEARCH;
3973 /* In a dumped Emacs, we normally have to reset the value of
3974 Vload_path from PATH_LOADSEARCH, since the value that was dumped
3975 uses ../lisp, instead of the path of the installed elisp
3976 libraries. However, if it appears that Vload_path was changed
3977 from the default before dumping, don't override that value. */
3978 if (initialized)
3980 if (! NILP (Fequal (dump_path, Vload_path)))
3982 Vload_path = decode_env_path (0, normal);
3983 if (!NILP (Vinstallation_directory))
3985 Lisp_Object tem, tem1, sitelisp;
3987 /* Remove site-lisp dirs from path temporarily and store
3988 them in sitelisp, then conc them on at the end so
3989 they're always first in path. */
3990 sitelisp = Qnil;
3991 while (1)
3993 tem = Fcar (Vload_path);
3994 tem1 = Fstring_match (build_string ("site-lisp"),
3995 tem, Qnil);
3996 if (!NILP (tem1))
3998 Vload_path = Fcdr (Vload_path);
3999 sitelisp = Fcons (tem, sitelisp);
4001 else
4002 break;
4005 /* Add to the path the lisp subdir of the
4006 installation dir, if it exists. */
4007 tem = Fexpand_file_name (build_string ("lisp"),
4008 Vinstallation_directory);
4009 tem1 = Ffile_exists_p (tem);
4010 if (!NILP (tem1))
4012 if (NILP (Fmember (tem, Vload_path)))
4014 turn_off_warning = 1;
4015 Vload_path = Fcons (tem, Vload_path);
4018 else
4019 /* That dir doesn't exist, so add the build-time
4020 Lisp dirs instead. */
4021 Vload_path = nconc2 (Vload_path, dump_path);
4023 /* Add leim under the installation dir, if it exists. */
4024 tem = Fexpand_file_name (build_string ("leim"),
4025 Vinstallation_directory);
4026 tem1 = Ffile_exists_p (tem);
4027 if (!NILP (tem1))
4029 if (NILP (Fmember (tem, Vload_path)))
4030 Vload_path = Fcons (tem, Vload_path);
4033 /* Add site-lisp under the installation dir, if it exists. */
4034 tem = Fexpand_file_name (build_string ("site-lisp"),
4035 Vinstallation_directory);
4036 tem1 = Ffile_exists_p (tem);
4037 if (!NILP (tem1))
4039 if (NILP (Fmember (tem, Vload_path)))
4040 Vload_path = Fcons (tem, Vload_path);
4043 /* If Emacs was not built in the source directory,
4044 and it is run from where it was built, add to load-path
4045 the lisp, leim and site-lisp dirs under that directory. */
4047 if (NILP (Fequal (Vinstallation_directory, Vsource_directory)))
4049 Lisp_Object tem2;
4051 tem = Fexpand_file_name (build_string ("src/Makefile"),
4052 Vinstallation_directory);
4053 tem1 = Ffile_exists_p (tem);
4055 /* Don't be fooled if they moved the entire source tree
4056 AFTER dumping Emacs. If the build directory is indeed
4057 different from the source dir, src/Makefile.in and
4058 src/Makefile will not be found together. */
4059 tem = Fexpand_file_name (build_string ("src/Makefile.in"),
4060 Vinstallation_directory);
4061 tem2 = Ffile_exists_p (tem);
4062 if (!NILP (tem1) && NILP (tem2))
4064 tem = Fexpand_file_name (build_string ("lisp"),
4065 Vsource_directory);
4067 if (NILP (Fmember (tem, Vload_path)))
4068 Vload_path = Fcons (tem, Vload_path);
4070 tem = Fexpand_file_name (build_string ("leim"),
4071 Vsource_directory);
4073 if (NILP (Fmember (tem, Vload_path)))
4074 Vload_path = Fcons (tem, Vload_path);
4076 tem = Fexpand_file_name (build_string ("site-lisp"),
4077 Vsource_directory);
4079 if (NILP (Fmember (tem, Vload_path)))
4080 Vload_path = Fcons (tem, Vload_path);
4083 if (!NILP (sitelisp))
4084 Vload_path = nconc2 (Fnreverse (sitelisp), Vload_path);
4088 else
4090 /* NORMAL refers to the lisp dir in the source directory. */
4091 /* We used to add ../lisp at the front here, but
4092 that caused trouble because it was copied from dump_path
4093 into Vload_path, above, when Vinstallation_directory was non-nil.
4094 It should be unnecessary. */
4095 Vload_path = decode_env_path (0, normal);
4096 dump_path = Vload_path;
4098 #endif
4100 #if (!(defined(WINDOWSNT) || (defined(HAVE_CARBON))))
4101 /* When Emacs is invoked over network shares on NT, PATH_LOADSEARCH is
4102 almost never correct, thereby causing a warning to be printed out that
4103 confuses users. Since PATH_LOADSEARCH is always overridden by the
4104 EMACSLOADPATH environment variable below, disable the warning on NT.
4105 Also, when using the "self-contained" option for Carbon Emacs for MacOSX,
4106 the "standard" paths may not exist and would be overridden by
4107 EMACSLOADPATH as on NT. Since this depends on how the executable
4108 was build and packaged, turn off the warnings in general */
4110 /* Warn if dirs in the *standard* path don't exist. */
4111 if (!turn_off_warning)
4113 Lisp_Object path_tail;
4115 for (path_tail = Vload_path;
4116 !NILP (path_tail);
4117 path_tail = XCDR (path_tail))
4119 Lisp_Object dirfile;
4120 dirfile = Fcar (path_tail);
4121 if (STRINGP (dirfile))
4123 dirfile = Fdirectory_file_name (dirfile);
4124 if (access (SDATA (dirfile), 0) < 0)
4125 dir_warning ("Warning: Lisp directory `%s' does not exist.\n",
4126 XCAR (path_tail));
4130 #endif /* !(WINDOWSNT || HAVE_CARBON) */
4132 /* If the EMACSLOADPATH environment variable is set, use its value.
4133 This doesn't apply if we're dumping. */
4134 #ifndef CANNOT_DUMP
4135 if (NILP (Vpurify_flag)
4136 && egetenv ("EMACSLOADPATH"))
4137 #endif
4138 Vload_path = decode_env_path ("EMACSLOADPATH", normal);
4140 Vvalues = Qnil;
4142 load_in_progress = 0;
4143 Vload_file_name = Qnil;
4145 load_descriptor_list = Qnil;
4147 Vstandard_input = Qt;
4148 Vloads_in_progress = Qnil;
4151 /* Print a warning, using format string FORMAT, that directory DIRNAME
4152 does not exist. Print it on stderr and put it in *Messages*. */
4154 void
4155 dir_warning (format, dirname)
4156 char *format;
4157 Lisp_Object dirname;
4159 char *buffer
4160 = (char *) alloca (SCHARS (dirname) + strlen (format) + 5);
4162 fprintf (stderr, format, SDATA (dirname));
4163 sprintf (buffer, format, SDATA (dirname));
4164 /* Don't log the warning before we've initialized!! */
4165 if (initialized)
4166 message_dolog (buffer, strlen (buffer), 0, STRING_MULTIBYTE (dirname));
4169 void
4170 syms_of_lread ()
4172 defsubr (&Sread);
4173 defsubr (&Sread_from_string);
4174 defsubr (&Sintern);
4175 defsubr (&Sintern_soft);
4176 defsubr (&Sunintern);
4177 defsubr (&Sget_load_suffixes);
4178 defsubr (&Sload);
4179 defsubr (&Seval_buffer);
4180 defsubr (&Seval_region);
4181 defsubr (&Sread_char);
4182 defsubr (&Sread_char_exclusive);
4183 defsubr (&Sread_event);
4184 defsubr (&Sget_file_char);
4185 defsubr (&Smapatoms);
4186 defsubr (&Slocate_file_internal);
4188 DEFVAR_LISP ("obarray", &Vobarray,
4189 doc: /* Symbol table for use by `intern' and `read'.
4190 It is a vector whose length ought to be prime for best results.
4191 The vector's contents don't make sense if examined from Lisp programs;
4192 to find all the symbols in an obarray, use `mapatoms'. */);
4194 DEFVAR_LISP ("values", &Vvalues,
4195 doc: /* List of values of all expressions which were read, evaluated and printed.
4196 Order is reverse chronological. */);
4198 DEFVAR_LISP ("standard-input", &Vstandard_input,
4199 doc: /* Stream for read to get input from.
4200 See documentation of `read' for possible values. */);
4201 Vstandard_input = Qt;
4203 DEFVAR_LISP ("read-with-symbol-positions", &Vread_with_symbol_positions,
4204 doc: /* If non-nil, add position of read symbols to `read-symbol-positions-list'.
4206 If this variable is a buffer, then only forms read from that buffer
4207 will be added to `read-symbol-positions-list'.
4208 If this variable is t, then all read forms will be added.
4209 The effect of all other values other than nil are not currently
4210 defined, although they may be in the future.
4212 The positions are relative to the last call to `read' or
4213 `read-from-string'. It is probably a bad idea to set this variable at
4214 the toplevel; bind it instead. */);
4215 Vread_with_symbol_positions = Qnil;
4217 DEFVAR_LISP ("read-symbol-positions-list", &Vread_symbol_positions_list,
4218 doc: /* A list mapping read symbols to their positions.
4219 This variable is modified during calls to `read' or
4220 `read-from-string', but only when `read-with-symbol-positions' is
4221 non-nil.
4223 Each element of the list looks like (SYMBOL . CHAR-POSITION), where
4224 CHAR-POSITION is an integer giving the offset of that occurrence of the
4225 symbol from the position where `read' or `read-from-string' started.
4227 Note that a symbol will appear multiple times in this list, if it was
4228 read multiple times. The list is in the same order as the symbols
4229 were read in. */);
4230 Vread_symbol_positions_list = Qnil;
4232 DEFVAR_LISP ("load-path", &Vload_path,
4233 doc: /* *List of directories to search for files to load.
4234 Each element is a string (directory name) or nil (try default directory).
4235 Initialized based on EMACSLOADPATH environment variable, if any,
4236 otherwise to default specified by file `epaths.h' when Emacs was built. */);
4238 DEFVAR_LISP ("load-suffixes", &Vload_suffixes,
4239 doc: /* List of suffixes for (compiled or source) Emacs Lisp files.
4240 This list should not include the empty string.
4241 `load' and related functions try to append these suffixes, in order,
4242 to the specified file name if a Lisp suffix is allowed or required. */);
4243 Vload_suffixes = Fcons (build_string (".elc"),
4244 Fcons (build_string (".el"), Qnil));
4245 DEFVAR_LISP ("load-file-rep-suffixes", &Vload_file_rep_suffixes,
4246 doc: /* List of suffixes that indicate representations of \
4247 the same file.
4248 This list should normally start with the empty string.
4250 Enabling Auto Compression mode appends the suffixes in
4251 `jka-compr-load-suffixes' to this list and disabling Auto Compression
4252 mode removes them again. `load' and related functions use this list to
4253 determine whether they should look for compressed versions of a file
4254 and, if so, which suffixes they should try to append to the file name
4255 in order to do so. However, if you want to customize which suffixes
4256 the loading functions recognize as compression suffixes, you should
4257 customize `jka-compr-load-suffixes' rather than the present variable. */);
4258 Vload_file_rep_suffixes = Fcons (empty_unibyte_string, Qnil);
4260 DEFVAR_BOOL ("load-in-progress", &load_in_progress,
4261 doc: /* Non-nil if inside of `load'. */);
4263 DEFVAR_LISP ("after-load-alist", &Vafter_load_alist,
4264 doc: /* An alist of expressions to be evalled when particular files are loaded.
4265 Each element looks like (REGEXP-OR-FEATURE FORMS...).
4267 REGEXP-OR-FEATURE is either a regular expression to match file names, or
4268 a symbol \(a feature name).
4270 When `load' is run and the file-name argument matches an element's
4271 REGEXP-OR-FEATURE, or when `provide' is run and provides the symbol
4272 REGEXP-OR-FEATURE, the FORMS in the element are executed.
4274 An error in FORMS does not undo the load, but does prevent execution of
4275 the rest of the FORMS. */);
4276 Vafter_load_alist = Qnil;
4278 DEFVAR_LISP ("load-history", &Vload_history,
4279 doc: /* Alist mapping file names to symbols and features.
4280 Each alist element is a list that starts with a file name,
4281 except for one element (optional) that starts with nil and describes
4282 definitions evaluated from buffers not visiting files.
4284 The file name is absolute and is the true file name (i.e. it doesn't
4285 contain symbolic links) of the loaded file.
4287 The remaining elements of each list are symbols defined as variables
4288 and cons cells of the form `(provide . FEATURE)', `(require . FEATURE)',
4289 `(defun . FUNCTION)', `(autoload . SYMBOL)', `(defface . SYMBOL)'
4290 and `(t . SYMBOL)'. An element `(t . SYMBOL)' precedes an entry
4291 `(defun . FUNCTION)', and means that SYMBOL was an autoload before
4292 this file redefined it as a function.
4294 During preloading, the file name recorded is relative to the main Lisp
4295 directory. These file names are converted to absolute at startup. */);
4296 Vload_history = Qnil;
4298 DEFVAR_LISP ("load-file-name", &Vload_file_name,
4299 doc: /* Full name of file being loaded by `load'. */);
4300 Vload_file_name = Qnil;
4302 DEFVAR_LISP ("user-init-file", &Vuser_init_file,
4303 doc: /* File name, including directory, of user's initialization file.
4304 If the file loaded had extension `.elc', and the corresponding source file
4305 exists, this variable contains the name of source file, suitable for use
4306 by functions like `custom-save-all' which edit the init file.
4307 While Emacs loads and evaluates the init file, value is the real name
4308 of the file, regardless of whether or not it has the `.elc' extension. */);
4309 Vuser_init_file = Qnil;
4311 DEFVAR_LISP ("current-load-list", &Vcurrent_load_list,
4312 doc: /* Used for internal purposes by `load'. */);
4313 Vcurrent_load_list = Qnil;
4315 DEFVAR_LISP ("load-read-function", &Vload_read_function,
4316 doc: /* Function used by `load' and `eval-region' for reading expressions.
4317 The default is nil, which means use the function `read'. */);
4318 Vload_read_function = Qnil;
4320 DEFVAR_LISP ("load-source-file-function", &Vload_source_file_function,
4321 doc: /* Function called in `load' for loading an Emacs Lisp source file.
4322 This function is for doing code conversion before reading the source file.
4323 If nil, loading is done without any code conversion.
4324 Arguments are FULLNAME, FILE, NOERROR, NOMESSAGE, where
4325 FULLNAME is the full name of FILE.
4326 See `load' for the meaning of the remaining arguments. */);
4327 Vload_source_file_function = Qnil;
4329 DEFVAR_BOOL ("load-force-doc-strings", &load_force_doc_strings,
4330 doc: /* Non-nil means `load' should force-load all dynamic doc strings.
4331 This is useful when the file being loaded is a temporary copy. */);
4332 load_force_doc_strings = 0;
4334 DEFVAR_BOOL ("load-convert-to-unibyte", &load_convert_to_unibyte,
4335 doc: /* Non-nil means `read' converts strings to unibyte whenever possible.
4336 This is normally bound by `load' and `eval-buffer' to control `read',
4337 and is not meant for users to change. */);
4338 load_convert_to_unibyte = 0;
4340 DEFVAR_LISP ("source-directory", &Vsource_directory,
4341 doc: /* Directory in which Emacs sources were found when Emacs was built.
4342 You cannot count on them to still be there! */);
4343 Vsource_directory
4344 = Fexpand_file_name (build_string ("../"),
4345 Fcar (decode_env_path (0, PATH_DUMPLOADSEARCH)));
4347 DEFVAR_LISP ("preloaded-file-list", &Vpreloaded_file_list,
4348 doc: /* List of files that were preloaded (when dumping Emacs). */);
4349 Vpreloaded_file_list = Qnil;
4351 DEFVAR_LISP ("byte-boolean-vars", &Vbyte_boolean_vars,
4352 doc: /* List of all DEFVAR_BOOL variables, used by the byte code optimizer. */);
4353 Vbyte_boolean_vars = Qnil;
4355 DEFVAR_BOOL ("load-dangerous-libraries", &load_dangerous_libraries,
4356 doc: /* Non-nil means load dangerous compiled Lisp files.
4357 Some versions of XEmacs use different byte codes than Emacs. These
4358 incompatible byte codes can make Emacs crash when it tries to execute
4359 them. */);
4360 load_dangerous_libraries = 0;
4362 DEFVAR_LISP ("bytecomp-version-regexp", &Vbytecomp_version_regexp,
4363 doc: /* Regular expression matching safe to load compiled Lisp files.
4364 When Emacs loads a compiled Lisp file, it reads the first 512 bytes
4365 from the file, and matches them against this regular expression.
4366 When the regular expression matches, the file is considered to be safe
4367 to load. See also `load-dangerous-libraries'. */);
4368 Vbytecomp_version_regexp
4369 = build_string ("^;;;.\\(in Emacs version\\|bytecomp version FSF\\)");
4371 DEFVAR_LISP ("eval-buffer-list", &Veval_buffer_list,
4372 doc: /* List of buffers being read from by calls to `eval-buffer' and `eval-region'. */);
4373 Veval_buffer_list = Qnil;
4375 DEFVAR_LISP ("old-style-backquotes", &Vold_style_backquotes,
4376 doc: /* Set to non-nil when `read' encounters an old-style backquote. */);
4377 Vold_style_backquotes = Qnil;
4378 Qold_style_backquotes = intern ("old-style-backquotes");
4379 staticpro (&Qold_style_backquotes);
4381 /* Vsource_directory was initialized in init_lread. */
4383 load_descriptor_list = Qnil;
4384 staticpro (&load_descriptor_list);
4386 Qcurrent_load_list = intern ("current-load-list");
4387 staticpro (&Qcurrent_load_list);
4389 Qstandard_input = intern ("standard-input");
4390 staticpro (&Qstandard_input);
4392 Qread_char = intern ("read-char");
4393 staticpro (&Qread_char);
4395 Qget_file_char = intern ("get-file-char");
4396 staticpro (&Qget_file_char);
4398 Qget_emacs_mule_file_char = intern ("get-emacs-mule-file-char");
4399 staticpro (&Qget_emacs_mule_file_char);
4401 Qload_force_doc_strings = intern ("load-force-doc-strings");
4402 staticpro (&Qload_force_doc_strings);
4404 Qbackquote = intern ("`");
4405 staticpro (&Qbackquote);
4406 Qcomma = intern (",");
4407 staticpro (&Qcomma);
4408 Qcomma_at = intern (",@");
4409 staticpro (&Qcomma_at);
4410 Qcomma_dot = intern (",.");
4411 staticpro (&Qcomma_dot);
4413 Qinhibit_file_name_operation = intern ("inhibit-file-name-operation");
4414 staticpro (&Qinhibit_file_name_operation);
4416 Qascii_character = intern ("ascii-character");
4417 staticpro (&Qascii_character);
4419 Qfunction = intern ("function");
4420 staticpro (&Qfunction);
4422 Qload = intern ("load");
4423 staticpro (&Qload);
4425 Qload_file_name = intern ("load-file-name");
4426 staticpro (&Qload_file_name);
4428 Qeval_buffer_list = intern ("eval-buffer-list");
4429 staticpro (&Qeval_buffer_list);
4431 Qfile_truename = intern ("file-truename");
4432 staticpro (&Qfile_truename) ;
4434 Qdo_after_load_evaluation = intern ("do-after-load-evaluation");
4435 staticpro (&Qdo_after_load_evaluation) ;
4437 staticpro (&dump_path);
4439 staticpro (&read_objects);
4440 read_objects = Qnil;
4441 staticpro (&seen_list);
4442 seen_list = Qnil;
4444 Vloads_in_progress = Qnil;
4445 staticpro (&Vloads_in_progress);
4448 /* arch-tag: a0d02733-0f96-4844-a659-9fd53c4f414d
4449 (do not change this comment) */