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