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