*** empty log message ***
[emacs.git] / src / lread.c
blob4d2895ca2e641117cea31404e912ae9de21a3fc3
1 /* Lisp parsing and input streams.
2 Copyright (C) 1985, 86, 87, 88, 89, 93, 94, 95, 97, 98, 1999
3 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
10 any later version.
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
23 #include <config.h>
24 /* The following feature selections should be in config.h, but that
25 causes at best a host of warnings on some systems. */
26 #undef _XOPEN_SOURCE /* Avoid warnings about redefinition
27 in some cases. */
28 #define _XOPEN_SOURCE 500 /* for Unix 98 ftello on GNU */
29 #undef __EXTENSIONS__
30 #define __EXTENSIONS__ /* Keep Solaris 2.6 happy with the
31 above, else things we need are hidden. */
32 #include <stdio.h>
33 #include <sys/types.h>
34 #include <sys/stat.h>
35 #include <sys/file.h>
36 #include <errno.h>
37 #include "lisp.h"
38 #include "intervals.h"
39 #include "buffer.h"
40 #include "charset.h"
41 #include <epaths.h>
42 #include "commands.h"
43 #include "keyboard.h"
44 #include "termhooks.h"
46 #ifdef lint
47 #include <sys/inode.h>
48 #endif /* lint */
50 #ifdef MSDOS
51 #if __DJGPP__ < 2
52 #include <unistd.h> /* to get X_OK */
53 #endif
54 #include "msdos.h"
55 #endif
57 #ifdef HAVE_UNISTD_H
58 #include <unistd.h>
59 #endif
61 #ifndef X_OK
62 #define X_OK 01
63 #endif
65 #include <math.h>
67 #ifdef HAVE_SETLOCALE
68 #include <locale.h>
69 #endif /* HAVE_SETLOCALE */
71 #ifndef O_RDONLY
72 #define O_RDONLY 0
73 #endif
75 #ifdef HAVE_FTELLO
76 #define file_offset off_t
77 #define file_tell ftello
78 #else
79 #define file_offset long
80 #define file_tell ftell
81 #endif
83 extern int errno;
85 Lisp_Object Qread_char, Qget_file_char, Qstandard_input, Qcurrent_load_list;
86 Lisp_Object Qvariable_documentation, Vvalues, Vstandard_input, Vafter_load_alist;
87 Lisp_Object Qascii_character, Qload, Qload_file_name;
88 Lisp_Object Qbackquote, Qcomma, Qcomma_at, Qcomma_dot, Qfunction;
89 Lisp_Object Qinhibit_file_name_operation;
91 extern Lisp_Object Qevent_symbol_element_mask;
92 extern Lisp_Object Qfile_exists_p;
94 /* non-zero if inside `load' */
95 int load_in_progress;
97 /* Directory in which the sources were found. */
98 Lisp_Object Vsource_directory;
100 /* Search path for files to be loaded. */
101 Lisp_Object Vload_path;
103 /* File name of user's init file. */
104 Lisp_Object Vuser_init_file;
106 /* This is the user-visible association list that maps features to
107 lists of defs in their load files. */
108 Lisp_Object Vload_history;
110 /* This is used to build the load history. */
111 Lisp_Object Vcurrent_load_list;
113 /* List of files that were preloaded. */
114 Lisp_Object Vpreloaded_file_list;
116 /* Name of file actually being read by `load'. */
117 Lisp_Object Vload_file_name;
119 /* Function to use for reading, in `load' and friends. */
120 Lisp_Object Vload_read_function;
122 /* The association list of objects read with the #n=object form.
123 Each member of the list has the form (n . object), and is used to
124 look up the object for the corresponding #n# construct.
125 It must be set to nil before all top-level calls to read0. */
126 Lisp_Object read_objects;
128 /* Nonzero means load should forcibly load all dynamic doc strings. */
129 static int load_force_doc_strings;
131 /* Nonzero means read should convert strings to unibyte. */
132 static int load_convert_to_unibyte;
134 /* Function to use for loading an Emacs lisp source file (not
135 compiled) instead of readevalloop. */
136 Lisp_Object Vload_source_file_function;
138 /* List of all DEFVAR_BOOL variables. Used by the byte optimizer. */
139 Lisp_Object Vbyte_boolean_vars;
141 /* List of descriptors now open for Fload. */
142 static Lisp_Object load_descriptor_list;
144 /* File for get_file_char to read from. Use by load. */
145 static FILE *instream;
147 /* When nonzero, read conses in pure space */
148 static int read_pure;
150 /* For use within read-from-string (this reader is non-reentrant!!) */
151 static int read_from_string_index;
152 static int read_from_string_index_byte;
153 static int read_from_string_limit;
155 /* Number of bytes left to read in the buffer character
156 that `readchar' has already advanced over. */
157 static int readchar_backlog;
159 /* This contains the last string skipped with #@. */
160 static char *saved_doc_string;
161 /* Length of buffer allocated in saved_doc_string. */
162 static int saved_doc_string_size;
163 /* Length of actual data in saved_doc_string. */
164 static int saved_doc_string_length;
165 /* This is the file position that string came from. */
166 static file_offset saved_doc_string_position;
168 /* This contains the previous string skipped with #@.
169 We copy it from saved_doc_string when a new string
170 is put in saved_doc_string. */
171 static char *prev_saved_doc_string;
172 /* Length of buffer allocated in prev_saved_doc_string. */
173 static int prev_saved_doc_string_size;
174 /* Length of actual data in prev_saved_doc_string. */
175 static int prev_saved_doc_string_length;
176 /* This is the file position that string came from. */
177 static file_offset prev_saved_doc_string_position;
179 /* Nonzero means inside a new-style backquote
180 with no surrounding parentheses.
181 Fread initializes this to zero, so we need not specbind it
182 or worry about what happens to it when there is an error. */
183 static int new_backquote_flag;
185 /* Handle unreading and rereading of characters.
186 Write READCHAR to read a character,
187 UNREAD(c) to unread c to be read again.
189 These macros actually read/unread a byte code, multibyte characters
190 are not handled here. The caller should manage them if necessary.
193 #define READCHAR readchar (readcharfun)
194 #define UNREAD(c) unreadchar (readcharfun, c)
196 static int
197 readchar (readcharfun)
198 Lisp_Object readcharfun;
200 Lisp_Object tem;
201 register int c;
203 if (BUFFERP (readcharfun))
205 register struct buffer *inbuffer = XBUFFER (readcharfun);
207 int pt_byte = BUF_PT_BYTE (inbuffer);
208 int orig_pt_byte = pt_byte;
210 if (readchar_backlog > 0)
211 /* We get the address of the byte just passed,
212 which is the last byte of the character.
213 The other bytes in this character are consecutive with it,
214 because the gap can't be in the middle of a character. */
215 return *(BUF_BYTE_ADDRESS (inbuffer, BUF_PT_BYTE (inbuffer) - 1)
216 - --readchar_backlog);
218 if (pt_byte >= BUF_ZV_BYTE (inbuffer))
219 return -1;
221 readchar_backlog = -1;
223 if (! NILP (inbuffer->enable_multibyte_characters))
225 /* Fetch the character code from the buffer. */
226 unsigned char *p = BUF_BYTE_ADDRESS (inbuffer, pt_byte);
227 BUF_INC_POS (inbuffer, pt_byte);
228 c = STRING_CHAR (p, pt_byte - orig_pt_byte);
230 else
232 c = BUF_FETCH_BYTE (inbuffer, pt_byte);
233 pt_byte++;
235 SET_BUF_PT_BOTH (inbuffer, BUF_PT (inbuffer) + 1, pt_byte);
237 return c;
239 if (MARKERP (readcharfun))
241 register struct buffer *inbuffer = XMARKER (readcharfun)->buffer;
243 int bytepos = marker_byte_position (readcharfun);
244 int orig_bytepos = bytepos;
246 if (readchar_backlog > 0)
247 /* We get the address of the byte just passed,
248 which is the last byte of the character.
249 The other bytes in this character are consecutive with it,
250 because the gap can't be in the middle of a character. */
251 return *(BUF_BYTE_ADDRESS (inbuffer, XMARKER (readcharfun)->bytepos - 1)
252 - --readchar_backlog);
254 if (bytepos >= BUF_ZV_BYTE (inbuffer))
255 return -1;
257 readchar_backlog = -1;
259 if (! NILP (inbuffer->enable_multibyte_characters))
261 /* Fetch the character code from the buffer. */
262 unsigned char *p = BUF_BYTE_ADDRESS (inbuffer, bytepos);
263 BUF_INC_POS (inbuffer, bytepos);
264 c = STRING_CHAR (p, bytepos - orig_bytepos);
266 else
268 c = BUF_FETCH_BYTE (inbuffer, bytepos);
269 bytepos++;
272 XMARKER (readcharfun)->bytepos = bytepos;
273 XMARKER (readcharfun)->charpos++;
275 return c;
278 if (EQ (readcharfun, Qlambda))
279 return read_bytecode_char (0);
281 if (EQ (readcharfun, Qget_file_char))
283 c = getc (instream);
284 #ifdef EINTR
285 /* Interrupted reads have been observed while reading over the network */
286 while (c == EOF && ferror (instream) && errno == EINTR)
288 clearerr (instream);
289 c = getc (instream);
291 #endif
292 return c;
295 if (STRINGP (readcharfun))
297 if (read_from_string_index >= read_from_string_limit)
298 c = -1;
299 else if (STRING_MULTIBYTE (readcharfun))
300 FETCH_STRING_CHAR_ADVANCE (c, readcharfun,
301 read_from_string_index,
302 read_from_string_index_byte);
303 else
304 c = XSTRING (readcharfun)->data[read_from_string_index++];
306 return c;
309 tem = call0 (readcharfun);
311 if (NILP (tem))
312 return -1;
313 return XINT (tem);
316 /* Unread the character C in the way appropriate for the stream READCHARFUN.
317 If the stream is a user function, call it with the char as argument. */
319 static void
320 unreadchar (readcharfun, c)
321 Lisp_Object readcharfun;
322 int c;
324 if (c == -1)
325 /* Don't back up the pointer if we're unreading the end-of-input mark,
326 since readchar didn't advance it when we read it. */
328 else if (BUFFERP (readcharfun))
330 struct buffer *b = XBUFFER (readcharfun);
331 int bytepos = BUF_PT_BYTE (b);
333 if (readchar_backlog >= 0)
334 readchar_backlog++;
335 else
337 BUF_PT (b)--;
338 if (! NILP (b->enable_multibyte_characters))
339 BUF_DEC_POS (b, bytepos);
340 else
341 bytepos--;
343 BUF_PT_BYTE (b) = bytepos;
346 else if (MARKERP (readcharfun))
348 struct buffer *b = XMARKER (readcharfun)->buffer;
349 int bytepos = XMARKER (readcharfun)->bytepos;
351 if (readchar_backlog >= 0)
352 readchar_backlog++;
353 else
355 XMARKER (readcharfun)->charpos--;
356 if (! NILP (b->enable_multibyte_characters))
357 BUF_DEC_POS (b, bytepos);
358 else
359 bytepos--;
361 XMARKER (readcharfun)->bytepos = bytepos;
364 else if (STRINGP (readcharfun))
366 read_from_string_index--;
367 read_from_string_index_byte
368 = string_char_to_byte (readcharfun, read_from_string_index);
370 else if (EQ (readcharfun, Qlambda))
371 read_bytecode_char (1);
372 else if (EQ (readcharfun, Qget_file_char))
373 ungetc (c, instream);
374 else
375 call1 (readcharfun, make_number (c));
378 static Lisp_Object read0 (), read1 (), read_list (), read_vector ();
379 static int read_multibyte ();
380 static Lisp_Object substitute_object_recurse ();
381 static void substitute_object_in_subtree (), substitute_in_interval ();
384 /* Get a character from the tty. */
386 extern Lisp_Object read_char ();
388 /* Read input events until we get one that's acceptable for our purposes.
390 If NO_SWITCH_FRAME is non-zero, switch-frame events are stashed
391 until we get a character we like, and then stuffed into
392 unread_switch_frame.
394 If ASCII_REQUIRED is non-zero, we check function key events to see
395 if the unmodified version of the symbol has a Qascii_character
396 property, and use that character, if present.
398 If ERROR_NONASCII is non-zero, we signal an error if the input we
399 get isn't an ASCII character with modifiers. If it's zero but
400 ASCII_REQUIRED is non-zero, we just re-read until we get an ASCII
401 character.
403 If INPUT_METHOD is nonzero, we invoke the current input method
404 if the character warrants that. */
406 Lisp_Object
407 read_filtered_event (no_switch_frame, ascii_required, error_nonascii,
408 input_method)
409 int no_switch_frame, ascii_required, error_nonascii, input_method;
411 register Lisp_Object val, delayed_switch_frame;
413 delayed_switch_frame = Qnil;
415 /* Read until we get an acceptable event. */
416 retry:
417 val = read_char (0, 0, 0,
418 (input_method ? Qnil : Qt),
421 if (BUFFERP (val))
422 goto retry;
424 /* switch-frame events are put off until after the next ASCII
425 character. This is better than signaling an error just because
426 the last characters were typed to a separate minibuffer frame,
427 for example. Eventually, some code which can deal with
428 switch-frame events will read it and process it. */
429 if (no_switch_frame
430 && EVENT_HAS_PARAMETERS (val)
431 && EQ (EVENT_HEAD (val), Qswitch_frame))
433 delayed_switch_frame = val;
434 goto retry;
437 if (ascii_required)
439 /* Convert certain symbols to their ASCII equivalents. */
440 if (SYMBOLP (val))
442 Lisp_Object tem, tem1;
443 tem = Fget (val, Qevent_symbol_element_mask);
444 if (!NILP (tem))
446 tem1 = Fget (Fcar (tem), Qascii_character);
447 /* Merge this symbol's modifier bits
448 with the ASCII equivalent of its basic code. */
449 if (!NILP (tem1))
450 XSETFASTINT (val, XINT (tem1) | XINT (Fcar (Fcdr (tem))));
454 /* If we don't have a character now, deal with it appropriately. */
455 if (!INTEGERP (val))
457 if (error_nonascii)
459 Vunread_command_events = Fcons (val, Qnil);
460 error ("Non-character input-event");
462 else
463 goto retry;
467 if (! NILP (delayed_switch_frame))
468 unread_switch_frame = delayed_switch_frame;
470 return val;
473 DEFUN ("read-char", Fread_char, Sread_char, 0, 2, 0,
474 "Read a character from the command input (keyboard or macro).\n\
475 It is returned as a number.\n\
476 If the user generates an event which is not a character (i.e. a mouse\n\
477 click or function key event), `read-char' signals an error. As an\n\
478 exception, switch-frame events are put off until non-ASCII events can\n\
479 be read.\n\
480 If you want to read non-character events, or ignore them, call\n\
481 `read-event' or `read-char-exclusive' instead.\n\
483 If the optional argument PROMPT is non-nil, display that as a prompt.\n\
484 If the optional argument INHERIT-INPUT-METHOD is non-nil and some\n\
485 input method is turned on in the current buffer, that input method\n\
486 is used for reading a character.")
487 (prompt, inherit_input_method)
488 Lisp_Object prompt, inherit_input_method;
490 if (! NILP (prompt))
491 message_with_string ("%s", prompt, 0);
492 return read_filtered_event (1, 1, 1, ! NILP (inherit_input_method));
495 DEFUN ("read-event", Fread_event, Sread_event, 0, 2, 0,
496 "Read an event object from the input stream.\n\
497 If the optional argument PROMPT is non-nil, display that as a prompt.\n\
498 If the optional argument INHERIT-INPUT-METHOD is non-nil and some\n\
499 input method is turned on in the current buffer, that input method\n\
500 is used for reading a character.")
501 (prompt, inherit_input_method)
502 Lisp_Object prompt, inherit_input_method;
504 if (! NILP (prompt))
505 message_with_string ("%s", prompt, 0);
506 return read_filtered_event (0, 0, 0, ! NILP (inherit_input_method));
509 DEFUN ("read-char-exclusive", Fread_char_exclusive, Sread_char_exclusive, 0, 2, 0,
510 "Read a character from the command input (keyboard or macro).\n\
511 It is returned as a number. Non-character events are ignored.\n\
513 If the optional argument PROMPT is non-nil, display that as a prompt.\n\
514 If the optional argument INHERIT-INPUT-METHOD is non-nil and some\n\
515 input method is turned on in the current buffer, that input method\n\
516 is used for reading a character.")
517 (prompt, inherit_input_method)
518 Lisp_Object prompt, inherit_input_method;
520 if (! NILP (prompt))
521 message_with_string ("%s", prompt, 0);
522 return read_filtered_event (1, 1, 0, ! NILP (inherit_input_method));
525 DEFUN ("get-file-char", Fget_file_char, Sget_file_char, 0, 0, 0,
526 "Don't use this yourself.")
529 register Lisp_Object val;
530 XSETINT (val, getc (instream));
531 return val;
534 static void readevalloop ();
535 static Lisp_Object load_unwind ();
536 static Lisp_Object load_descriptor_unwind ();
538 /* Non-zero means load dangerous compiled Lisp files. */
540 int load_dangerous_libraries;
542 /* A regular expression used to detect files compiled with Emacs. */
544 static Lisp_Object Vbytecomp_version_regexp;
547 /* Value is non-zero if the file asswociated with file descriptor FD
548 is a compiled Lisp file that's safe to load. Only files compiled
549 with Emacs are safe to load. Files compiled with XEmacs can lead
550 to a crash in Fbyte_code because of an incompatible change in the
551 byte compiler. */
553 static int
554 safe_to_load_p (fd)
555 int fd;
557 char buf[512];
558 int nbytes, i;
559 int safe_p = 1;
561 /* Read the first few bytes from the file, and look for a line
562 specifying the byte compiler version used. */
563 nbytes = emacs_read (fd, buf, sizeof buf - 1);
564 if (nbytes > 0)
566 buf[nbytes] = '\0';
568 /* Skip to the next newline, skipping over the initial `ELC'
569 with NUL bytes following it. */
570 for (i = 0; i < nbytes && buf[i] != '\n'; ++i)
573 if (i < nbytes
574 && fast_c_string_match_ignore_case (Vbytecomp_version_regexp,
575 buf + i) < 0)
576 safe_p = 0;
579 lseek (fd, 0, SEEK_SET);
580 return safe_p;
584 DEFUN ("load", Fload, Sload, 1, 5, 0,
585 "Execute a file of Lisp code named FILE.\n\
586 First try FILE with `.elc' appended, then try with `.el',\n\
587 then try FILE unmodified.\n\
588 This function searches the directories in `load-path'.\n\
589 If optional second arg NOERROR is non-nil,\n\
590 report no error if FILE doesn't exist.\n\
591 Print messages at start and end of loading unless\n\
592 optional third arg NOMESSAGE is non-nil.\n\
593 If optional fourth arg NOSUFFIX is non-nil, don't try adding\n\
594 suffixes `.elc' or `.el' to the specified name FILE.\n\
595 If optional fifth arg MUST-SUFFIX is non-nil, insist on\n\
596 the suffix `.elc' or `.el'; don't accept just FILE unless\n\
597 it ends in one of those suffixes or includes a directory name.\n\
598 Return t if file exists.")
599 (file, noerror, nomessage, nosuffix, must_suffix)
600 Lisp_Object file, noerror, nomessage, nosuffix, must_suffix;
602 register FILE *stream;
603 register int fd = -1;
604 register Lisp_Object lispstream;
605 int count = specpdl_ptr - specpdl;
606 Lisp_Object temp;
607 struct gcpro gcpro1;
608 Lisp_Object found;
609 /* 1 means we printed the ".el is newer" message. */
610 int newer = 0;
611 /* 1 means we are loading a compiled file. */
612 int compiled = 0;
613 Lisp_Object handler;
614 int safe_p = 1;
615 char *fmode = "r";
616 #ifdef DOS_NT
617 fmode = "rt";
618 #endif /* DOS_NT */
620 CHECK_STRING (file, 0);
622 /* If file name is magic, call the handler. */
623 handler = Ffind_file_name_handler (file, Qload);
624 if (!NILP (handler))
625 return call5 (handler, Qload, file, noerror, nomessage, nosuffix);
627 /* Do this after the handler to avoid
628 the need to gcpro noerror, nomessage and nosuffix.
629 (Below here, we care only whether they are nil or not.) */
630 file = Fsubstitute_in_file_name (file);
632 /* Avoid weird lossage with null string as arg,
633 since it would try to load a directory as a Lisp file */
634 if (XSTRING (file)->size > 0)
636 int size = STRING_BYTES (XSTRING (file));
638 GCPRO1 (file);
640 if (! NILP (must_suffix))
642 /* Don't insist on adding a suffix if FILE already ends with one. */
643 if (size > 3
644 && !strcmp (XSTRING (file)->data + size - 3, ".el"))
645 must_suffix = Qnil;
646 else if (size > 4
647 && !strcmp (XSTRING (file)->data + size - 4, ".elc"))
648 must_suffix = Qnil;
649 /* Don't insist on adding a suffix
650 if the argument includes a directory name. */
651 else if (! NILP (Ffile_name_directory (file)))
652 must_suffix = Qnil;
655 fd = openp (Vload_path, file,
656 (!NILP (nosuffix) ? ""
657 : ! NILP (must_suffix) ? ".elc.gz:.elc:.el.gz:.el"
658 : ".elc:.elc.gz:.el.gz:.el:"),
659 &found, 0);
660 UNGCPRO;
663 if (fd < 0)
665 if (NILP (noerror))
666 while (1)
667 Fsignal (Qfile_error, Fcons (build_string ("Cannot open load file"),
668 Fcons (file, Qnil)));
669 else
670 return Qnil;
673 if (EQ (Qt, Vuser_init_file))
674 Vuser_init_file = found;
676 /* If FD is 0, that means openp found a magic file. */
677 if (fd == 0)
679 if (NILP (Fequal (found, file)))
680 /* If FOUND is a different file name from FILE,
681 find its handler even if we have already inhibited
682 the `load' operation on FILE. */
683 handler = Ffind_file_name_handler (found, Qt);
684 else
685 handler = Ffind_file_name_handler (found, Qload);
686 if (! NILP (handler))
687 return call5 (handler, Qload, found, noerror, nomessage, Qt);
690 /* Load .elc files directly, but not when they are
691 remote and have no handler! */
692 if (!bcmp (&(XSTRING (found)->data[STRING_BYTES (XSTRING (found)) - 4]),
693 ".elc", 4)
694 && fd != 0)
696 struct stat s1, s2;
697 int result;
699 if (!safe_to_load_p (fd))
701 safe_p = 0;
702 if (!load_dangerous_libraries)
703 error ("File `%s' was not compiled in Emacs",
704 XSTRING (found)->data);
705 else if (!NILP (nomessage))
706 message_with_string ("File `%s' not compiled in Emacs", found, 1);
709 compiled = 1;
711 #ifdef DOS_NT
712 fmode = "rb";
713 #endif /* DOS_NT */
714 stat ((char *)XSTRING (found)->data, &s1);
715 XSTRING (found)->data[STRING_BYTES (XSTRING (found)) - 1] = 0;
716 result = stat ((char *)XSTRING (found)->data, &s2);
717 if (result >= 0 && (unsigned) s1.st_mtime < (unsigned) s2.st_mtime)
719 /* Make the progress messages mention that source is newer. */
720 newer = 1;
722 /* If we won't print another message, mention this anyway. */
723 if (! NILP (nomessage))
724 message_with_string ("Source file `%s' newer than byte-compiled file",
725 found, 1);
727 XSTRING (found)->data[STRING_BYTES (XSTRING (found)) - 1] = 'c';
729 else
731 load_source:
733 /* We are loading a source file (*.el). */
734 if (!NILP (Vload_source_file_function))
736 if (fd != 0)
737 emacs_close (fd);
738 return call4 (Vload_source_file_function, found, file,
739 NILP (noerror) ? Qnil : Qt,
740 NILP (nomessage) ? Qnil : Qt);
744 #ifdef WINDOWSNT
745 emacs_close (fd);
746 stream = fopen ((char *) XSTRING (found)->data, fmode);
747 #else /* not WINDOWSNT */
748 stream = fdopen (fd, fmode);
749 #endif /* not WINDOWSNT */
750 if (stream == 0)
752 emacs_close (fd);
753 error ("Failure to create stdio stream for %s", XSTRING (file)->data);
756 if (! NILP (Vpurify_flag))
757 Vpreloaded_file_list = Fcons (file, Vpreloaded_file_list);
759 if (NILP (nomessage))
761 if (!safe_p)
762 message_with_string ("Loading %s (compiled; note unsafe, not compiled in Emacs)...",
763 file, 1);
764 else if (!compiled)
765 message_with_string ("Loading %s (source)...", file, 1);
766 else if (newer)
767 message_with_string ("Loading %s (compiled; note, source file is newer)...",
768 file, 1);
769 else /* The typical case; compiled file newer than source file. */
770 message_with_string ("Loading %s...", file, 1);
773 GCPRO1 (file);
774 lispstream = Fcons (Qnil, Qnil);
775 XSETFASTINT (XCAR (lispstream), (EMACS_UINT)stream >> 16);
776 XSETFASTINT (XCDR (lispstream), (EMACS_UINT)stream & 0xffff);
777 record_unwind_protect (load_unwind, lispstream);
778 record_unwind_protect (load_descriptor_unwind, load_descriptor_list);
779 specbind (Qload_file_name, found);
780 specbind (Qinhibit_file_name_operation, Qnil);
781 load_descriptor_list
782 = Fcons (make_number (fileno (stream)), load_descriptor_list);
783 load_in_progress++;
784 readevalloop (Qget_file_char, stream, file, Feval, 0, Qnil, Qnil);
785 unbind_to (count, Qnil);
787 /* Run any load-hooks for this file. */
788 temp = Fassoc (file, Vafter_load_alist);
789 if (!NILP (temp))
790 Fprogn (Fcdr (temp));
791 UNGCPRO;
793 if (saved_doc_string)
794 free (saved_doc_string);
795 saved_doc_string = 0;
796 saved_doc_string_size = 0;
798 if (prev_saved_doc_string)
799 xfree (prev_saved_doc_string);
800 prev_saved_doc_string = 0;
801 prev_saved_doc_string_size = 0;
803 if (!noninteractive && NILP (nomessage))
805 if (!safe_p)
806 message_with_string ("Loading %s (compiled; note unsafe, not compiled in Emacs)...done",
807 file, 1);
808 else if (!compiled)
809 message_with_string ("Loading %s (source)...done", file, 1);
810 else if (newer)
811 message_with_string ("Loading %s (compiled; note, source file is newer)...done",
812 file, 1);
813 else /* The typical case; compiled file newer than source file. */
814 message_with_string ("Loading %s...done", file, 1);
816 return Qt;
819 static Lisp_Object
820 load_unwind (stream) /* used as unwind-protect function in load */
821 Lisp_Object stream;
823 fclose ((FILE *) (XFASTINT (XCAR (stream)) << 16
824 | XFASTINT (XCDR (stream))));
825 if (--load_in_progress < 0) load_in_progress = 0;
826 return Qnil;
829 static Lisp_Object
830 load_descriptor_unwind (oldlist)
831 Lisp_Object oldlist;
833 load_descriptor_list = oldlist;
834 return Qnil;
837 /* Close all descriptors in use for Floads.
838 This is used when starting a subprocess. */
840 void
841 close_load_descs ()
843 #ifndef WINDOWSNT
844 Lisp_Object tail;
845 for (tail = load_descriptor_list; !NILP (tail); tail = XCDR (tail))
846 emacs_close (XFASTINT (XCAR (tail)));
847 #endif
850 static int
851 complete_filename_p (pathname)
852 Lisp_Object pathname;
854 register unsigned char *s = XSTRING (pathname)->data;
855 return (IS_DIRECTORY_SEP (s[0])
856 || (XSTRING (pathname)->size > 2
857 && IS_DEVICE_SEP (s[1]) && IS_DIRECTORY_SEP (s[2]))
858 #ifdef ALTOS
859 || *s == '@'
860 #endif
861 #ifdef VMS
862 || index (s, ':')
863 #endif /* VMS */
867 /* Search for a file whose name is STR, looking in directories
868 in the Lisp list PATH, and trying suffixes from SUFFIX.
869 SUFFIX is a string containing possible suffixes separated by colons.
870 On success, returns a file descriptor. On failure, returns -1.
872 EXEC_ONLY nonzero means don't open the files,
873 just look for one that is executable. In this case,
874 returns 1 on success.
876 If STOREPTR is nonzero, it points to a slot where the name of
877 the file actually found should be stored as a Lisp string.
878 nil is stored there on failure.
880 If the file we find is remote, return 0
881 but store the found remote file name in *STOREPTR.
882 We do not check for remote files if EXEC_ONLY is nonzero. */
885 openp (path, str, suffix, storeptr, exec_only)
886 Lisp_Object path, str;
887 char *suffix;
888 Lisp_Object *storeptr;
889 int exec_only;
891 register int fd;
892 int fn_size = 100;
893 char buf[100];
894 register char *fn = buf;
895 int absolute = 0;
896 int want_size;
897 Lisp_Object filename;
898 struct stat st;
899 struct gcpro gcpro1;
901 GCPRO1 (str);
902 if (storeptr)
903 *storeptr = Qnil;
905 if (complete_filename_p (str))
906 absolute = 1;
908 for (; !NILP (path); path = Fcdr (path))
910 char *nsuffix;
912 filename = Fexpand_file_name (str, Fcar (path));
913 if (!complete_filename_p (filename))
914 /* If there are non-absolute elts in PATH (eg ".") */
915 /* Of course, this could conceivably lose if luser sets
916 default-directory to be something non-absolute... */
918 filename = Fexpand_file_name (filename, current_buffer->directory);
919 if (!complete_filename_p (filename))
920 /* Give up on this path element! */
921 continue;
924 /* Calculate maximum size of any filename made from
925 this path element/specified file name and any possible suffix. */
926 want_size = strlen (suffix) + STRING_BYTES (XSTRING (filename)) + 1;
927 if (fn_size < want_size)
928 fn = (char *) alloca (fn_size = 100 + want_size);
930 nsuffix = suffix;
932 /* Loop over suffixes. */
933 while (1)
935 char *esuffix = (char *) index (nsuffix, ':');
936 int lsuffix = esuffix ? esuffix - nsuffix : strlen (nsuffix);
937 Lisp_Object handler;
939 /* Concatenate path element/specified name with the suffix.
940 If the directory starts with /:, remove that. */
941 if (XSTRING (filename)->size > 2
942 && XSTRING (filename)->data[0] == '/'
943 && XSTRING (filename)->data[1] == ':')
945 strncpy (fn, XSTRING (filename)->data + 2,
946 STRING_BYTES (XSTRING (filename)) - 2);
947 fn[STRING_BYTES (XSTRING (filename)) - 2] = 0;
949 else
951 strncpy (fn, XSTRING (filename)->data,
952 STRING_BYTES (XSTRING (filename)));
953 fn[STRING_BYTES (XSTRING (filename))] = 0;
956 if (lsuffix != 0) /* Bug happens on CCI if lsuffix is 0. */
957 strncat (fn, nsuffix, lsuffix);
959 /* Check that the file exists and is not a directory. */
960 if (absolute)
961 handler = Qnil;
962 else
963 handler = Ffind_file_name_handler (filename, Qfile_exists_p);
964 if (! NILP (handler) && ! exec_only)
966 Lisp_Object string;
967 int exists;
969 string = build_string (fn);
970 exists = ! NILP (exec_only ? Ffile_executable_p (string)
971 : Ffile_readable_p (string));
972 if (exists
973 && ! NILP (Ffile_directory_p (build_string (fn))))
974 exists = 0;
976 if (exists)
978 /* We succeeded; return this descriptor and filename. */
979 if (storeptr)
980 *storeptr = build_string (fn);
981 UNGCPRO;
982 return 0;
985 else
987 int exists = (stat (fn, &st) >= 0
988 && (st.st_mode & S_IFMT) != S_IFDIR);
989 if (exists)
991 /* Check that we can access or open it. */
992 if (exec_only)
993 fd = (access (fn, X_OK) == 0) ? 1 : -1;
994 else
995 fd = emacs_open (fn, O_RDONLY, 0);
997 if (fd >= 0)
999 /* We succeeded; return this descriptor and filename. */
1000 if (storeptr)
1001 *storeptr = build_string (fn);
1002 UNGCPRO;
1003 return fd;
1008 /* Advance to next suffix. */
1009 if (esuffix == 0)
1010 break;
1011 nsuffix += lsuffix + 1;
1013 if (absolute)
1014 break;
1017 UNGCPRO;
1018 return -1;
1022 /* Merge the list we've accumulated of globals from the current input source
1023 into the load_history variable. The details depend on whether
1024 the source has an associated file name or not. */
1026 static void
1027 build_load_history (stream, source)
1028 FILE *stream;
1029 Lisp_Object source;
1031 register Lisp_Object tail, prev, newelt;
1032 register Lisp_Object tem, tem2;
1033 register int foundit, loading;
1035 loading = stream || !NARROWED;
1037 tail = Vload_history;
1038 prev = Qnil;
1039 foundit = 0;
1040 while (!NILP (tail))
1042 tem = Fcar (tail);
1044 /* Find the feature's previous assoc list... */
1045 if (!NILP (Fequal (source, Fcar (tem))))
1047 foundit = 1;
1049 /* If we're loading, remove it. */
1050 if (loading)
1052 if (NILP (prev))
1053 Vload_history = Fcdr (tail);
1054 else
1055 Fsetcdr (prev, Fcdr (tail));
1058 /* Otherwise, cons on new symbols that are not already members. */
1059 else
1061 tem2 = Vcurrent_load_list;
1063 while (CONSP (tem2))
1065 newelt = Fcar (tem2);
1067 if (NILP (Fmemq (newelt, tem)))
1068 Fsetcar (tail, Fcons (Fcar (tem),
1069 Fcons (newelt, Fcdr (tem))));
1071 tem2 = Fcdr (tem2);
1072 QUIT;
1076 else
1077 prev = tail;
1078 tail = Fcdr (tail);
1079 QUIT;
1082 /* If we're loading, cons the new assoc onto the front of load-history,
1083 the most-recently-loaded position. Also do this if we didn't find
1084 an existing member for the current source. */
1085 if (loading || !foundit)
1086 Vload_history = Fcons (Fnreverse (Vcurrent_load_list),
1087 Vload_history);
1090 Lisp_Object
1091 unreadpure () /* Used as unwind-protect function in readevalloop */
1093 read_pure = 0;
1094 return Qnil;
1097 static Lisp_Object
1098 readevalloop_1 (old)
1099 Lisp_Object old;
1101 load_convert_to_unibyte = ! NILP (old);
1102 return Qnil;
1105 /* UNIBYTE specifies how to set load_convert_to_unibyte
1106 for this invocation.
1107 READFUN, if non-nil, is used instead of `read'. */
1109 static void
1110 readevalloop (readcharfun, stream, sourcename, evalfun, printflag, unibyte, readfun)
1111 Lisp_Object readcharfun;
1112 FILE *stream;
1113 Lisp_Object sourcename;
1114 Lisp_Object (*evalfun) ();
1115 int printflag;
1116 Lisp_Object unibyte, readfun;
1118 register int c;
1119 register Lisp_Object val;
1120 int count = specpdl_ptr - specpdl;
1121 struct gcpro gcpro1;
1122 struct buffer *b = 0;
1124 if (BUFFERP (readcharfun))
1125 b = XBUFFER (readcharfun);
1126 else if (MARKERP (readcharfun))
1127 b = XMARKER (readcharfun)->buffer;
1129 specbind (Qstandard_input, readcharfun);
1130 specbind (Qcurrent_load_list, Qnil);
1131 record_unwind_protect (readevalloop_1, load_convert_to_unibyte ? Qt : Qnil);
1132 load_convert_to_unibyte = !NILP (unibyte);
1134 readchar_backlog = -1;
1136 GCPRO1 (sourcename);
1138 LOADHIST_ATTACH (sourcename);
1140 while (1)
1142 if (b != 0 && NILP (b->name))
1143 error ("Reading from killed buffer");
1145 instream = stream;
1146 c = READCHAR;
1147 if (c == ';')
1149 while ((c = READCHAR) != '\n' && c != -1);
1150 continue;
1152 if (c < 0) break;
1154 /* Ignore whitespace here, so we can detect eof. */
1155 if (c == ' ' || c == '\t' || c == '\n' || c == '\f' || c == '\r')
1156 continue;
1158 if (!NILP (Vpurify_flag) && c == '(')
1160 int count1 = specpdl_ptr - specpdl;
1161 record_unwind_protect (unreadpure, Qnil);
1162 val = read_list (-1, readcharfun);
1163 unbind_to (count1, Qnil);
1165 else
1167 UNREAD (c);
1168 read_objects = Qnil;
1169 if (! NILP (readfun))
1170 val = call1 (readfun, readcharfun);
1171 else if (! NILP (Vload_read_function))
1172 val = call1 (Vload_read_function, readcharfun);
1173 else
1174 val = read0 (readcharfun);
1177 val = (*evalfun) (val);
1178 if (printflag)
1180 Vvalues = Fcons (val, Vvalues);
1181 if (EQ (Vstandard_output, Qt))
1182 Fprin1 (val, Qnil);
1183 else
1184 Fprint (val, Qnil);
1188 build_load_history (stream, sourcename);
1189 UNGCPRO;
1191 unbind_to (count, Qnil);
1194 DEFUN ("eval-buffer", Feval_buffer, Seval_buffer, 0, 5, "",
1195 "Execute the current buffer as Lisp code.\n\
1196 Programs can pass two arguments, BUFFER and PRINTFLAG.\n\
1197 BUFFER is the buffer to evaluate (nil means use current buffer).\n\
1198 PRINTFLAG controls printing of output:\n\
1199 nil means discard it; anything else is stream for print.\n\
1201 If the optional third argument FILENAME is non-nil,\n\
1202 it specifies the file name to use for `load-history'.\n\
1203 The optional fourth argument UNIBYTE specifies `load-convert-to-unibyte'\n\
1204 for this invocation.\n\
1206 The optional fifth argument DO-ALLOW-PRINT, if not-nil, specifies that\n\
1207 `print' and related functions should work normally even if PRINTFLAG is nil.\n\
1209 This function preserves the position of point.")
1210 (buffer, printflag, filename, unibyte, do_allow_print)
1211 Lisp_Object buffer, printflag, filename, unibyte, do_allow_print;
1213 int count = specpdl_ptr - specpdl;
1214 Lisp_Object tem, buf;
1216 if (NILP (buffer))
1217 buf = Fcurrent_buffer ();
1218 else
1219 buf = Fget_buffer (buffer);
1220 if (NILP (buf))
1221 error ("No such buffer");
1223 if (NILP (printflag) && NILP (do_allow_print))
1224 tem = Qsymbolp;
1225 else
1226 tem = printflag;
1228 if (NILP (filename))
1229 filename = XBUFFER (buf)->filename;
1231 specbind (Qstandard_output, tem);
1232 record_unwind_protect (save_excursion_restore, save_excursion_save ());
1233 BUF_SET_PT (XBUFFER (buf), BUF_BEGV (XBUFFER (buf)));
1234 readevalloop (buf, 0, filename, Feval, !NILP (printflag), unibyte, Qnil);
1235 unbind_to (count, Qnil);
1237 return Qnil;
1240 #if 0
1241 XDEFUN ("eval-current-buffer", Feval_current_buffer, Seval_current_buffer, 0, 1, "",
1242 "Execute the current buffer as Lisp code.\n\
1243 Programs can pass argument PRINTFLAG which controls printing of output:\n\
1244 nil means discard it; anything else is stream for print.\n\
1246 If there is no error, point does not move. If there is an error,\n\
1247 point remains at the end of the last character read from the buffer.")
1248 (printflag)
1249 Lisp_Object printflag;
1251 int count = specpdl_ptr - specpdl;
1252 Lisp_Object tem, cbuf;
1254 cbuf = Fcurrent_buffer ()
1256 if (NILP (printflag))
1257 tem = Qsymbolp;
1258 else
1259 tem = printflag;
1260 specbind (Qstandard_output, tem);
1261 record_unwind_protect (save_excursion_restore, save_excursion_save ());
1262 SET_PT (BEGV);
1263 readevalloop (cbuf, 0, XBUFFER (cbuf)->filename, Feval,
1264 !NILP (printflag), Qnil, Qnil);
1265 return unbind_to (count, Qnil);
1267 #endif
1269 DEFUN ("eval-region", Feval_region, Seval_region, 2, 4, "r",
1270 "Execute the region as Lisp code.\n\
1271 When called from programs, expects two arguments,\n\
1272 giving starting and ending indices in the current buffer\n\
1273 of the text to be executed.\n\
1274 Programs can pass third argument PRINTFLAG which controls output:\n\
1275 nil means discard it; anything else is stream for printing it.\n\
1276 Also the fourth argument READ-FUNCTION, if non-nil, is used\n\
1277 instead of `read' to read each expression. It gets one argument\n\
1278 which is the input stream for reading characters.\n\
1280 This function does not move point.")
1281 (start, end, printflag, read_function)
1282 Lisp_Object start, end, printflag, read_function;
1284 int count = specpdl_ptr - specpdl;
1285 Lisp_Object tem, cbuf;
1287 cbuf = Fcurrent_buffer ();
1289 if (NILP (printflag))
1290 tem = Qsymbolp;
1291 else
1292 tem = printflag;
1293 specbind (Qstandard_output, tem);
1295 if (NILP (printflag))
1296 record_unwind_protect (save_excursion_restore, save_excursion_save ());
1297 record_unwind_protect (save_restriction_restore, save_restriction_save ());
1299 /* This both uses start and checks its type. */
1300 Fgoto_char (start);
1301 Fnarrow_to_region (make_number (BEGV), end);
1302 readevalloop (cbuf, 0, XBUFFER (cbuf)->filename, Feval,
1303 !NILP (printflag), Qnil, read_function);
1305 return unbind_to (count, Qnil);
1309 DEFUN ("read", Fread, Sread, 0, 1, 0,
1310 "Read one Lisp expression as text from STREAM, return as Lisp object.\n\
1311 If STREAM is nil, use the value of `standard-input' (which see).\n\
1312 STREAM or the value of `standard-input' may be:\n\
1313 a buffer (read from point and advance it)\n\
1314 a marker (read from where it points and advance it)\n\
1315 a function (call it with no arguments for each character,\n\
1316 call it with a char as argument to push a char back)\n\
1317 a string (takes text from string, starting at the beginning)\n\
1318 t (read text line using minibuffer and use it).")
1319 (stream)
1320 Lisp_Object stream;
1322 extern Lisp_Object Fread_minibuffer ();
1324 if (NILP (stream))
1325 stream = Vstandard_input;
1326 if (EQ (stream, Qt))
1327 stream = Qread_char;
1329 readchar_backlog = -1;
1330 new_backquote_flag = 0;
1331 read_objects = Qnil;
1333 if (EQ (stream, Qread_char))
1334 return Fread_minibuffer (build_string ("Lisp expression: "), Qnil);
1336 if (STRINGP (stream))
1337 return Fcar (Fread_from_string (stream, Qnil, Qnil));
1339 return read0 (stream);
1342 DEFUN ("read-from-string", Fread_from_string, Sread_from_string, 1, 3, 0,
1343 "Read one Lisp expression which is represented as text by STRING.\n\
1344 Returns a cons: (OBJECT-READ . FINAL-STRING-INDEX).\n\
1345 START and END optionally delimit a substring of STRING from which to read;\n\
1346 they default to 0 and (length STRING) respectively.")
1347 (string, start, end)
1348 Lisp_Object string, start, end;
1350 int startval, endval;
1351 Lisp_Object tem;
1353 CHECK_STRING (string,0);
1355 if (NILP (end))
1356 endval = XSTRING (string)->size;
1357 else
1359 CHECK_NUMBER (end, 2);
1360 endval = XINT (end);
1361 if (endval < 0 || endval > XSTRING (string)->size)
1362 args_out_of_range (string, end);
1365 if (NILP (start))
1366 startval = 0;
1367 else
1369 CHECK_NUMBER (start, 1);
1370 startval = XINT (start);
1371 if (startval < 0 || startval > endval)
1372 args_out_of_range (string, start);
1375 read_from_string_index = startval;
1376 read_from_string_index_byte = string_char_to_byte (string, startval);
1377 read_from_string_limit = endval;
1379 new_backquote_flag = 0;
1380 read_objects = Qnil;
1382 tem = read0 (string);
1383 return Fcons (tem, make_number (read_from_string_index));
1386 /* Use this for recursive reads, in contexts where internal tokens
1387 are not allowed. */
1389 static Lisp_Object
1390 read0 (readcharfun)
1391 Lisp_Object readcharfun;
1393 register Lisp_Object val;
1394 int c;
1396 val = read1 (readcharfun, &c, 0);
1397 if (c)
1398 Fsignal (Qinvalid_read_syntax, Fcons (Fmake_string (make_number (1),
1399 make_number (c)),
1400 Qnil));
1402 return val;
1405 static int read_buffer_size;
1406 static char *read_buffer;
1408 /* Read multibyte form and return it as a character. C is a first
1409 byte of multibyte form, and rest of them are read from
1410 READCHARFUN. */
1412 static int
1413 read_multibyte (c, readcharfun)
1414 register int c;
1415 Lisp_Object readcharfun;
1417 /* We need the actual character code of this multibyte
1418 characters. */
1419 unsigned char str[MAX_MULTIBYTE_LENGTH];
1420 int len = 0;
1422 str[len++] = c;
1423 while ((c = READCHAR) >= 0xA0
1424 && len < MAX_MULTIBYTE_LENGTH)
1425 str[len++] = c;
1426 UNREAD (c);
1427 return STRING_CHAR (str, len);
1430 /* Read a \-escape sequence, assuming we already read the `\'. */
1432 static int
1433 read_escape (readcharfun, stringp)
1434 Lisp_Object readcharfun;
1435 int stringp;
1437 register int c = READCHAR;
1438 switch (c)
1440 case -1:
1441 error ("End of file");
1443 case 'a':
1444 return '\007';
1445 case 'b':
1446 return '\b';
1447 case 'd':
1448 return 0177;
1449 case 'e':
1450 return 033;
1451 case 'f':
1452 return '\f';
1453 case 'n':
1454 return '\n';
1455 case 'r':
1456 return '\r';
1457 case 't':
1458 return '\t';
1459 case 'v':
1460 return '\v';
1461 case '\n':
1462 return -1;
1463 case ' ':
1464 if (stringp)
1465 return -1;
1466 return ' ';
1468 case 'M':
1469 c = READCHAR;
1470 if (c != '-')
1471 error ("Invalid escape character syntax");
1472 c = READCHAR;
1473 if (c == '\\')
1474 c = read_escape (readcharfun, 0);
1475 return c | meta_modifier;
1477 case 'S':
1478 c = READCHAR;
1479 if (c != '-')
1480 error ("Invalid escape character syntax");
1481 c = READCHAR;
1482 if (c == '\\')
1483 c = read_escape (readcharfun, 0);
1484 return c | shift_modifier;
1486 case 'H':
1487 c = READCHAR;
1488 if (c != '-')
1489 error ("Invalid escape character syntax");
1490 c = READCHAR;
1491 if (c == '\\')
1492 c = read_escape (readcharfun, 0);
1493 return c | hyper_modifier;
1495 case 'A':
1496 c = READCHAR;
1497 if (c != '-')
1498 error ("Invalid escape character syntax");
1499 c = READCHAR;
1500 if (c == '\\')
1501 c = read_escape (readcharfun, 0);
1502 return c | alt_modifier;
1504 case 's':
1505 c = READCHAR;
1506 if (c != '-')
1507 error ("Invalid escape character syntax");
1508 c = READCHAR;
1509 if (c == '\\')
1510 c = read_escape (readcharfun, 0);
1511 return c | super_modifier;
1513 case 'C':
1514 c = READCHAR;
1515 if (c != '-')
1516 error ("Invalid escape character syntax");
1517 case '^':
1518 c = READCHAR;
1519 if (c == '\\')
1520 c = read_escape (readcharfun, 0);
1521 if ((c & ~CHAR_MODIFIER_MASK) == '?')
1522 return 0177 | (c & CHAR_MODIFIER_MASK);
1523 else if (! SINGLE_BYTE_CHAR_P ((c & ~CHAR_MODIFIER_MASK)))
1524 return c | ctrl_modifier;
1525 /* ASCII control chars are made from letters (both cases),
1526 as well as the non-letters within 0100...0137. */
1527 else if ((c & 0137) >= 0101 && (c & 0137) <= 0132)
1528 return (c & (037 | ~0177));
1529 else if ((c & 0177) >= 0100 && (c & 0177) <= 0137)
1530 return (c & (037 | ~0177));
1531 else
1532 return c | ctrl_modifier;
1534 case '0':
1535 case '1':
1536 case '2':
1537 case '3':
1538 case '4':
1539 case '5':
1540 case '6':
1541 case '7':
1542 /* An octal escape, as in ANSI C. */
1544 register int i = c - '0';
1545 register int count = 0;
1546 while (++count < 3)
1548 if ((c = READCHAR) >= '0' && c <= '7')
1550 i *= 8;
1551 i += c - '0';
1553 else
1555 UNREAD (c);
1556 break;
1559 return i;
1562 case 'x':
1563 /* A hex escape, as in ANSI C. */
1565 int i = 0;
1566 while (1)
1568 c = READCHAR;
1569 if (c >= '0' && c <= '9')
1571 i *= 16;
1572 i += c - '0';
1574 else if ((c >= 'a' && c <= 'f')
1575 || (c >= 'A' && c <= 'F'))
1577 i *= 16;
1578 if (c >= 'a' && c <= 'f')
1579 i += c - 'a' + 10;
1580 else
1581 i += c - 'A' + 10;
1583 else
1585 UNREAD (c);
1586 break;
1589 return i;
1592 default:
1593 if (BASE_LEADING_CODE_P (c))
1594 c = read_multibyte (c, readcharfun);
1595 return c;
1600 /* Read an integer in radix RADIX using READCHARFUN to read
1601 characters. RADIX must be in the interval [2..36]; if it isn't, a
1602 read error is signaled . Value is the integer read. Signals an
1603 error if encountering invalid read syntax or if RADIX is out of
1604 range. */
1606 static Lisp_Object
1607 read_integer (readcharfun, radix)
1608 Lisp_Object readcharfun;
1609 int radix;
1611 int number, ndigits, invalid_p, c, sign;
1613 if (radix < 2 || radix > 36)
1614 invalid_p = 1;
1615 else
1617 number = ndigits = invalid_p = 0;
1618 sign = 1;
1620 c = READCHAR;
1621 if (c == '-')
1623 c = READCHAR;
1624 sign = -1;
1626 else if (c == '+')
1627 c = READCHAR;
1629 while (c >= 0)
1631 int digit;
1633 if (c >= '0' && c <= '9')
1634 digit = c - '0';
1635 else if (c >= 'a' && c <= 'z')
1636 digit = c - 'a' + 10;
1637 else if (c >= 'A' && c <= 'Z')
1638 digit = c - 'A' + 10;
1639 else
1641 UNREAD (c);
1642 break;
1645 if (digit < 0 || digit >= radix)
1646 invalid_p = 1;
1648 number = radix * number + digit;
1649 ++ndigits;
1650 c = READCHAR;
1654 if (ndigits == 0 || invalid_p)
1656 char buf[50];
1657 sprintf (buf, "integer, radix %d", radix);
1658 Fsignal (Qinvalid_read_syntax, Fcons (build_string (buf), Qnil));
1661 return make_number (sign * number);
1665 /* If the next token is ')' or ']' or '.', we store that character
1666 in *PCH and the return value is not interesting. Else, we store
1667 zero in *PCH and we read and return one lisp object.
1669 FIRST_IN_LIST is nonzero if this is the first element of a list. */
1671 static Lisp_Object
1672 read1 (readcharfun, pch, first_in_list)
1673 register Lisp_Object readcharfun;
1674 int *pch;
1675 int first_in_list;
1677 register int c;
1678 int uninterned_symbol = 0;
1680 *pch = 0;
1682 retry:
1684 c = READCHAR;
1685 if (c < 0) return Fsignal (Qend_of_file, Qnil);
1687 switch (c)
1689 case '(':
1690 return read_list (0, readcharfun);
1692 case '[':
1693 return read_vector (readcharfun, 0);
1695 case ')':
1696 case ']':
1698 *pch = c;
1699 return Qnil;
1702 case '#':
1703 c = READCHAR;
1704 if (c == '^')
1706 c = READCHAR;
1707 if (c == '[')
1709 Lisp_Object tmp;
1710 tmp = read_vector (readcharfun, 0);
1711 if (XVECTOR (tmp)->size < CHAR_TABLE_STANDARD_SLOTS
1712 || XVECTOR (tmp)->size > CHAR_TABLE_STANDARD_SLOTS + 10)
1713 error ("Invalid size char-table");
1714 XSETCHAR_TABLE (tmp, XCHAR_TABLE (tmp));
1715 XCHAR_TABLE (tmp)->top = Qt;
1716 return tmp;
1718 else if (c == '^')
1720 c = READCHAR;
1721 if (c == '[')
1723 Lisp_Object tmp;
1724 tmp = read_vector (readcharfun, 0);
1725 if (XVECTOR (tmp)->size != SUB_CHAR_TABLE_STANDARD_SLOTS)
1726 error ("Invalid size char-table");
1727 XSETCHAR_TABLE (tmp, XCHAR_TABLE (tmp));
1728 XCHAR_TABLE (tmp)->top = Qnil;
1729 return tmp;
1731 Fsignal (Qinvalid_read_syntax,
1732 Fcons (make_string ("#^^", 3), Qnil));
1734 Fsignal (Qinvalid_read_syntax, Fcons (make_string ("#^", 2), Qnil));
1736 if (c == '&')
1738 Lisp_Object length;
1739 length = read1 (readcharfun, pch, first_in_list);
1740 c = READCHAR;
1741 if (c == '"')
1743 Lisp_Object tmp, val;
1744 int size_in_chars = ((XFASTINT (length) + BITS_PER_CHAR - 1)
1745 / BITS_PER_CHAR);
1747 UNREAD (c);
1748 tmp = read1 (readcharfun, pch, first_in_list);
1749 if (size_in_chars != XSTRING (tmp)->size
1750 /* We used to print 1 char too many
1751 when the number of bits was a multiple of 8.
1752 Accept such input in case it came from an old version. */
1753 && ! (XFASTINT (length)
1754 == (XSTRING (tmp)->size - 1) * BITS_PER_CHAR))
1755 Fsignal (Qinvalid_read_syntax,
1756 Fcons (make_string ("#&...", 5), Qnil));
1758 val = Fmake_bool_vector (length, Qnil);
1759 bcopy (XSTRING (tmp)->data, XBOOL_VECTOR (val)->data,
1760 size_in_chars);
1761 /* Clear the extraneous bits in the last byte. */
1762 if (XINT (length) != size_in_chars * BITS_PER_CHAR)
1763 XBOOL_VECTOR (val)->data[size_in_chars - 1]
1764 &= (1 << (XINT (length) % BITS_PER_CHAR)) - 1;
1765 return val;
1767 Fsignal (Qinvalid_read_syntax, Fcons (make_string ("#&...", 5),
1768 Qnil));
1770 if (c == '[')
1772 /* Accept compiled functions at read-time so that we don't have to
1773 build them using function calls. */
1774 Lisp_Object tmp;
1775 tmp = read_vector (readcharfun, 1);
1776 return Fmake_byte_code (XVECTOR (tmp)->size,
1777 XVECTOR (tmp)->contents);
1779 if (c == '(')
1781 Lisp_Object tmp;
1782 struct gcpro gcpro1;
1783 int ch;
1785 /* Read the string itself. */
1786 tmp = read1 (readcharfun, &ch, 0);
1787 if (ch != 0 || !STRINGP (tmp))
1788 Fsignal (Qinvalid_read_syntax, Fcons (make_string ("#", 1), Qnil));
1789 GCPRO1 (tmp);
1790 /* Read the intervals and their properties. */
1791 while (1)
1793 Lisp_Object beg, end, plist;
1795 beg = read1 (readcharfun, &ch, 0);
1796 if (ch == ')')
1797 break;
1798 if (ch == 0)
1799 end = read1 (readcharfun, &ch, 0);
1800 if (ch == 0)
1801 plist = read1 (readcharfun, &ch, 0);
1802 if (ch)
1803 Fsignal (Qinvalid_read_syntax,
1804 Fcons (build_string ("invalid string property list"),
1805 Qnil));
1806 Fset_text_properties (beg, end, plist, tmp);
1808 UNGCPRO;
1809 return tmp;
1812 /* #@NUMBER is used to skip NUMBER following characters.
1813 That's used in .elc files to skip over doc strings
1814 and function definitions. */
1815 if (c == '@')
1817 int i, nskip = 0;
1819 /* Read a decimal integer. */
1820 while ((c = READCHAR) >= 0
1821 && c >= '0' && c <= '9')
1823 nskip *= 10;
1824 nskip += c - '0';
1826 if (c >= 0)
1827 UNREAD (c);
1829 if (load_force_doc_strings && EQ (readcharfun, Qget_file_char))
1831 /* If we are supposed to force doc strings into core right now,
1832 record the last string that we skipped,
1833 and record where in the file it comes from. */
1835 /* But first exchange saved_doc_string
1836 with prev_saved_doc_string, so we save two strings. */
1838 char *temp = saved_doc_string;
1839 int temp_size = saved_doc_string_size;
1840 file_offset temp_pos = saved_doc_string_position;
1841 int temp_len = saved_doc_string_length;
1843 saved_doc_string = prev_saved_doc_string;
1844 saved_doc_string_size = prev_saved_doc_string_size;
1845 saved_doc_string_position = prev_saved_doc_string_position;
1846 saved_doc_string_length = prev_saved_doc_string_length;
1848 prev_saved_doc_string = temp;
1849 prev_saved_doc_string_size = temp_size;
1850 prev_saved_doc_string_position = temp_pos;
1851 prev_saved_doc_string_length = temp_len;
1854 if (saved_doc_string_size == 0)
1856 saved_doc_string_size = nskip + 100;
1857 saved_doc_string = (char *) xmalloc (saved_doc_string_size);
1859 if (nskip > saved_doc_string_size)
1861 saved_doc_string_size = nskip + 100;
1862 saved_doc_string = (char *) xrealloc (saved_doc_string,
1863 saved_doc_string_size);
1866 saved_doc_string_position = file_tell (instream);
1868 /* Copy that many characters into saved_doc_string. */
1869 for (i = 0; i < nskip && c >= 0; i++)
1870 saved_doc_string[i] = c = READCHAR;
1872 saved_doc_string_length = i;
1874 else
1876 /* Skip that many characters. */
1877 for (i = 0; i < nskip && c >= 0; i++)
1878 c = READCHAR;
1881 goto retry;
1883 if (c == '$')
1884 return Vload_file_name;
1885 if (c == '\'')
1886 return Fcons (Qfunction, Fcons (read0 (readcharfun), Qnil));
1887 /* #:foo is the uninterned symbol named foo. */
1888 if (c == ':')
1890 uninterned_symbol = 1;
1891 c = READCHAR;
1892 goto default_label;
1894 /* Reader forms that can reuse previously read objects. */
1895 if (c >= '0' && c <= '9')
1897 int n = 0;
1898 Lisp_Object tem;
1900 /* Read a non-negative integer. */
1901 while (c >= '0' && c <= '9')
1903 n *= 10;
1904 n += c - '0';
1905 c = READCHAR;
1907 /* #n=object returns object, but associates it with n for #n#. */
1908 if (c == '=')
1910 /* Make a placeholder for #n# to use temporarily */
1911 Lisp_Object placeholder;
1912 Lisp_Object cell;
1914 placeholder = Fcons(Qnil, Qnil);
1915 cell = Fcons (make_number (n), placeholder);
1916 read_objects = Fcons (cell, read_objects);
1918 /* Read the object itself. */
1919 tem = read0 (readcharfun);
1921 /* Now put it everywhere the placeholder was... */
1922 substitute_object_in_subtree (tem, placeholder);
1924 /* ...and #n# will use the real value from now on. */
1925 Fsetcdr (cell, tem);
1927 return tem;
1929 /* #n# returns a previously read object. */
1930 if (c == '#')
1932 tem = Fassq (make_number (n), read_objects);
1933 if (CONSP (tem))
1934 return XCDR (tem);
1935 /* Fall through to error message. */
1937 else if (c == 'r' || c == 'R')
1938 return read_integer (readcharfun, n);
1940 /* Fall through to error message. */
1942 else if (c == 'x' || c == 'X')
1943 return read_integer (readcharfun, 16);
1944 else if (c == 'o' || c == 'O')
1945 return read_integer (readcharfun, 8);
1946 else if (c == 'b' || c == 'B')
1947 return read_integer (readcharfun, 2);
1949 UNREAD (c);
1950 Fsignal (Qinvalid_read_syntax, Fcons (make_string ("#", 1), Qnil));
1952 case ';':
1953 while ((c = READCHAR) >= 0 && c != '\n');
1954 goto retry;
1956 case '\'':
1958 return Fcons (Qquote, Fcons (read0 (readcharfun), Qnil));
1961 case '`':
1962 if (first_in_list)
1963 goto default_label;
1964 else
1966 Lisp_Object value;
1968 new_backquote_flag = 1;
1969 value = read0 (readcharfun);
1970 new_backquote_flag = 0;
1972 return Fcons (Qbackquote, Fcons (value, Qnil));
1975 case ',':
1976 if (new_backquote_flag)
1978 Lisp_Object comma_type = Qnil;
1979 Lisp_Object value;
1980 int ch = READCHAR;
1982 if (ch == '@')
1983 comma_type = Qcomma_at;
1984 else if (ch == '.')
1985 comma_type = Qcomma_dot;
1986 else
1988 if (ch >= 0) UNREAD (ch);
1989 comma_type = Qcomma;
1992 new_backquote_flag = 0;
1993 value = read0 (readcharfun);
1994 new_backquote_flag = 1;
1995 return Fcons (comma_type, Fcons (value, Qnil));
1997 else
1998 goto default_label;
2000 case '?':
2002 c = READCHAR;
2003 if (c < 0) return Fsignal (Qend_of_file, Qnil);
2005 if (c == '\\')
2006 c = read_escape (readcharfun, 0);
2007 else if (BASE_LEADING_CODE_P (c))
2008 c = read_multibyte (c, readcharfun);
2010 return make_number (c);
2013 case '"':
2015 register char *p = read_buffer;
2016 register char *end = read_buffer + read_buffer_size;
2017 register int c;
2018 /* Nonzero if we saw an escape sequence specifying
2019 a multibyte character. */
2020 int force_multibyte = 0;
2021 /* Nonzero if we saw an escape sequence specifying
2022 a single-byte character. */
2023 int force_singlebyte = 0;
2024 int cancel = 0;
2025 int nchars;
2027 while ((c = READCHAR) >= 0
2028 && c != '\"')
2030 if (end - p < MAX_MULTIBYTE_LENGTH)
2032 char *new = (char *) xrealloc (read_buffer, read_buffer_size *= 2);
2033 p += new - read_buffer;
2034 read_buffer += new - read_buffer;
2035 end = read_buffer + read_buffer_size;
2038 if (c == '\\')
2040 c = read_escape (readcharfun, 1);
2042 /* C is -1 if \ newline has just been seen */
2043 if (c == -1)
2045 if (p == read_buffer)
2046 cancel = 1;
2047 continue;
2050 /* If an escape specifies a non-ASCII single-byte character,
2051 this must be a unibyte string. */
2052 if (SINGLE_BYTE_CHAR_P ((c & ~CHAR_MODIFIER_MASK))
2053 && ! ASCII_BYTE_P ((c & ~CHAR_MODIFIER_MASK)))
2054 force_singlebyte = 1;
2057 if (! SINGLE_BYTE_CHAR_P ((c & ~CHAR_MODIFIER_MASK)))
2059 /* Any modifiers for a multibyte character are invalid. */
2060 if (c & CHAR_MODIFIER_MASK)
2061 error ("Invalid modifier in string");
2062 p += CHAR_STRING (c, p);
2063 force_multibyte = 1;
2065 else
2067 /* Allow `\C- ' and `\C-?'. */
2068 if (c == (CHAR_CTL | ' '))
2069 c = 0;
2070 else if (c == (CHAR_CTL | '?'))
2071 c = 127;
2073 if (c & CHAR_SHIFT)
2075 /* Shift modifier is valid only with [A-Za-z]. */
2076 if ((c & 0377) >= 'A' && (c & 0377) <= 'Z')
2077 c &= ~CHAR_SHIFT;
2078 else if ((c & 0377) >= 'a' && (c & 0377) <= 'z')
2079 c = (c & ~CHAR_SHIFT) - ('a' - 'A');
2082 if (c & CHAR_META)
2083 /* Move the meta bit to the right place for a string. */
2084 c = (c & ~CHAR_META) | 0x80;
2085 if (c & ~0xff)
2086 error ("Invalid modifier in string");
2087 *p++ = c;
2090 if (c < 0)
2091 return Fsignal (Qend_of_file, Qnil);
2093 /* If purifying, and string starts with \ newline,
2094 return zero instead. This is for doc strings
2095 that we are really going to find in etc/DOC.nn.nn */
2096 if (!NILP (Vpurify_flag) && NILP (Vdoc_file_name) && cancel)
2097 return make_number (0);
2099 if (force_multibyte)
2100 nchars = multibyte_chars_in_text (read_buffer, p - read_buffer);
2101 else if (force_singlebyte)
2102 nchars = p - read_buffer;
2103 else if (load_convert_to_unibyte)
2105 Lisp_Object string;
2106 nchars = multibyte_chars_in_text (read_buffer, p - read_buffer);
2107 if (p - read_buffer != nchars)
2109 string = make_multibyte_string (read_buffer, nchars,
2110 p - read_buffer);
2111 return Fstring_make_unibyte (string);
2114 else if (EQ (readcharfun, Qget_file_char)
2115 || EQ (readcharfun, Qlambda))
2116 /* Nowadays, reading directly from a file
2117 is used only for compiled Emacs Lisp files,
2118 and those always use the Emacs internal encoding.
2119 Meanwhile, Qlambda is used for reading dynamic byte code
2120 (compiled with byte-compile-dynamic = t). */
2121 nchars = multibyte_chars_in_text (read_buffer, p - read_buffer);
2122 else
2123 /* In all other cases, if we read these bytes as
2124 separate characters, treat them as separate characters now. */
2125 nchars = p - read_buffer;
2127 if (read_pure)
2128 return make_pure_string (read_buffer, nchars, p - read_buffer,
2129 (force_multibyte
2130 || (p - read_buffer != nchars)));
2131 return make_specified_string (read_buffer, nchars, p - read_buffer,
2132 (force_multibyte
2133 || (p - read_buffer != nchars)));
2136 case '.':
2138 int next_char = READCHAR;
2139 UNREAD (next_char);
2141 if (next_char <= 040)
2143 *pch = c;
2144 return Qnil;
2147 /* Otherwise, we fall through! Note that the atom-reading loop
2148 below will now loop at least once, assuring that we will not
2149 try to UNREAD two characters in a row. */
2151 default:
2152 default_label:
2153 if (c <= 040) goto retry;
2155 register char *p = read_buffer;
2156 int quoted = 0;
2159 register char *end = read_buffer + read_buffer_size;
2161 while (c > 040
2162 && !(c == '\"' || c == '\'' || c == ';' || c == '?'
2163 || c == '(' || c == ')'
2164 || c == '[' || c == ']' || c == '#'
2167 if (end - p < MAX_MULTIBYTE_LENGTH)
2169 register char *new = (char *) xrealloc (read_buffer, read_buffer_size *= 2);
2170 p += new - read_buffer;
2171 read_buffer += new - read_buffer;
2172 end = read_buffer + read_buffer_size;
2174 if (c == '\\')
2176 c = READCHAR;
2177 quoted = 1;
2180 if (! SINGLE_BYTE_CHAR_P (c))
2181 p += CHAR_STRING (c, p);
2182 else
2183 *p++ = c;
2185 c = READCHAR;
2188 if (p == end)
2190 char *new = (char *) xrealloc (read_buffer, read_buffer_size *= 2);
2191 p += new - read_buffer;
2192 read_buffer += new - read_buffer;
2193 /* end = read_buffer + read_buffer_size; */
2195 *p = 0;
2196 if (c >= 0)
2197 UNREAD (c);
2200 if (!quoted && !uninterned_symbol)
2202 register char *p1;
2203 register Lisp_Object val;
2204 p1 = read_buffer;
2205 if (*p1 == '+' || *p1 == '-') p1++;
2206 /* Is it an integer? */
2207 if (p1 != p)
2209 while (p1 != p && (c = *p1) >= '0' && c <= '9') p1++;
2210 /* Integers can have trailing decimal points. */
2211 if (p1 > read_buffer && p1 < p && *p1 == '.') p1++;
2212 if (p1 == p)
2213 /* It is an integer. */
2215 if (p1[-1] == '.')
2216 p1[-1] = '\0';
2217 if (sizeof (int) == sizeof (EMACS_INT))
2218 XSETINT (val, atoi (read_buffer));
2219 else if (sizeof (long) == sizeof (EMACS_INT))
2220 XSETINT (val, atol (read_buffer));
2221 else
2222 abort ();
2223 return val;
2226 if (isfloat_string (read_buffer))
2228 /* Compute NaN and infinities using 0.0 in a variable,
2229 to cope with compilers that think they are smarter
2230 than we are. */
2231 double zero = 0.0;
2233 double value;
2235 /* Negate the value ourselves. This treats 0, NaNs,
2236 and infinity properly on IEEE floating point hosts,
2237 and works around a common bug where atof ("-0.0")
2238 drops the sign. */
2239 int negative = read_buffer[0] == '-';
2241 /* The only way p[-1] can be 'F' or 'N', after isfloat_string
2242 returns 1, is if the input ends in e+INF or e+NaN. */
2243 switch (p[-1])
2245 case 'F':
2246 value = 1.0 / zero;
2247 break;
2248 case 'N':
2249 value = zero / zero;
2250 break;
2251 default:
2252 value = atof (read_buffer + negative);
2253 break;
2256 return make_float (negative ? - value : value);
2260 if (uninterned_symbol)
2261 return make_symbol (read_buffer);
2262 else
2263 return intern (read_buffer);
2269 /* List of nodes we've seen during substitute_object_in_subtree. */
2270 static Lisp_Object seen_list;
2272 static void
2273 substitute_object_in_subtree (object, placeholder)
2274 Lisp_Object object;
2275 Lisp_Object placeholder;
2277 Lisp_Object check_object;
2279 /* We haven't seen any objects when we start. */
2280 seen_list = Qnil;
2282 /* Make all the substitutions. */
2283 check_object
2284 = substitute_object_recurse (object, placeholder, object);
2286 /* Clear seen_list because we're done with it. */
2287 seen_list = Qnil;
2289 /* The returned object here is expected to always eq the
2290 original. */
2291 if (!EQ (check_object, object))
2292 error ("Unexpected mutation error in reader");
2295 /* Feval doesn't get called from here, so no gc protection is needed. */
2296 #define SUBSTITUTE(get_val, set_val) \
2298 Lisp_Object old_value = get_val; \
2299 Lisp_Object true_value \
2300 = substitute_object_recurse (object, placeholder,\
2301 old_value); \
2303 if (!EQ (old_value, true_value)) \
2305 set_val; \
2309 static Lisp_Object
2310 substitute_object_recurse (object, placeholder, subtree)
2311 Lisp_Object object;
2312 Lisp_Object placeholder;
2313 Lisp_Object subtree;
2315 /* If we find the placeholder, return the target object. */
2316 if (EQ (placeholder, subtree))
2317 return object;
2319 /* If we've been to this node before, don't explore it again. */
2320 if (!EQ (Qnil, Fmemq (subtree, seen_list)))
2321 return subtree;
2323 /* If this node can be the entry point to a cycle, remember that
2324 we've seen it. It can only be such an entry point if it was made
2325 by #n=, which means that we can find it as a value in
2326 read_objects. */
2327 if (!EQ (Qnil, Frassq (subtree, read_objects)))
2328 seen_list = Fcons (subtree, seen_list);
2330 /* Recurse according to subtree's type.
2331 Every branch must return a Lisp_Object. */
2332 switch (XTYPE (subtree))
2334 case Lisp_Vectorlike:
2336 int i;
2337 int length = XINT (Flength(subtree));
2338 for (i = 0; i < length; i++)
2340 Lisp_Object idx = make_number (i);
2341 SUBSTITUTE (Faref (subtree, idx),
2342 Faset (subtree, idx, true_value));
2344 return subtree;
2347 case Lisp_Cons:
2349 SUBSTITUTE (Fcar_safe (subtree),
2350 Fsetcar (subtree, true_value));
2351 SUBSTITUTE (Fcdr_safe (subtree),
2352 Fsetcdr (subtree, true_value));
2353 return subtree;
2356 case Lisp_String:
2358 /* Check for text properties in each interval.
2359 substitute_in_interval contains part of the logic. */
2361 INTERVAL root_interval = XSTRING (subtree)->intervals;
2362 Lisp_Object arg = Fcons (object, placeholder);
2364 traverse_intervals (root_interval, 1, 0,
2365 &substitute_in_interval, arg);
2367 return subtree;
2370 /* Other types don't recurse any further. */
2371 default:
2372 return subtree;
2376 /* Helper function for substitute_object_recurse. */
2377 static void
2378 substitute_in_interval (interval, arg)
2379 INTERVAL interval;
2380 Lisp_Object arg;
2382 Lisp_Object object = Fcar (arg);
2383 Lisp_Object placeholder = Fcdr (arg);
2385 SUBSTITUTE(interval->plist, interval->plist = true_value);
2389 #define LEAD_INT 1
2390 #define DOT_CHAR 2
2391 #define TRAIL_INT 4
2392 #define E_CHAR 8
2393 #define EXP_INT 16
2396 isfloat_string (cp)
2397 register char *cp;
2399 register int state;
2401 char *start = cp;
2403 state = 0;
2404 if (*cp == '+' || *cp == '-')
2405 cp++;
2407 if (*cp >= '0' && *cp <= '9')
2409 state |= LEAD_INT;
2410 while (*cp >= '0' && *cp <= '9')
2411 cp++;
2413 if (*cp == '.')
2415 state |= DOT_CHAR;
2416 cp++;
2418 if (*cp >= '0' && *cp <= '9')
2420 state |= TRAIL_INT;
2421 while (*cp >= '0' && *cp <= '9')
2422 cp++;
2424 if (*cp == 'e' || *cp == 'E')
2426 state |= E_CHAR;
2427 cp++;
2428 if (*cp == '+' || *cp == '-')
2429 cp++;
2432 if (*cp >= '0' && *cp <= '9')
2434 state |= EXP_INT;
2435 while (*cp >= '0' && *cp <= '9')
2436 cp++;
2438 else if (cp == start)
2440 else if (cp[-1] == '+' && cp[0] == 'I' && cp[1] == 'N' && cp[2] == 'F')
2442 state |= EXP_INT;
2443 cp += 3;
2445 else if (cp[-1] == '+' && cp[0] == 'N' && cp[1] == 'a' && cp[2] == 'N')
2447 state |= EXP_INT;
2448 cp += 3;
2451 return (((*cp == 0) || (*cp == ' ') || (*cp == '\t') || (*cp == '\n') || (*cp == '\r') || (*cp == '\f'))
2452 && (state == (LEAD_INT|DOT_CHAR|TRAIL_INT)
2453 || state == (DOT_CHAR|TRAIL_INT)
2454 || state == (LEAD_INT|E_CHAR|EXP_INT)
2455 || state == (LEAD_INT|DOT_CHAR|TRAIL_INT|E_CHAR|EXP_INT)
2456 || state == (DOT_CHAR|TRAIL_INT|E_CHAR|EXP_INT)));
2460 static Lisp_Object
2461 read_vector (readcharfun, bytecodeflag)
2462 Lisp_Object readcharfun;
2463 int bytecodeflag;
2465 register int i;
2466 register int size;
2467 register Lisp_Object *ptr;
2468 register Lisp_Object tem, item, vector;
2469 register struct Lisp_Cons *otem;
2470 Lisp_Object len;
2472 tem = read_list (1, readcharfun);
2473 len = Flength (tem);
2474 vector = (read_pure ? make_pure_vector (XINT (len)) : Fmake_vector (len, Qnil));
2476 size = XVECTOR (vector)->size;
2477 ptr = XVECTOR (vector)->contents;
2478 for (i = 0; i < size; i++)
2480 item = Fcar (tem);
2481 /* If `load-force-doc-strings' is t when reading a lazily-loaded
2482 bytecode object, the docstring containing the bytecode and
2483 constants values must be treated as unibyte and passed to
2484 Fread, to get the actual bytecode string and constants vector. */
2485 if (bytecodeflag && load_force_doc_strings)
2487 if (i == COMPILED_BYTECODE)
2489 if (!STRINGP (item))
2490 error ("invalid byte code");
2492 /* Delay handling the bytecode slot until we know whether
2493 it is lazily-loaded (we can tell by whether the
2494 constants slot is nil). */
2495 ptr[COMPILED_CONSTANTS] = item;
2496 item = Qnil;
2498 else if (i == COMPILED_CONSTANTS)
2500 Lisp_Object bytestr = ptr[COMPILED_CONSTANTS];
2502 if (NILP (item))
2504 /* Coerce string to unibyte (like string-as-unibyte,
2505 but without generating extra garbage and
2506 guaranteeing no change in the contents). */
2507 XSTRING (bytestr)->size = STRING_BYTES (XSTRING (bytestr));
2508 SET_STRING_BYTES (XSTRING (bytestr), -1);
2510 item = Fread (bytestr);
2511 if (!CONSP (item))
2512 error ("invalid byte code");
2514 otem = XCONS (item);
2515 bytestr = XCAR (item);
2516 item = XCDR (item);
2517 free_cons (otem);
2520 /* Now handle the bytecode slot. */
2521 ptr[COMPILED_BYTECODE] = read_pure ? Fpurecopy (bytestr) : bytestr;
2524 ptr[i] = read_pure ? Fpurecopy (item) : item;
2525 otem = XCONS (tem);
2526 tem = Fcdr (tem);
2527 free_cons (otem);
2529 return vector;
2532 /* FLAG = 1 means check for ] to terminate rather than ) and .
2533 FLAG = -1 means check for starting with defun
2534 and make structure pure. */
2536 static Lisp_Object
2537 read_list (flag, readcharfun)
2538 int flag;
2539 register Lisp_Object readcharfun;
2541 /* -1 means check next element for defun,
2542 0 means don't check,
2543 1 means already checked and found defun. */
2544 int defunflag = flag < 0 ? -1 : 0;
2545 Lisp_Object val, tail;
2546 register Lisp_Object elt, tem;
2547 struct gcpro gcpro1, gcpro2;
2548 /* 0 is the normal case.
2549 1 means this list is a doc reference; replace it with the number 0.
2550 2 means this list is a doc reference; replace it with the doc string. */
2551 int doc_reference = 0;
2553 /* Initialize this to 1 if we are reading a list. */
2554 int first_in_list = flag <= 0;
2556 val = Qnil;
2557 tail = Qnil;
2559 while (1)
2561 int ch;
2562 GCPRO2 (val, tail);
2563 elt = read1 (readcharfun, &ch, first_in_list);
2564 UNGCPRO;
2566 first_in_list = 0;
2568 /* While building, if the list starts with #$, treat it specially. */
2569 if (EQ (elt, Vload_file_name)
2570 && ! NILP (elt)
2571 && !NILP (Vpurify_flag))
2573 if (NILP (Vdoc_file_name))
2574 /* We have not yet called Snarf-documentation, so assume
2575 this file is described in the DOC-MM.NN file
2576 and Snarf-documentation will fill in the right value later.
2577 For now, replace the whole list with 0. */
2578 doc_reference = 1;
2579 else
2580 /* We have already called Snarf-documentation, so make a relative
2581 file name for this file, so it can be found properly
2582 in the installed Lisp directory.
2583 We don't use Fexpand_file_name because that would make
2584 the directory absolute now. */
2585 elt = concat2 (build_string ("../lisp/"),
2586 Ffile_name_nondirectory (elt));
2588 else if (EQ (elt, Vload_file_name)
2589 && ! NILP (elt)
2590 && load_force_doc_strings)
2591 doc_reference = 2;
2593 if (ch)
2595 if (flag > 0)
2597 if (ch == ']')
2598 return val;
2599 Fsignal (Qinvalid_read_syntax,
2600 Fcons (make_string (") or . in a vector", 18), Qnil));
2602 if (ch == ')')
2603 return val;
2604 if (ch == '.')
2606 GCPRO2 (val, tail);
2607 if (!NILP (tail))
2608 XCDR (tail) = read0 (readcharfun);
2609 else
2610 val = read0 (readcharfun);
2611 read1 (readcharfun, &ch, 0);
2612 UNGCPRO;
2613 if (ch == ')')
2615 if (doc_reference == 1)
2616 return make_number (0);
2617 if (doc_reference == 2)
2619 /* Get a doc string from the file we are loading.
2620 If it's in saved_doc_string, get it from there. */
2621 int pos = XINT (XCDR (val));
2622 /* Position is negative for user variables. */
2623 if (pos < 0) pos = -pos;
2624 if (pos >= saved_doc_string_position
2625 && pos < (saved_doc_string_position
2626 + saved_doc_string_length))
2628 int start = pos - saved_doc_string_position;
2629 int from, to;
2631 /* Process quoting with ^A,
2632 and find the end of the string,
2633 which is marked with ^_ (037). */
2634 for (from = start, to = start;
2635 saved_doc_string[from] != 037;)
2637 int c = saved_doc_string[from++];
2638 if (c == 1)
2640 c = saved_doc_string[from++];
2641 if (c == 1)
2642 saved_doc_string[to++] = c;
2643 else if (c == '0')
2644 saved_doc_string[to++] = 0;
2645 else if (c == '_')
2646 saved_doc_string[to++] = 037;
2648 else
2649 saved_doc_string[to++] = c;
2652 return make_string (saved_doc_string + start,
2653 to - start);
2655 /* Look in prev_saved_doc_string the same way. */
2656 else if (pos >= prev_saved_doc_string_position
2657 && pos < (prev_saved_doc_string_position
2658 + prev_saved_doc_string_length))
2660 int start = pos - prev_saved_doc_string_position;
2661 int from, to;
2663 /* Process quoting with ^A,
2664 and find the end of the string,
2665 which is marked with ^_ (037). */
2666 for (from = start, to = start;
2667 prev_saved_doc_string[from] != 037;)
2669 int c = prev_saved_doc_string[from++];
2670 if (c == 1)
2672 c = prev_saved_doc_string[from++];
2673 if (c == 1)
2674 prev_saved_doc_string[to++] = c;
2675 else if (c == '0')
2676 prev_saved_doc_string[to++] = 0;
2677 else if (c == '_')
2678 prev_saved_doc_string[to++] = 037;
2680 else
2681 prev_saved_doc_string[to++] = c;
2684 return make_string (prev_saved_doc_string + start,
2685 to - start);
2687 else
2688 return get_doc_string (val, 0, 0);
2691 return val;
2693 return Fsignal (Qinvalid_read_syntax, Fcons (make_string (". in wrong context", 18), Qnil));
2695 return Fsignal (Qinvalid_read_syntax, Fcons (make_string ("] in a list", 11), Qnil));
2697 tem = (read_pure && flag <= 0
2698 ? pure_cons (elt, Qnil)
2699 : Fcons (elt, Qnil));
2700 if (!NILP (tail))
2701 XCDR (tail) = tem;
2702 else
2703 val = tem;
2704 tail = tem;
2705 if (defunflag < 0)
2706 defunflag = EQ (elt, Qdefun);
2707 else if (defunflag > 0)
2708 read_pure = 1;
2712 Lisp_Object Vobarray;
2713 Lisp_Object initial_obarray;
2715 /* oblookup stores the bucket number here, for the sake of Funintern. */
2717 int oblookup_last_bucket_number;
2719 static int hash_string ();
2720 Lisp_Object oblookup ();
2722 /* Get an error if OBARRAY is not an obarray.
2723 If it is one, return it. */
2725 Lisp_Object
2726 check_obarray (obarray)
2727 Lisp_Object obarray;
2729 while (!VECTORP (obarray) || XVECTOR (obarray)->size == 0)
2731 /* If Vobarray is now invalid, force it to be valid. */
2732 if (EQ (Vobarray, obarray)) Vobarray = initial_obarray;
2734 obarray = wrong_type_argument (Qvectorp, obarray);
2736 return obarray;
2739 /* Intern the C string STR: return a symbol with that name,
2740 interned in the current obarray. */
2742 Lisp_Object
2743 intern (str)
2744 char *str;
2746 Lisp_Object tem;
2747 int len = strlen (str);
2748 Lisp_Object obarray;
2750 obarray = Vobarray;
2751 if (!VECTORP (obarray) || XVECTOR (obarray)->size == 0)
2752 obarray = check_obarray (obarray);
2753 tem = oblookup (obarray, str, len, len);
2754 if (SYMBOLP (tem))
2755 return tem;
2756 return Fintern (make_string (str, len), obarray);
2759 /* Create an uninterned symbol with name STR. */
2761 Lisp_Object
2762 make_symbol (str)
2763 char *str;
2765 int len = strlen (str);
2767 return Fmake_symbol ((!NILP (Vpurify_flag)
2768 ? make_pure_string (str, len, len, 0)
2769 : make_string (str, len)));
2772 DEFUN ("intern", Fintern, Sintern, 1, 2, 0,
2773 "Return the canonical symbol whose name is STRING.\n\
2774 If there is none, one is created by this function and returned.\n\
2775 A second optional argument specifies the obarray to use;\n\
2776 it defaults to the value of `obarray'.")
2777 (string, obarray)
2778 Lisp_Object string, obarray;
2780 register Lisp_Object tem, sym, *ptr;
2782 if (NILP (obarray)) obarray = Vobarray;
2783 obarray = check_obarray (obarray);
2785 CHECK_STRING (string, 0);
2787 tem = oblookup (obarray, XSTRING (string)->data,
2788 XSTRING (string)->size,
2789 STRING_BYTES (XSTRING (string)));
2790 if (!INTEGERP (tem))
2791 return tem;
2793 if (!NILP (Vpurify_flag))
2794 string = Fpurecopy (string);
2795 sym = Fmake_symbol (string);
2796 XSYMBOL (sym)->obarray = obarray;
2798 if ((XSTRING (string)->data[0] == ':')
2799 && EQ (obarray, initial_obarray))
2800 XSYMBOL (sym)->value = sym;
2802 ptr = &XVECTOR (obarray)->contents[XINT (tem)];
2803 if (SYMBOLP (*ptr))
2804 XSYMBOL (sym)->next = XSYMBOL (*ptr);
2805 else
2806 XSYMBOL (sym)->next = 0;
2807 *ptr = sym;
2808 return sym;
2811 DEFUN ("intern-soft", Fintern_soft, Sintern_soft, 1, 2, 0,
2812 "Return the canonical symbol named NAME, or nil if none exists.\n\
2813 NAME may be a string or a symbol. If it is a symbol, that exact\n\
2814 symbol is searched for.\n\
2815 A second optional argument specifies the obarray to use;\n\
2816 it defaults to the value of `obarray'.")
2817 (name, obarray)
2818 Lisp_Object name, obarray;
2820 register Lisp_Object tem;
2821 struct Lisp_String *string;
2823 if (NILP (obarray)) obarray = Vobarray;
2824 obarray = check_obarray (obarray);
2826 if (!SYMBOLP (name))
2828 CHECK_STRING (name, 0);
2829 string = XSTRING (name);
2831 else
2832 string = XSYMBOL (name)->name;
2834 tem = oblookup (obarray, string->data, string->size, STRING_BYTES (string));
2835 if (INTEGERP (tem) || (SYMBOLP (name) && !EQ (name, tem)))
2836 return Qnil;
2837 else
2838 return tem;
2841 DEFUN ("unintern", Funintern, Sunintern, 1, 2, 0,
2842 "Delete the symbol named NAME, if any, from OBARRAY.\n\
2843 The value is t if a symbol was found and deleted, nil otherwise.\n\
2844 NAME may be a string or a symbol. If it is a symbol, that symbol\n\
2845 is deleted, if it belongs to OBARRAY--no other symbol is deleted.\n\
2846 OBARRAY defaults to the value of the variable `obarray'.")
2847 (name, obarray)
2848 Lisp_Object name, obarray;
2850 register Lisp_Object string, tem;
2851 int hash;
2853 if (NILP (obarray)) obarray = Vobarray;
2854 obarray = check_obarray (obarray);
2856 if (SYMBOLP (name))
2857 XSETSTRING (string, XSYMBOL (name)->name);
2858 else
2860 CHECK_STRING (name, 0);
2861 string = name;
2864 tem = oblookup (obarray, XSTRING (string)->data,
2865 XSTRING (string)->size,
2866 STRING_BYTES (XSTRING (string)));
2867 if (INTEGERP (tem))
2868 return Qnil;
2869 /* If arg was a symbol, don't delete anything but that symbol itself. */
2870 if (SYMBOLP (name) && !EQ (name, tem))
2871 return Qnil;
2873 XSYMBOL (tem)->obarray = Qnil;
2875 hash = oblookup_last_bucket_number;
2877 if (EQ (XVECTOR (obarray)->contents[hash], tem))
2879 if (XSYMBOL (tem)->next)
2880 XSETSYMBOL (XVECTOR (obarray)->contents[hash], XSYMBOL (tem)->next);
2881 else
2882 XSETINT (XVECTOR (obarray)->contents[hash], 0);
2884 else
2886 Lisp_Object tail, following;
2888 for (tail = XVECTOR (obarray)->contents[hash];
2889 XSYMBOL (tail)->next;
2890 tail = following)
2892 XSETSYMBOL (following, XSYMBOL (tail)->next);
2893 if (EQ (following, tem))
2895 XSYMBOL (tail)->next = XSYMBOL (following)->next;
2896 break;
2901 return Qt;
2904 /* Return the symbol in OBARRAY whose names matches the string
2905 of SIZE characters (SIZE_BYTE bytes) at PTR.
2906 If there is no such symbol in OBARRAY, return nil.
2908 Also store the bucket number in oblookup_last_bucket_number. */
2910 Lisp_Object
2911 oblookup (obarray, ptr, size, size_byte)
2912 Lisp_Object obarray;
2913 register char *ptr;
2914 int size, size_byte;
2916 int hash;
2917 int obsize;
2918 register Lisp_Object tail;
2919 Lisp_Object bucket, tem;
2921 if (!VECTORP (obarray)
2922 || (obsize = XVECTOR (obarray)->size) == 0)
2924 obarray = check_obarray (obarray);
2925 obsize = XVECTOR (obarray)->size;
2927 /* This is sometimes needed in the middle of GC. */
2928 obsize &= ~ARRAY_MARK_FLAG;
2929 /* Combining next two lines breaks VMS C 2.3. */
2930 hash = hash_string (ptr, size_byte);
2931 hash %= obsize;
2932 bucket = XVECTOR (obarray)->contents[hash];
2933 oblookup_last_bucket_number = hash;
2934 if (XFASTINT (bucket) == 0)
2936 else if (!SYMBOLP (bucket))
2937 error ("Bad data in guts of obarray"); /* Like CADR error message */
2938 else
2939 for (tail = bucket; ; XSETSYMBOL (tail, XSYMBOL (tail)->next))
2941 if (STRING_BYTES (XSYMBOL (tail)->name) == size_byte
2942 && XSYMBOL (tail)->name->size == size
2943 && !bcmp (XSYMBOL (tail)->name->data, ptr, size_byte))
2944 return tail;
2945 else if (XSYMBOL (tail)->next == 0)
2946 break;
2948 XSETINT (tem, hash);
2949 return tem;
2952 static int
2953 hash_string (ptr, len)
2954 unsigned char *ptr;
2955 int len;
2957 register unsigned char *p = ptr;
2958 register unsigned char *end = p + len;
2959 register unsigned char c;
2960 register int hash = 0;
2962 while (p != end)
2964 c = *p++;
2965 if (c >= 0140) c -= 40;
2966 hash = ((hash<<3) + (hash>>28) + c);
2968 return hash & 07777777777;
2971 void
2972 map_obarray (obarray, fn, arg)
2973 Lisp_Object obarray;
2974 void (*fn) P_ ((Lisp_Object, Lisp_Object));
2975 Lisp_Object arg;
2977 register int i;
2978 register Lisp_Object tail;
2979 CHECK_VECTOR (obarray, 1);
2980 for (i = XVECTOR (obarray)->size - 1; i >= 0; i--)
2982 tail = XVECTOR (obarray)->contents[i];
2983 if (SYMBOLP (tail))
2984 while (1)
2986 (*fn) (tail, arg);
2987 if (XSYMBOL (tail)->next == 0)
2988 break;
2989 XSETSYMBOL (tail, XSYMBOL (tail)->next);
2994 void
2995 mapatoms_1 (sym, function)
2996 Lisp_Object sym, function;
2998 call1 (function, sym);
3001 DEFUN ("mapatoms", Fmapatoms, Smapatoms, 1, 2, 0,
3002 "Call FUNCTION on every symbol in OBARRAY.\n\
3003 OBARRAY defaults to the value of `obarray'.")
3004 (function, obarray)
3005 Lisp_Object function, obarray;
3007 if (NILP (obarray)) obarray = Vobarray;
3008 obarray = check_obarray (obarray);
3010 map_obarray (obarray, mapatoms_1, function);
3011 return Qnil;
3014 #define OBARRAY_SIZE 1511
3016 void
3017 init_obarray ()
3019 Lisp_Object oblength;
3020 int hash;
3021 Lisp_Object *tem;
3023 XSETFASTINT (oblength, OBARRAY_SIZE);
3025 Qnil = Fmake_symbol (make_pure_string ("nil", 3, 3, 0));
3026 Vobarray = Fmake_vector (oblength, make_number (0));
3027 initial_obarray = Vobarray;
3028 staticpro (&initial_obarray);
3029 /* Intern nil in the obarray */
3030 XSYMBOL (Qnil)->obarray = Vobarray;
3031 /* These locals are to kludge around a pyramid compiler bug. */
3032 hash = hash_string ("nil", 3);
3033 /* Separate statement here to avoid VAXC bug. */
3034 hash %= OBARRAY_SIZE;
3035 tem = &XVECTOR (Vobarray)->contents[hash];
3036 *tem = Qnil;
3038 Qunbound = Fmake_symbol (make_pure_string ("unbound", 7, 7, 0));
3039 XSYMBOL (Qnil)->function = Qunbound;
3040 XSYMBOL (Qunbound)->value = Qunbound;
3041 XSYMBOL (Qunbound)->function = Qunbound;
3043 Qt = intern ("t");
3044 XSYMBOL (Qnil)->value = Qnil;
3045 XSYMBOL (Qnil)->plist = Qnil;
3046 XSYMBOL (Qt)->value = Qt;
3048 /* Qt is correct even if CANNOT_DUMP. loadup.el will set to nil at end. */
3049 Vpurify_flag = Qt;
3051 Qvariable_documentation = intern ("variable-documentation");
3052 staticpro (&Qvariable_documentation);
3054 read_buffer_size = 100 + MAX_MULTIBYTE_LENGTH;
3055 read_buffer = (char *) xmalloc (read_buffer_size);
3058 void
3059 defsubr (sname)
3060 struct Lisp_Subr *sname;
3062 Lisp_Object sym;
3063 sym = intern (sname->symbol_name);
3064 XSETSUBR (XSYMBOL (sym)->function, sname);
3067 #ifdef NOTDEF /* use fset in subr.el now */
3068 void
3069 defalias (sname, string)
3070 struct Lisp_Subr *sname;
3071 char *string;
3073 Lisp_Object sym;
3074 sym = intern (string);
3075 XSETSUBR (XSYMBOL (sym)->function, sname);
3077 #endif /* NOTDEF */
3079 /* Define an "integer variable"; a symbol whose value is forwarded
3080 to a C variable of type int. Sample call: */
3081 /* DEFVAR_INT ("indent-tabs-mode", &indent_tabs_mode, "Documentation"); */
3082 void
3083 defvar_int (namestring, address)
3084 char *namestring;
3085 int *address;
3087 Lisp_Object sym, val;
3088 sym = intern (namestring);
3089 val = allocate_misc ();
3090 XMISCTYPE (val) = Lisp_Misc_Intfwd;
3091 XINTFWD (val)->intvar = address;
3092 XSYMBOL (sym)->value = val;
3095 /* Similar but define a variable whose value is T if address contains 1,
3096 NIL if address contains 0 */
3097 void
3098 defvar_bool (namestring, address)
3099 char *namestring;
3100 int *address;
3102 Lisp_Object sym, val;
3103 sym = intern (namestring);
3104 val = allocate_misc ();
3105 XMISCTYPE (val) = Lisp_Misc_Boolfwd;
3106 XBOOLFWD (val)->boolvar = address;
3107 XSYMBOL (sym)->value = val;
3108 Vbyte_boolean_vars = Fcons (sym, Vbyte_boolean_vars);
3111 /* Similar but define a variable whose value is the Lisp Object stored
3112 at address. Two versions: with and without gc-marking of the C
3113 variable. The nopro version is used when that variable will be
3114 gc-marked for some other reason, since marking the same slot twice
3115 can cause trouble with strings. */
3116 void
3117 defvar_lisp_nopro (namestring, address)
3118 char *namestring;
3119 Lisp_Object *address;
3121 Lisp_Object sym, val;
3122 sym = intern (namestring);
3123 val = allocate_misc ();
3124 XMISCTYPE (val) = Lisp_Misc_Objfwd;
3125 XOBJFWD (val)->objvar = address;
3126 XSYMBOL (sym)->value = val;
3129 void
3130 defvar_lisp (namestring, address)
3131 char *namestring;
3132 Lisp_Object *address;
3134 defvar_lisp_nopro (namestring, address);
3135 staticpro (address);
3138 /* Similar but define a variable whose value is the Lisp Object stored in
3139 the current buffer. address is the address of the slot in the buffer
3140 that is current now. */
3142 void
3143 defvar_per_buffer (namestring, address, type, doc)
3144 char *namestring;
3145 Lisp_Object *address;
3146 Lisp_Object type;
3147 char *doc;
3149 Lisp_Object sym, val;
3150 int offset;
3151 extern struct buffer buffer_local_symbols;
3153 sym = intern (namestring);
3154 val = allocate_misc ();
3155 offset = (char *)address - (char *)current_buffer;
3157 XMISCTYPE (val) = Lisp_Misc_Buffer_Objfwd;
3158 XBUFFER_OBJFWD (val)->offset = offset;
3159 XSYMBOL (sym)->value = val;
3160 PER_BUFFER_SYMBOL (offset) = sym;
3161 PER_BUFFER_TYPE (offset) = type;
3163 if (PER_BUFFER_IDX (offset) == 0)
3164 /* Did a DEFVAR_PER_BUFFER without initializing the corresponding
3165 slot of buffer_local_flags */
3166 abort ();
3170 /* Similar but define a variable whose value is the Lisp Object stored
3171 at a particular offset in the current kboard object. */
3173 void
3174 defvar_kboard (namestring, offset)
3175 char *namestring;
3176 int offset;
3178 Lisp_Object sym, val;
3179 sym = intern (namestring);
3180 val = allocate_misc ();
3181 XMISCTYPE (val) = Lisp_Misc_Kboard_Objfwd;
3182 XKBOARD_OBJFWD (val)->offset = offset;
3183 XSYMBOL (sym)->value = val;
3186 /* Record the value of load-path used at the start of dumping
3187 so we can see if the site changed it later during dumping. */
3188 static Lisp_Object dump_path;
3190 void
3191 init_lread ()
3193 char *normal;
3194 int turn_off_warning = 0;
3196 /* Compute the default load-path. */
3197 #ifdef CANNOT_DUMP
3198 normal = PATH_LOADSEARCH;
3199 Vload_path = decode_env_path (0, normal);
3200 #else
3201 if (NILP (Vpurify_flag))
3202 normal = PATH_LOADSEARCH;
3203 else
3204 normal = PATH_DUMPLOADSEARCH;
3206 /* In a dumped Emacs, we normally have to reset the value of
3207 Vload_path from PATH_LOADSEARCH, since the value that was dumped
3208 uses ../lisp, instead of the path of the installed elisp
3209 libraries. However, if it appears that Vload_path was changed
3210 from the default before dumping, don't override that value. */
3211 if (initialized)
3213 if (! NILP (Fequal (dump_path, Vload_path)))
3215 Vload_path = decode_env_path (0, normal);
3216 if (!NILP (Vinstallation_directory))
3218 /* Add to the path the lisp subdir of the
3219 installation dir, if it exists. */
3220 Lisp_Object tem, tem1;
3221 tem = Fexpand_file_name (build_string ("lisp"),
3222 Vinstallation_directory);
3223 tem1 = Ffile_exists_p (tem);
3224 if (!NILP (tem1))
3226 if (NILP (Fmember (tem, Vload_path)))
3228 turn_off_warning = 1;
3229 Vload_path = nconc2 (Vload_path, Fcons (tem, Qnil));
3232 else
3233 /* That dir doesn't exist, so add the build-time
3234 Lisp dirs instead. */
3235 Vload_path = nconc2 (Vload_path, dump_path);
3237 /* Add leim under the installation dir, if it exists. */
3238 tem = Fexpand_file_name (build_string ("leim"),
3239 Vinstallation_directory);
3240 tem1 = Ffile_exists_p (tem);
3241 if (!NILP (tem1))
3243 if (NILP (Fmember (tem, Vload_path)))
3244 Vload_path = nconc2 (Vload_path, Fcons (tem, Qnil));
3247 /* Add site-list under the installation dir, if it exists. */
3248 tem = Fexpand_file_name (build_string ("site-lisp"),
3249 Vinstallation_directory);
3250 tem1 = Ffile_exists_p (tem);
3251 if (!NILP (tem1))
3253 if (NILP (Fmember (tem, Vload_path)))
3254 Vload_path = nconc2 (Vload_path, Fcons (tem, Qnil));
3257 /* If Emacs was not built in the source directory,
3258 and it is run from where it was built, add to load-path
3259 the lisp, leim and site-lisp dirs under that directory. */
3261 if (NILP (Fequal (Vinstallation_directory, Vsource_directory)))
3263 Lisp_Object tem2;
3265 tem = Fexpand_file_name (build_string ("src/Makefile"),
3266 Vinstallation_directory);
3267 tem1 = Ffile_exists_p (tem);
3269 /* Don't be fooled if they moved the entire source tree
3270 AFTER dumping Emacs. If the build directory is indeed
3271 different from the source dir, src/Makefile.in and
3272 src/Makefile will not be found together. */
3273 tem = Fexpand_file_name (build_string ("src/Makefile.in"),
3274 Vinstallation_directory);
3275 tem2 = Ffile_exists_p (tem);
3276 if (!NILP (tem1) && NILP (tem2))
3278 tem = Fexpand_file_name (build_string ("lisp"),
3279 Vsource_directory);
3281 if (NILP (Fmember (tem, Vload_path)))
3282 Vload_path = nconc2 (Vload_path, Fcons (tem, Qnil));
3284 tem = Fexpand_file_name (build_string ("leim"),
3285 Vsource_directory);
3287 if (NILP (Fmember (tem, Vload_path)))
3288 Vload_path = nconc2 (Vload_path, Fcons (tem, Qnil));
3290 tem = Fexpand_file_name (build_string ("site-lisp"),
3291 Vsource_directory);
3293 if (NILP (Fmember (tem, Vload_path)))
3294 Vload_path = nconc2 (Vload_path, Fcons (tem, Qnil));
3300 else
3302 /* NORMAL refers to the lisp dir in the source directory. */
3303 /* We used to add ../lisp at the front here, but
3304 that caused trouble because it was copied from dump_path
3305 into Vload_path, aboe, when Vinstallation_directory was non-nil.
3306 It should be unnecessary. */
3307 Vload_path = decode_env_path (0, normal);
3308 dump_path = Vload_path;
3310 #endif
3312 #ifndef WINDOWSNT
3313 /* When Emacs is invoked over network shares on NT, PATH_LOADSEARCH is
3314 almost never correct, thereby causing a warning to be printed out that
3315 confuses users. Since PATH_LOADSEARCH is always overridden by the
3316 EMACSLOADPATH environment variable below, disable the warning on NT. */
3318 /* Warn if dirs in the *standard* path don't exist. */
3319 if (!turn_off_warning)
3321 Lisp_Object path_tail;
3323 for (path_tail = Vload_path;
3324 !NILP (path_tail);
3325 path_tail = XCDR (path_tail))
3327 Lisp_Object dirfile;
3328 dirfile = Fcar (path_tail);
3329 if (STRINGP (dirfile))
3331 dirfile = Fdirectory_file_name (dirfile);
3332 if (access (XSTRING (dirfile)->data, 0) < 0)
3333 dir_warning ("Warning: Lisp directory `%s' does not exist.\n",
3334 XCAR (path_tail));
3338 #endif /* WINDOWSNT */
3340 /* If the EMACSLOADPATH environment variable is set, use its value.
3341 This doesn't apply if we're dumping. */
3342 #ifndef CANNOT_DUMP
3343 if (NILP (Vpurify_flag)
3344 && egetenv ("EMACSLOADPATH"))
3345 #endif
3346 Vload_path = decode_env_path ("EMACSLOADPATH", normal);
3348 Vvalues = Qnil;
3350 load_in_progress = 0;
3351 Vload_file_name = Qnil;
3353 load_descriptor_list = Qnil;
3355 Vstandard_input = Qt;
3358 /* Print a warning, using format string FORMAT, that directory DIRNAME
3359 does not exist. Print it on stderr and put it in *Message*. */
3361 void
3362 dir_warning (format, dirname)
3363 char *format;
3364 Lisp_Object dirname;
3366 char *buffer
3367 = (char *) alloca (XSTRING (dirname)->size + strlen (format) + 5);
3369 fprintf (stderr, format, XSTRING (dirname)->data);
3370 sprintf (buffer, format, XSTRING (dirname)->data);
3371 /* Don't log the warning before we've initialized!! */
3372 if (initialized)
3373 message_dolog (buffer, strlen (buffer), 0, STRING_MULTIBYTE (dirname));
3376 void
3377 syms_of_lread ()
3379 defsubr (&Sread);
3380 defsubr (&Sread_from_string);
3381 defsubr (&Sintern);
3382 defsubr (&Sintern_soft);
3383 defsubr (&Sunintern);
3384 defsubr (&Sload);
3385 defsubr (&Seval_buffer);
3386 defsubr (&Seval_region);
3387 defsubr (&Sread_char);
3388 defsubr (&Sread_char_exclusive);
3389 defsubr (&Sread_event);
3390 defsubr (&Sget_file_char);
3391 defsubr (&Smapatoms);
3393 DEFVAR_LISP ("obarray", &Vobarray,
3394 "Symbol table for use by `intern' and `read'.\n\
3395 It is a vector whose length ought to be prime for best results.\n\
3396 The vector's contents don't make sense if examined from Lisp programs;\n\
3397 to find all the symbols in an obarray, use `mapatoms'.");
3399 DEFVAR_LISP ("values", &Vvalues,
3400 "List of values of all expressions which were read, evaluated and printed.\n\
3401 Order is reverse chronological.");
3403 DEFVAR_LISP ("standard-input", &Vstandard_input,
3404 "Stream for read to get input from.\n\
3405 See documentation of `read' for possible values.");
3406 Vstandard_input = Qt;
3408 DEFVAR_LISP ("load-path", &Vload_path,
3409 "*List of directories to search for files to load.\n\
3410 Each element is a string (directory name) or nil (try default directory).\n\
3411 Initialized based on EMACSLOADPATH environment variable, if any,\n\
3412 otherwise to default specified by file `epaths.h' when Emacs was built.");
3414 DEFVAR_BOOL ("load-in-progress", &load_in_progress,
3415 "Non-nil iff inside of `load'.");
3417 DEFVAR_LISP ("after-load-alist", &Vafter_load_alist,
3418 "An alist of expressions to be evalled when particular files are loaded.\n\
3419 Each element looks like (FILENAME FORMS...).\n\
3420 When `load' is run and the file-name argument is FILENAME,\n\
3421 the FORMS in the corresponding element are executed at the end of loading.\n\n\
3422 FILENAME must match exactly! Normally FILENAME is the name of a library,\n\
3423 with no directory specified, since that is how `load' is normally called.\n\
3424 An error in FORMS does not undo the load,\n\
3425 but does prevent execution of the rest of the FORMS.");
3426 Vafter_load_alist = Qnil;
3428 DEFVAR_LISP ("load-history", &Vload_history,
3429 "Alist mapping source file names to symbols and features.\n\
3430 Each alist element is a list that starts with a file name,\n\
3431 except for one element (optional) that starts with nil and describes\n\
3432 definitions evaluated from buffers not visiting files.\n\
3433 The remaining elements of each list are symbols defined as functions\n\
3434 or variables, and cons cells `(provide . FEATURE)', `(require . FEATURE)',\n\
3435 and `(autoload . SYMBOL)'.");
3436 Vload_history = Qnil;
3438 DEFVAR_LISP ("load-file-name", &Vload_file_name,
3439 "Full name of file being loaded by `load'.");
3440 Vload_file_name = Qnil;
3442 DEFVAR_LISP ("user-init-file", &Vuser_init_file,
3443 "File name, including directory, of user's initialization file.\n\
3444 If the file loaded had extension `.elc' and there was a corresponding `.el'\n\
3445 file, this variable contains the name of the .el file, suitable for use\n\
3446 by functions like `custom-save-all' which edit the init file.");
3447 Vuser_init_file = Qnil;
3449 DEFVAR_LISP ("current-load-list", &Vcurrent_load_list,
3450 "Used for internal purposes by `load'.");
3451 Vcurrent_load_list = Qnil;
3453 DEFVAR_LISP ("load-read-function", &Vload_read_function,
3454 "Function used by `load' and `eval-region' for reading expressions.\n\
3455 The default is nil, which means use the function `read'.");
3456 Vload_read_function = Qnil;
3458 DEFVAR_LISP ("load-source-file-function", &Vload_source_file_function,
3459 "Function called in `load' for loading an Emacs lisp source file.\n\
3460 This function is for doing code conversion before reading the source file.\n\
3461 If nil, loading is done without any code conversion.\n\
3462 Arguments are FULLNAME, FILE, NOERROR, NOMESSAGE, where\n\
3463 FULLNAME is the full name of FILE.\n\
3464 See `load' for the meaning of the remaining arguments.");
3465 Vload_source_file_function = Qnil;
3467 DEFVAR_BOOL ("load-force-doc-strings", &load_force_doc_strings,
3468 "Non-nil means `load' should force-load all dynamic doc strings.\n\
3469 This is useful when the file being loaded is a temporary copy.");
3470 load_force_doc_strings = 0;
3472 DEFVAR_BOOL ("load-convert-to-unibyte", &load_convert_to_unibyte,
3473 "Non-nil means `read' converts strings to unibyte whenever possible.\n\
3474 This is normally bound by `load' and `eval-buffer' to control `read',\n\
3475 and is not meant for users to change.");
3476 load_convert_to_unibyte = 0;
3478 DEFVAR_LISP ("source-directory", &Vsource_directory,
3479 "Directory in which Emacs sources were found when Emacs was built.\n\
3480 You cannot count on them to still be there!");
3481 Vsource_directory
3482 = Fexpand_file_name (build_string ("../"),
3483 Fcar (decode_env_path (0, PATH_DUMPLOADSEARCH)));
3485 DEFVAR_LISP ("preloaded-file-list", &Vpreloaded_file_list,
3486 "List of files that were preloaded (when dumping Emacs).");
3487 Vpreloaded_file_list = Qnil;
3489 DEFVAR_LISP ("byte-boolean-vars", &Vbyte_boolean_vars,
3490 "List of all DEFVAR_BOOL variables, used by the byte code optimizer.");
3491 Vbyte_boolean_vars = Qnil;
3493 DEFVAR_BOOL ("load-dangerous-libraries", &load_dangerous_libraries,
3494 "Non-nil means load dangerous compiled Lisp files.\n\
3495 Some versions of XEmacs use different byte codes than Emacs. These\n\
3496 incompatible byte codes can make Emacs crash when it tries to execute\n\
3497 them.");
3498 load_dangerous_libraries = 0;
3500 Vbytecomp_version_regexp = build_string ("^;;;.in Emacs version");
3501 staticpro (&Vbytecomp_version_regexp);
3503 /* Vsource_directory was initialized in init_lread. */
3505 load_descriptor_list = Qnil;
3506 staticpro (&load_descriptor_list);
3508 Qcurrent_load_list = intern ("current-load-list");
3509 staticpro (&Qcurrent_load_list);
3511 Qstandard_input = intern ("standard-input");
3512 staticpro (&Qstandard_input);
3514 Qread_char = intern ("read-char");
3515 staticpro (&Qread_char);
3517 Qget_file_char = intern ("get-file-char");
3518 staticpro (&Qget_file_char);
3520 Qbackquote = intern ("`");
3521 staticpro (&Qbackquote);
3522 Qcomma = intern (",");
3523 staticpro (&Qcomma);
3524 Qcomma_at = intern (",@");
3525 staticpro (&Qcomma_at);
3526 Qcomma_dot = intern (",.");
3527 staticpro (&Qcomma_dot);
3529 Qinhibit_file_name_operation = intern ("inhibit-file-name-operation");
3530 staticpro (&Qinhibit_file_name_operation);
3532 Qascii_character = intern ("ascii-character");
3533 staticpro (&Qascii_character);
3535 Qfunction = intern ("function");
3536 staticpro (&Qfunction);
3538 Qload = intern ("load");
3539 staticpro (&Qload);
3541 Qload_file_name = intern ("load-file-name");
3542 staticpro (&Qload_file_name);
3544 staticpro (&dump_path);
3546 staticpro (&read_objects);
3547 read_objects = Qnil;
3548 staticpro (&seen_list);