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)
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. */
24 #define _XOPEN_SOURCE 500 /* for Unix 98 ftello on GNU */
25 #define __EXTENSIONS__ /* Keep Solaris 2.6 happy with the
26 above, else things we need are hidden. */
28 #include <sys/types.h>
33 #include "intervals.h"
41 #include "termhooks.h"
45 #include <sys/inode.h>
50 #include <unistd.h> /* to get X_OK */
63 #ifdef LISP_FLOAT_TYPE
65 #endif /* LISP_FLOAT_TYPE */
69 #endif /* HAVE_SETLOCALE */
76 #define file_offset off_t
77 #define file_tell ftello
79 #define file_offset long
80 #define file_tell ftell
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' */
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)
197 readchar (readcharfun
)
198 Lisp_Object readcharfun
;
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
))
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
);
232 c
= BUF_FETCH_BYTE (inbuffer
, pt_byte
);
235 SET_BUF_PT_BOTH (inbuffer
, BUF_PT (inbuffer
) + 1, pt_byte
);
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
))
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
);
268 c
= BUF_FETCH_BYTE (inbuffer
, bytepos
);
272 XMARKER (readcharfun
)->bytepos
= bytepos
;
273 XMARKER (readcharfun
)->charpos
++;
278 if (EQ (readcharfun
, Qlambda
))
279 return read_bytecode_char (0);
281 if (EQ (readcharfun
, Qget_file_char
))
285 /* Interrupted reads have been observed while reading over the network */
286 while (c
== EOF
&& ferror (instream
) && errno
== EINTR
)
295 if (STRINGP (readcharfun
))
297 if (read_from_string_index
>= read_from_string_limit
)
299 else if (STRING_MULTIBYTE (readcharfun
))
300 FETCH_STRING_CHAR_ADVANCE (c
, readcharfun
,
301 read_from_string_index
,
302 read_from_string_index_byte
);
304 c
= XSTRING (readcharfun
)->data
[read_from_string_index
++];
309 tem
= call0 (readcharfun
);
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. */
320 unreadchar (readcharfun
, c
)
321 Lisp_Object readcharfun
;
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)
338 if (! NILP (b
->enable_multibyte_characters
))
339 BUF_DEC_POS (b
, 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)
355 XMARKER (readcharfun
)->charpos
--;
356 if (! NILP (b
->enable_multibyte_characters
))
357 BUF_DEC_POS (b
, 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
);
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
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
403 If INPUT_METHOD is nonzero, we invoke the current input method
404 if the character warrants that. */
407 read_filtered_event (no_switch_frame
, ascii_required
, error_nonascii
,
409 int no_switch_frame
, ascii_required
, error_nonascii
, input_method
;
412 return make_number (getchar ());
414 register Lisp_Object val
, delayed_switch_frame
;
416 delayed_switch_frame
= Qnil
;
418 /* Read until we get an acceptable event. */
420 val
= read_char (0, 0, 0,
421 (input_method
? Qnil
: Qt
),
427 /* switch-frame events are put off until after the next ASCII
428 character. This is better than signaling an error just because
429 the last characters were typed to a separate minibuffer frame,
430 for example. Eventually, some code which can deal with
431 switch-frame events will read it and process it. */
433 && EVENT_HAS_PARAMETERS (val
)
434 && EQ (EVENT_HEAD (val
), Qswitch_frame
))
436 delayed_switch_frame
= val
;
442 /* Convert certain symbols to their ASCII equivalents. */
445 Lisp_Object tem
, tem1
;
446 tem
= Fget (val
, Qevent_symbol_element_mask
);
449 tem1
= Fget (Fcar (tem
), Qascii_character
);
450 /* Merge this symbol's modifier bits
451 with the ASCII equivalent of its basic code. */
453 XSETFASTINT (val
, XINT (tem1
) | XINT (Fcar (Fcdr (tem
))));
457 /* If we don't have a character now, deal with it appropriately. */
462 Vunread_command_events
= Fcons (val
, Qnil
);
463 error ("Non-character input-event");
470 if (! NILP (delayed_switch_frame
))
471 unread_switch_frame
= delayed_switch_frame
;
477 DEFUN ("read-char", Fread_char
, Sread_char
, 0, 2, 0,
478 "Read a character from the command input (keyboard or macro).\n\
479 It is returned as a number.\n\
480 If the user generates an event which is not a character (i.e. a mouse\n\
481 click or function key event), `read-char' signals an error. As an\n\
482 exception, switch-frame events are put off until non-ASCII events can\n\
484 If you want to read non-character events, or ignore them, call\n\
485 `read-event' or `read-char-exclusive' instead.\n\
487 If the optional argument PROMPT is non-nil, display that as a prompt.\n\
488 If the optional argument INHERIT-INPUT-METHOD is non-nil and some\n\
489 input method is turned on in the current buffer, that input method\n\
490 is used for reading a character.")
491 (prompt
, inherit_input_method
)
492 Lisp_Object prompt
, inherit_input_method
;
495 message_with_string ("%s", prompt
, 0);
496 return read_filtered_event (1, 1, 1, ! NILP (inherit_input_method
));
499 DEFUN ("read-event", Fread_event
, Sread_event
, 0, 2, 0,
500 "Read an event object from the input stream.\n\
501 If the optional argument PROMPT is non-nil, display that as a prompt.\n\
502 If the optional argument INHERIT-INPUT-METHOD is non-nil and some\n\
503 input method is turned on in the current buffer, that input method\n\
504 is used for reading a character.")
505 (prompt
, inherit_input_method
)
506 Lisp_Object prompt
, inherit_input_method
;
509 message_with_string ("%s", prompt
, 0);
510 return read_filtered_event (0, 0, 0, ! NILP (inherit_input_method
));
513 DEFUN ("read-char-exclusive", Fread_char_exclusive
, Sread_char_exclusive
, 0, 2, 0,
514 "Read a character from the command input (keyboard or macro).\n\
515 It is returned as a number. Non-character events are ignored.\n\
517 If the optional argument PROMPT is non-nil, display that as a prompt.\n\
518 If the optional argument INHERIT-INPUT-METHOD is non-nil and some\n\
519 input method is turned on in the current buffer, that input method\n\
520 is used for reading a character.")
521 (prompt
, inherit_input_method
)
522 Lisp_Object prompt
, inherit_input_method
;
525 message_with_string ("%s", prompt
, 0);
526 return read_filtered_event (1, 1, 0, ! NILP (inherit_input_method
));
529 DEFUN ("get-file-char", Fget_file_char
, Sget_file_char
, 0, 0, 0,
530 "Don't use this yourself.")
533 register Lisp_Object val
;
534 XSETINT (val
, getc (instream
));
538 static void readevalloop ();
539 static Lisp_Object
load_unwind ();
540 static Lisp_Object
load_descriptor_unwind ();
542 DEFUN ("load", Fload
, Sload
, 1, 5, 0,
543 "Execute a file of Lisp code named FILE.\n\
544 First try FILE with `.elc' appended, then try with `.el',\n\
545 then try FILE unmodified.\n\
546 This function searches the directories in `load-path'.\n\
547 If optional second arg NOERROR is non-nil,\n\
548 report no error if FILE doesn't exist.\n\
549 Print messages at start and end of loading unless\n\
550 optional third arg NOMESSAGE is non-nil.\n\
551 If optional fourth arg NOSUFFIX is non-nil, don't try adding\n\
552 suffixes `.elc' or `.el' to the specified name FILE.\n\
553 If optional fifth arg MUST-SUFFIX is non-nil, insist on\n\
554 the suffix `.elc' or `.el'; don't accept just FILE unless\n\
555 it ends in one of those suffixes or includes a directory name.\n\
556 Return t if file exists.")
557 (file
, noerror
, nomessage
, nosuffix
, must_suffix
)
558 Lisp_Object file
, noerror
, nomessage
, nosuffix
, must_suffix
;
560 register FILE *stream
;
561 register int fd
= -1;
562 register Lisp_Object lispstream
;
563 int count
= specpdl_ptr
- specpdl
;
567 /* 1 means we printed the ".el is newer" message. */
569 /* 1 means we are loading a compiled file. */
577 CHECK_STRING (file
, 0);
579 /* If file name is magic, call the handler. */
580 handler
= Ffind_file_name_handler (file
, Qload
);
582 return call5 (handler
, Qload
, file
, noerror
, nomessage
, nosuffix
);
584 /* Do this after the handler to avoid
585 the need to gcpro noerror, nomessage and nosuffix.
586 (Below here, we care only whether they are nil or not.) */
587 file
= Fsubstitute_in_file_name (file
);
589 /* Avoid weird lossage with null string as arg,
590 since it would try to load a directory as a Lisp file */
591 if (XSTRING (file
)->size
> 0)
593 int size
= STRING_BYTES (XSTRING (file
));
597 if (! NILP (must_suffix
))
599 /* Don't insist on adding a suffix if FILE already ends with one. */
601 && !strcmp (XSTRING (file
)->data
+ size
- 3, ".el"))
604 && !strcmp (XSTRING (file
)->data
+ size
- 4, ".elc"))
606 /* Don't insist on adding a suffix
607 if the argument includes a directory name. */
608 else if (! NILP (Ffile_name_directory (file
)))
612 fd
= openp (Vload_path
, file
,
613 (!NILP (nosuffix
) ? ""
614 : ! NILP (must_suffix
) ? ".elc.gz:.elc:.el.gz:.el"
615 : ".elc:.elc.gz:.el.gz:.el:"),
624 Fsignal (Qfile_error
, Fcons (build_string ("Cannot open load file"),
625 Fcons (file
, Qnil
)));
630 if (EQ (Qt
, Vuser_init_file
))
631 Vuser_init_file
= found
;
633 /* If FD is 0, that means openp found a magic file. */
636 if (NILP (Fequal (found
, file
)))
637 /* If FOUND is a different file name from FILE,
638 find its handler even if we have already inhibited
639 the `load' operation on FILE. */
640 handler
= Ffind_file_name_handler (found
, Qt
);
642 handler
= Ffind_file_name_handler (found
, Qload
);
643 if (! NILP (handler
))
644 return call5 (handler
, Qload
, found
, noerror
, nomessage
, Qt
);
647 /* Load .elc files directly, but not when they are
648 remote and have no handler! */
649 if (!bcmp (&(XSTRING (found
)->data
[STRING_BYTES (XSTRING (found
)) - 4]),
661 stat ((char *)XSTRING (found
)->data
, &s1
);
662 XSTRING (found
)->data
[STRING_BYTES (XSTRING (found
)) - 1] = 0;
663 result
= stat ((char *)XSTRING (found
)->data
, &s2
);
664 if (result
>= 0 && (unsigned) s1
.st_mtime
< (unsigned) s2
.st_mtime
)
666 /* Make the progress messages mention that source is newer. */
669 /* If we won't print another message, mention this anyway. */
670 if (! NILP (nomessage
))
671 message_with_string ("Source file `%s' newer than byte-compiled file",
674 XSTRING (found
)->data
[STRING_BYTES (XSTRING (found
)) - 1] = 'c';
678 /* We are loading a source file (*.el). */
679 if (!NILP (Vload_source_file_function
))
683 return call4 (Vload_source_file_function
, found
, file
,
684 NILP (noerror
) ? Qnil
: Qt
,
685 NILP (nomessage
) ? Qnil
: Qt
);
691 stream
= fopen ((char *) XSTRING (found
)->data
, fmode
);
692 #else /* not WINDOWSNT */
693 stream
= fdopen (fd
, fmode
);
694 #endif /* not WINDOWSNT */
698 error ("Failure to create stdio stream for %s", XSTRING (file
)->data
);
701 if (! NILP (Vpurify_flag
))
702 Vpreloaded_file_list
= Fcons (file
, Vpreloaded_file_list
);
704 if (NILP (nomessage
))
707 message_with_string ("Loading %s (source)...", file
, 1);
709 message_with_string ("Loading %s (compiled; note, source file is newer)...",
711 else /* The typical case; compiled file newer than source file. */
712 message_with_string ("Loading %s...", file
, 1);
716 lispstream
= Fcons (Qnil
, Qnil
);
717 XSETFASTINT (XCAR (lispstream
), (EMACS_UINT
)stream
>> 16);
718 XSETFASTINT (XCDR (lispstream
), (EMACS_UINT
)stream
& 0xffff);
719 record_unwind_protect (load_unwind
, lispstream
);
720 record_unwind_protect (load_descriptor_unwind
, load_descriptor_list
);
721 specbind (Qload_file_name
, found
);
722 specbind (Qinhibit_file_name_operation
, Qnil
);
724 = Fcons (make_number (fileno (stream
)), load_descriptor_list
);
726 readevalloop (Qget_file_char
, stream
, file
, Feval
, 0, Qnil
, Qnil
);
727 unbind_to (count
, Qnil
);
729 /* Run any load-hooks for this file. */
730 temp
= Fassoc (file
, Vafter_load_alist
);
732 Fprogn (Fcdr (temp
));
735 if (saved_doc_string
)
736 free (saved_doc_string
);
737 saved_doc_string
= 0;
738 saved_doc_string_size
= 0;
740 if (prev_saved_doc_string
)
741 free (prev_saved_doc_string
);
742 prev_saved_doc_string
= 0;
743 prev_saved_doc_string_size
= 0;
745 if (!noninteractive
&& NILP (nomessage
))
748 message_with_string ("Loading %s (source)...done", file
, 1);
750 message_with_string ("Loading %s (compiled; note, source file is newer)...done",
752 else /* The typical case; compiled file newer than source file. */
753 message_with_string ("Loading %s...done", file
, 1);
759 load_unwind (stream
) /* used as unwind-protect function in load */
762 fclose ((FILE *) (XFASTINT (XCAR (stream
)) << 16
763 | XFASTINT (XCDR (stream
))));
764 if (--load_in_progress
< 0) load_in_progress
= 0;
769 load_descriptor_unwind (oldlist
)
772 load_descriptor_list
= oldlist
;
776 /* Close all descriptors in use for Floads.
777 This is used when starting a subprocess. */
784 for (tail
= load_descriptor_list
; !NILP (tail
); tail
= XCDR (tail
))
785 emacs_close (XFASTINT (XCAR (tail
)));
790 complete_filename_p (pathname
)
791 Lisp_Object pathname
;
793 register unsigned char *s
= XSTRING (pathname
)->data
;
794 return (IS_DIRECTORY_SEP (s
[0])
795 || (XSTRING (pathname
)->size
> 2
796 && IS_DEVICE_SEP (s
[1]) && IS_DIRECTORY_SEP (s
[2]))
806 /* Search for a file whose name is STR, looking in directories
807 in the Lisp list PATH, and trying suffixes from SUFFIX.
808 SUFFIX is a string containing possible suffixes separated by colons.
809 On success, returns a file descriptor. On failure, returns -1.
811 EXEC_ONLY nonzero means don't open the files,
812 just look for one that is executable. In this case,
813 returns 1 on success.
815 If STOREPTR is nonzero, it points to a slot where the name of
816 the file actually found should be stored as a Lisp string.
817 nil is stored there on failure.
819 If the file we find is remote, return 0
820 but store the found remote file name in *STOREPTR.
821 We do not check for remote files if EXEC_ONLY is nonzero. */
824 openp (path
, str
, suffix
, storeptr
, exec_only
)
825 Lisp_Object path
, str
;
827 Lisp_Object
*storeptr
;
833 register char *fn
= buf
;
836 Lisp_Object filename
;
844 if (complete_filename_p (str
))
847 for (; !NILP (path
); path
= Fcdr (path
))
851 filename
= Fexpand_file_name (str
, Fcar (path
));
852 if (!complete_filename_p (filename
))
853 /* If there are non-absolute elts in PATH (eg ".") */
854 /* Of course, this could conceivably lose if luser sets
855 default-directory to be something non-absolute... */
857 filename
= Fexpand_file_name (filename
, current_buffer
->directory
);
858 if (!complete_filename_p (filename
))
859 /* Give up on this path element! */
863 /* Calculate maximum size of any filename made from
864 this path element/specified file name and any possible suffix. */
865 want_size
= strlen (suffix
) + STRING_BYTES (XSTRING (filename
)) + 1;
866 if (fn_size
< want_size
)
867 fn
= (char *) alloca (fn_size
= 100 + want_size
);
871 /* Loop over suffixes. */
874 char *esuffix
= (char *) index (nsuffix
, ':');
875 int lsuffix
= esuffix
? esuffix
- nsuffix
: strlen (nsuffix
);
878 /* Concatenate path element/specified name with the suffix.
879 If the directory starts with /:, remove that. */
880 if (XSTRING (filename
)->size
> 2
881 && XSTRING (filename
)->data
[0] == '/'
882 && XSTRING (filename
)->data
[1] == ':')
884 strncpy (fn
, XSTRING (filename
)->data
+ 2,
885 STRING_BYTES (XSTRING (filename
)) - 2);
886 fn
[STRING_BYTES (XSTRING (filename
)) - 2] = 0;
890 strncpy (fn
, XSTRING (filename
)->data
,
891 STRING_BYTES (XSTRING (filename
)));
892 fn
[STRING_BYTES (XSTRING (filename
))] = 0;
895 if (lsuffix
!= 0) /* Bug happens on CCI if lsuffix is 0. */
896 strncat (fn
, nsuffix
, lsuffix
);
898 /* Check that the file exists and is not a directory. */
902 handler
= Ffind_file_name_handler (filename
, Qfile_exists_p
);
903 if (! NILP (handler
) && ! exec_only
)
908 string
= build_string (fn
);
909 exists
= ! NILP (exec_only
? Ffile_executable_p (string
)
910 : Ffile_readable_p (string
));
912 && ! NILP (Ffile_directory_p (build_string (fn
))))
917 /* We succeeded; return this descriptor and filename. */
919 *storeptr
= build_string (fn
);
926 int exists
= (stat (fn
, &st
) >= 0
927 && (st
.st_mode
& S_IFMT
) != S_IFDIR
);
930 /* Check that we can access or open it. */
932 fd
= (access (fn
, X_OK
) == 0) ? 1 : -1;
934 fd
= emacs_open (fn
, O_RDONLY
, 0);
938 /* We succeeded; return this descriptor and filename. */
940 *storeptr
= build_string (fn
);
947 /* Advance to next suffix. */
950 nsuffix
+= lsuffix
+ 1;
961 /* Merge the list we've accumulated of globals from the current input source
962 into the load_history variable. The details depend on whether
963 the source has an associated file name or not. */
966 build_load_history (stream
, source
)
970 register Lisp_Object tail
, prev
, newelt
;
971 register Lisp_Object tem
, tem2
;
972 register int foundit
, loading
;
974 loading
= stream
|| !NARROWED
;
976 tail
= Vload_history
;
983 /* Find the feature's previous assoc list... */
984 if (!NILP (Fequal (source
, Fcar (tem
))))
988 /* If we're loading, remove it. */
992 Vload_history
= Fcdr (tail
);
994 Fsetcdr (prev
, Fcdr (tail
));
997 /* Otherwise, cons on new symbols that are not already members. */
1000 tem2
= Vcurrent_load_list
;
1002 while (CONSP (tem2
))
1004 newelt
= Fcar (tem2
);
1006 if (NILP (Fmemq (newelt
, tem
)))
1007 Fsetcar (tail
, Fcons (Fcar (tem
),
1008 Fcons (newelt
, Fcdr (tem
))));
1021 /* If we're loading, cons the new assoc onto the front of load-history,
1022 the most-recently-loaded position. Also do this if we didn't find
1023 an existing member for the current source. */
1024 if (loading
|| !foundit
)
1025 Vload_history
= Fcons (Fnreverse (Vcurrent_load_list
),
1030 unreadpure () /* Used as unwind-protect function in readevalloop */
1037 readevalloop_1 (old
)
1040 load_convert_to_unibyte
= ! NILP (old
);
1044 /* UNIBYTE specifies how to set load_convert_to_unibyte
1045 for this invocation.
1046 READFUN, if non-nil, is used instead of `read'. */
1049 readevalloop (readcharfun
, stream
, sourcename
, evalfun
, printflag
, unibyte
, readfun
)
1050 Lisp_Object readcharfun
;
1052 Lisp_Object sourcename
;
1053 Lisp_Object (*evalfun
) ();
1055 Lisp_Object unibyte
, readfun
;
1058 register Lisp_Object val
;
1059 int count
= specpdl_ptr
- specpdl
;
1060 struct gcpro gcpro1
;
1061 struct buffer
*b
= 0;
1063 if (BUFFERP (readcharfun
))
1064 b
= XBUFFER (readcharfun
);
1065 else if (MARKERP (readcharfun
))
1066 b
= XMARKER (readcharfun
)->buffer
;
1068 specbind (Qstandard_input
, readcharfun
);
1069 specbind (Qcurrent_load_list
, Qnil
);
1070 record_unwind_protect (readevalloop_1
, load_convert_to_unibyte
? Qt
: Qnil
);
1071 load_convert_to_unibyte
= !NILP (unibyte
);
1073 readchar_backlog
= -1;
1075 GCPRO1 (sourcename
);
1077 LOADHIST_ATTACH (sourcename
);
1081 if (b
!= 0 && NILP (b
->name
))
1082 error ("Reading from killed buffer");
1088 while ((c
= READCHAR
) != '\n' && c
!= -1);
1093 /* Ignore whitespace here, so we can detect eof. */
1094 if (c
== ' ' || c
== '\t' || c
== '\n' || c
== '\f' || c
== '\r')
1097 if (!NILP (Vpurify_flag
) && c
== '(')
1099 int count1
= specpdl_ptr
- specpdl
;
1100 record_unwind_protect (unreadpure
, Qnil
);
1101 val
= read_list (-1, readcharfun
);
1102 unbind_to (count1
, Qnil
);
1107 read_objects
= Qnil
;
1108 if (! NILP (readfun
))
1109 val
= call1 (readfun
, readcharfun
);
1110 else if (! NILP (Vload_read_function
))
1111 val
= call1 (Vload_read_function
, readcharfun
);
1113 val
= read0 (readcharfun
);
1116 val
= (*evalfun
) (val
);
1119 Vvalues
= Fcons (val
, Vvalues
);
1120 if (EQ (Vstandard_output
, Qt
))
1127 build_load_history (stream
, sourcename
);
1130 unbind_to (count
, Qnil
);
1135 DEFUN ("eval-buffer", Feval_buffer
, Seval_buffer
, 0, 5, "",
1136 "Execute the current buffer as Lisp code.\n\
1137 Programs can pass two arguments, BUFFER and PRINTFLAG.\n\
1138 BUFFER is the buffer to evaluate (nil means use current buffer).\n\
1139 PRINTFLAG controls printing of output:\n\
1140 nil means discard it; anything else is stream for print.\n\
1142 If the optional third argument FILENAME is non-nil,\n\
1143 it specifies the file name to use for `load-history'.\n\
1144 The optional fourth argument UNIBYTE specifies `load-convert-to-unibyte'\n\
1145 for this invocation.\n\
1147 The optional fifth argument DO-ALLOW-PRINT, if not-nil, specifies that\n\
1148 `print' and related functions should work normally even if PRINTFLAG is nil.\n\
1150 This function preserves the position of point.")
1151 (buffer
, printflag
, filename
, unibyte
, do_allow_print
)
1152 Lisp_Object buffer
, printflag
, filename
, unibyte
, do_allow_print
;
1154 int count
= specpdl_ptr
- specpdl
;
1155 Lisp_Object tem
, buf
;
1158 buf
= Fcurrent_buffer ();
1160 buf
= Fget_buffer (buffer
);
1162 error ("No such buffer");
1164 if (NILP (printflag
) && NILP (do_allow_print
))
1169 if (NILP (filename
))
1170 filename
= XBUFFER (buf
)->filename
;
1172 specbind (Qstandard_output
, tem
);
1173 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
1174 BUF_SET_PT (XBUFFER (buf
), BUF_BEGV (XBUFFER (buf
)));
1175 readevalloop (buf
, 0, filename
, Feval
, !NILP (printflag
), unibyte
, Qnil
);
1176 unbind_to (count
, Qnil
);
1182 XDEFUN ("eval-current-buffer", Feval_current_buffer
, Seval_current_buffer
, 0, 1, "",
1183 "Execute the current buffer as Lisp code.\n\
1184 Programs can pass argument PRINTFLAG which controls printing of output:\n\
1185 nil means discard it; anything else is stream for print.\n\
1187 If there is no error, point does not move. If there is an error,\n\
1188 point remains at the end of the last character read from the buffer.")
1190 Lisp_Object printflag
;
1192 int count
= specpdl_ptr
- specpdl
;
1193 Lisp_Object tem
, cbuf
;
1195 cbuf
= Fcurrent_buffer ()
1197 if (NILP (printflag
))
1201 specbind (Qstandard_output
, tem
);
1202 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
1204 readevalloop (cbuf
, 0, XBUFFER (cbuf
)->filename
, Feval
,
1205 !NILP (printflag
), Qnil
, Qnil
);
1206 return unbind_to (count
, Qnil
);
1210 DEFUN ("eval-region", Feval_region
, Seval_region
, 2, 4, "r",
1211 "Execute the region as Lisp code.\n\
1212 When called from programs, expects two arguments,\n\
1213 giving starting and ending indices in the current buffer\n\
1214 of the text to be executed.\n\
1215 Programs can pass third argument PRINTFLAG which controls output:\n\
1216 nil means discard it; anything else is stream for printing it.\n\
1217 Also the fourth argument READ-FUNCTION, if non-nil, is used\n\
1218 instead of `read' to read each expression. It gets one argument\n\
1219 which is the input stream for reading characters.\n\
1221 This function does not move point.")
1222 (start
, end
, printflag
, read_function
)
1223 Lisp_Object start
, end
, printflag
, read_function
;
1225 int count
= specpdl_ptr
- specpdl
;
1226 Lisp_Object tem
, cbuf
;
1228 cbuf
= Fcurrent_buffer ();
1230 if (NILP (printflag
))
1234 specbind (Qstandard_output
, tem
);
1236 if (NILP (printflag
))
1237 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
1238 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
1240 /* This both uses start and checks its type. */
1242 Fnarrow_to_region (make_number (BEGV
), end
);
1243 readevalloop (cbuf
, 0, XBUFFER (cbuf
)->filename
, Feval
,
1244 !NILP (printflag
), Qnil
, read_function
);
1246 return unbind_to (count
, Qnil
);
1249 #endif /* standalone */
1251 DEFUN ("read", Fread
, Sread
, 0, 1, 0,
1252 "Read one Lisp expression as text from STREAM, return as Lisp object.\n\
1253 If STREAM is nil, use the value of `standard-input' (which see).\n\
1254 STREAM or the value of `standard-input' may be:\n\
1255 a buffer (read from point and advance it)\n\
1256 a marker (read from where it points and advance it)\n\
1257 a function (call it with no arguments for each character,\n\
1258 call it with a char as argument to push a char back)\n\
1259 a string (takes text from string, starting at the beginning)\n\
1260 t (read text line using minibuffer and use it).")
1264 extern Lisp_Object
Fread_minibuffer ();
1267 stream
= Vstandard_input
;
1268 if (EQ (stream
, Qt
))
1269 stream
= Qread_char
;
1271 readchar_backlog
= -1;
1272 new_backquote_flag
= 0;
1273 read_objects
= Qnil
;
1276 if (EQ (stream
, Qread_char
))
1277 return Fread_minibuffer (build_string ("Lisp expression: "), Qnil
);
1280 if (STRINGP (stream
))
1281 return Fcar (Fread_from_string (stream
, Qnil
, Qnil
));
1283 return read0 (stream
);
1286 DEFUN ("read-from-string", Fread_from_string
, Sread_from_string
, 1, 3, 0,
1287 "Read one Lisp expression which is represented as text by STRING.\n\
1288 Returns a cons: (OBJECT-READ . FINAL-STRING-INDEX).\n\
1289 START and END optionally delimit a substring of STRING from which to read;\n\
1290 they default to 0 and (length STRING) respectively.")
1291 (string
, start
, end
)
1292 Lisp_Object string
, start
, end
;
1294 int startval
, endval
;
1297 CHECK_STRING (string
,0);
1300 endval
= XSTRING (string
)->size
;
1303 CHECK_NUMBER (end
, 2);
1304 endval
= XINT (end
);
1305 if (endval
< 0 || endval
> XSTRING (string
)->size
)
1306 args_out_of_range (string
, end
);
1313 CHECK_NUMBER (start
, 1);
1314 startval
= XINT (start
);
1315 if (startval
< 0 || startval
> endval
)
1316 args_out_of_range (string
, start
);
1319 read_from_string_index
= startval
;
1320 read_from_string_index_byte
= string_char_to_byte (string
, startval
);
1321 read_from_string_limit
= endval
;
1323 new_backquote_flag
= 0;
1324 read_objects
= Qnil
;
1326 tem
= read0 (string
);
1327 return Fcons (tem
, make_number (read_from_string_index
));
1330 /* Use this for recursive reads, in contexts where internal tokens
1335 Lisp_Object readcharfun
;
1337 register Lisp_Object val
;
1340 val
= read1 (readcharfun
, &c
, 0);
1342 Fsignal (Qinvalid_read_syntax
, Fcons (Fmake_string (make_number (1),
1349 static int read_buffer_size
;
1350 static char *read_buffer
;
1352 /* Read multibyte form and return it as a character. C is a first
1353 byte of multibyte form, and rest of them are read from
1357 read_multibyte (c
, readcharfun
)
1359 Lisp_Object readcharfun
;
1361 /* We need the actual character code of this multibyte
1363 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
1367 while ((c
= READCHAR
) >= 0xA0
1368 && len
< MAX_MULTIBYTE_LENGTH
)
1371 return STRING_CHAR (str
, len
);
1374 /* Read a \-escape sequence, assuming we already read the `\'. */
1377 read_escape (readcharfun
, stringp
)
1378 Lisp_Object readcharfun
;
1381 register int c
= READCHAR
;
1385 error ("End of file");
1415 error ("Invalid escape character syntax");
1418 c
= read_escape (readcharfun
, 0);
1419 return c
| meta_modifier
;
1424 error ("Invalid escape character syntax");
1427 c
= read_escape (readcharfun
, 0);
1428 return c
| shift_modifier
;
1433 error ("Invalid escape character syntax");
1436 c
= read_escape (readcharfun
, 0);
1437 return c
| hyper_modifier
;
1442 error ("Invalid escape character syntax");
1445 c
= read_escape (readcharfun
, 0);
1446 return c
| alt_modifier
;
1451 error ("Invalid escape character syntax");
1454 c
= read_escape (readcharfun
, 0);
1455 return c
| super_modifier
;
1460 error ("Invalid escape character syntax");
1464 c
= read_escape (readcharfun
, 0);
1465 if ((c
& ~CHAR_MODIFIER_MASK
) == '?')
1466 return 0177 | (c
& CHAR_MODIFIER_MASK
);
1467 else if (! SINGLE_BYTE_CHAR_P ((c
& ~CHAR_MODIFIER_MASK
)))
1468 return c
| ctrl_modifier
;
1469 /* ASCII control chars are made from letters (both cases),
1470 as well as the non-letters within 0100...0137. */
1471 else if ((c
& 0137) >= 0101 && (c
& 0137) <= 0132)
1472 return (c
& (037 | ~0177));
1473 else if ((c
& 0177) >= 0100 && (c
& 0177) <= 0137)
1474 return (c
& (037 | ~0177));
1476 return c
| ctrl_modifier
;
1486 /* An octal escape, as in ANSI C. */
1488 register int i
= c
- '0';
1489 register int count
= 0;
1492 if ((c
= READCHAR
) >= '0' && c
<= '7')
1507 /* A hex escape, as in ANSI C. */
1513 if (c
>= '0' && c
<= '9')
1518 else if ((c
>= 'a' && c
<= 'f')
1519 || (c
>= 'A' && c
<= 'F'))
1522 if (c
>= 'a' && c
<= 'f')
1537 if (BASE_LEADING_CODE_P (c
))
1538 c
= read_multibyte (c
, readcharfun
);
1543 /* If the next token is ')' or ']' or '.', we store that character
1544 in *PCH and the return value is not interesting. Else, we store
1545 zero in *PCH and we read and return one lisp object.
1547 FIRST_IN_LIST is nonzero if this is the first element of a list. */
1550 read1 (readcharfun
, pch
, first_in_list
)
1551 register Lisp_Object readcharfun
;
1556 int uninterned_symbol
= 0;
1563 if (c
< 0) return Fsignal (Qend_of_file
, Qnil
);
1568 return read_list (0, readcharfun
);
1571 return read_vector (readcharfun
, 0);
1588 tmp
= read_vector (readcharfun
, 0);
1589 if (XVECTOR (tmp
)->size
< CHAR_TABLE_STANDARD_SLOTS
1590 || XVECTOR (tmp
)->size
> CHAR_TABLE_STANDARD_SLOTS
+ 10)
1591 error ("Invalid size char-table");
1592 XSETCHAR_TABLE (tmp
, XCHAR_TABLE (tmp
));
1593 XCHAR_TABLE (tmp
)->top
= Qt
;
1602 tmp
= read_vector (readcharfun
, 0);
1603 if (XVECTOR (tmp
)->size
!= SUB_CHAR_TABLE_STANDARD_SLOTS
)
1604 error ("Invalid size char-table");
1605 XSETCHAR_TABLE (tmp
, XCHAR_TABLE (tmp
));
1606 XCHAR_TABLE (tmp
)->top
= Qnil
;
1609 Fsignal (Qinvalid_read_syntax
,
1610 Fcons (make_string ("#^^", 3), Qnil
));
1612 Fsignal (Qinvalid_read_syntax
, Fcons (make_string ("#^", 2), Qnil
));
1617 length
= read1 (readcharfun
, pch
, first_in_list
);
1621 Lisp_Object tmp
, val
;
1622 int size_in_chars
= ((XFASTINT (length
) + BITS_PER_CHAR
- 1)
1626 tmp
= read1 (readcharfun
, pch
, first_in_list
);
1627 if (size_in_chars
!= XSTRING (tmp
)->size
1628 /* We used to print 1 char too many
1629 when the number of bits was a multiple of 8.
1630 Accept such input in case it came from an old version. */
1631 && ! (XFASTINT (length
)
1632 == (XSTRING (tmp
)->size
- 1) * BITS_PER_CHAR
))
1633 Fsignal (Qinvalid_read_syntax
,
1634 Fcons (make_string ("#&...", 5), Qnil
));
1636 val
= Fmake_bool_vector (length
, Qnil
);
1637 bcopy (XSTRING (tmp
)->data
, XBOOL_VECTOR (val
)->data
,
1639 /* Clear the extraneous bits in the last byte. */
1640 if (XINT (length
) != size_in_chars
* BITS_PER_CHAR
)
1641 XBOOL_VECTOR (val
)->data
[size_in_chars
- 1]
1642 &= (1 << (XINT (length
) % BITS_PER_CHAR
)) - 1;
1645 Fsignal (Qinvalid_read_syntax
, Fcons (make_string ("#&...", 5),
1650 /* Accept compiled functions at read-time so that we don't have to
1651 build them using function calls. */
1653 tmp
= read_vector (readcharfun
, 1);
1654 return Fmake_byte_code (XVECTOR (tmp
)->size
,
1655 XVECTOR (tmp
)->contents
);
1660 struct gcpro gcpro1
;
1663 /* Read the string itself. */
1664 tmp
= read1 (readcharfun
, &ch
, 0);
1665 if (ch
!= 0 || !STRINGP (tmp
))
1666 Fsignal (Qinvalid_read_syntax
, Fcons (make_string ("#", 1), Qnil
));
1668 /* Read the intervals and their properties. */
1671 Lisp_Object beg
, end
, plist
;
1673 beg
= read1 (readcharfun
, &ch
, 0);
1677 end
= read1 (readcharfun
, &ch
, 0);
1679 plist
= read1 (readcharfun
, &ch
, 0);
1681 Fsignal (Qinvalid_read_syntax
,
1682 Fcons (build_string ("invalid string property list"),
1684 Fset_text_properties (beg
, end
, plist
, tmp
);
1690 /* #@NUMBER is used to skip NUMBER following characters.
1691 That's used in .elc files to skip over doc strings
1692 and function definitions. */
1697 /* Read a decimal integer. */
1698 while ((c
= READCHAR
) >= 0
1699 && c
>= '0' && c
<= '9')
1707 if (load_force_doc_strings
&& EQ (readcharfun
, Qget_file_char
))
1709 /* If we are supposed to force doc strings into core right now,
1710 record the last string that we skipped,
1711 and record where in the file it comes from. */
1713 /* But first exchange saved_doc_string
1714 with prev_saved_doc_string, so we save two strings. */
1716 char *temp
= saved_doc_string
;
1717 int temp_size
= saved_doc_string_size
;
1718 file_offset temp_pos
= saved_doc_string_position
;
1719 int temp_len
= saved_doc_string_length
;
1721 saved_doc_string
= prev_saved_doc_string
;
1722 saved_doc_string_size
= prev_saved_doc_string_size
;
1723 saved_doc_string_position
= prev_saved_doc_string_position
;
1724 saved_doc_string_length
= prev_saved_doc_string_length
;
1726 prev_saved_doc_string
= temp
;
1727 prev_saved_doc_string_size
= temp_size
;
1728 prev_saved_doc_string_position
= temp_pos
;
1729 prev_saved_doc_string_length
= temp_len
;
1732 if (saved_doc_string_size
== 0)
1734 saved_doc_string_size
= nskip
+ 100;
1735 saved_doc_string
= (char *) xmalloc (saved_doc_string_size
);
1737 if (nskip
> saved_doc_string_size
)
1739 saved_doc_string_size
= nskip
+ 100;
1740 saved_doc_string
= (char *) xrealloc (saved_doc_string
,
1741 saved_doc_string_size
);
1744 saved_doc_string_position
= file_tell (instream
);
1746 /* Copy that many characters into saved_doc_string. */
1747 for (i
= 0; i
< nskip
&& c
>= 0; i
++)
1748 saved_doc_string
[i
] = c
= READCHAR
;
1750 saved_doc_string_length
= i
;
1754 /* Skip that many characters. */
1755 for (i
= 0; i
< nskip
&& c
>= 0; i
++)
1762 return Vload_file_name
;
1764 return Fcons (Qfunction
, Fcons (read0 (readcharfun
), Qnil
));
1765 /* #:foo is the uninterned symbol named foo. */
1768 uninterned_symbol
= 1;
1772 /* Reader forms that can reuse previously read objects. */
1773 if (c
>= '0' && c
<= '9')
1778 /* Read a non-negative integer. */
1779 while (c
>= '0' && c
<= '9')
1785 /* #n=object returns object, but associates it with n for #n#. */
1788 /* Make a placeholder for #n# to use temporarily */
1789 Lisp_Object placeholder
;
1792 placeholder
= Fcons(Qnil
, Qnil
);
1793 cell
= Fcons (make_number (n
), placeholder
);
1794 read_objects
= Fcons (cell
, read_objects
);
1796 /* Read the object itself. */
1797 tem
= read0 (readcharfun
);
1799 /* Now put it everywhere the placeholder was... */
1800 substitute_object_in_subtree (tem
, placeholder
);
1802 /* ...and #n# will use the real value from now on. */
1803 Fsetcdr (cell
, tem
);
1807 /* #n# returns a previously read object. */
1810 tem
= Fassq (make_number (n
), read_objects
);
1813 /* Fall through to error message. */
1815 /* Fall through to error message. */
1819 Fsignal (Qinvalid_read_syntax
, Fcons (make_string ("#", 1), Qnil
));
1822 while ((c
= READCHAR
) >= 0 && c
!= '\n');
1827 return Fcons (Qquote
, Fcons (read0 (readcharfun
), Qnil
));
1837 new_backquote_flag
= 1;
1838 value
= read0 (readcharfun
);
1839 new_backquote_flag
= 0;
1841 return Fcons (Qbackquote
, Fcons (value
, Qnil
));
1845 if (new_backquote_flag
)
1847 Lisp_Object comma_type
= Qnil
;
1852 comma_type
= Qcomma_at
;
1854 comma_type
= Qcomma_dot
;
1857 if (ch
>= 0) UNREAD (ch
);
1858 comma_type
= Qcomma
;
1861 new_backquote_flag
= 0;
1862 value
= read0 (readcharfun
);
1863 new_backquote_flag
= 1;
1864 return Fcons (comma_type
, Fcons (value
, Qnil
));
1872 if (c
< 0) return Fsignal (Qend_of_file
, Qnil
);
1875 c
= read_escape (readcharfun
, 0);
1876 else if (BASE_LEADING_CODE_P (c
))
1877 c
= read_multibyte (c
, readcharfun
);
1879 return make_number (c
);
1884 register char *p
= read_buffer
;
1885 register char *end
= read_buffer
+ read_buffer_size
;
1887 /* Nonzero if we saw an escape sequence specifying
1888 a multibyte character. */
1889 int force_multibyte
= 0;
1890 /* Nonzero if we saw an escape sequence specifying
1891 a single-byte character. */
1892 int force_singlebyte
= 0;
1896 while ((c
= READCHAR
) >= 0
1899 if (end
- p
< MAX_MULTIBYTE_LENGTH
)
1901 char *new = (char *) xrealloc (read_buffer
, read_buffer_size
*= 2);
1902 p
+= new - read_buffer
;
1903 read_buffer
+= new - read_buffer
;
1904 end
= read_buffer
+ read_buffer_size
;
1909 c
= read_escape (readcharfun
, 1);
1911 /* C is -1 if \ newline has just been seen */
1914 if (p
== read_buffer
)
1919 /* If an escape specifies a non-ASCII single-byte character,
1920 this must be a unibyte string. */
1921 if (SINGLE_BYTE_CHAR_P ((c
& ~CHAR_MODIFIER_MASK
))
1922 && ! ASCII_BYTE_P ((c
& ~CHAR_MODIFIER_MASK
)))
1923 force_singlebyte
= 1;
1926 if (! SINGLE_BYTE_CHAR_P ((c
& ~CHAR_MODIFIER_MASK
)))
1928 /* Any modifiers for a multibyte character are invalid. */
1929 if (c
& CHAR_MODIFIER_MASK
)
1930 error ("Invalid modifier in string");
1931 p
+= CHAR_STRING (c
, p
);
1932 force_multibyte
= 1;
1936 /* Allow `\C- ' and `\C-?'. */
1937 if (c
== (CHAR_CTL
| ' '))
1939 else if (c
== (CHAR_CTL
| '?'))
1944 /* Shift modifier is valid only with [A-Za-z]. */
1945 if ((c
& 0377) >= 'A' && (c
& 0377) <= 'Z')
1947 else if ((c
& 0377) >= 'a' && (c
& 0377) <= 'z')
1948 c
= (c
& ~CHAR_SHIFT
) - ('a' - 'A');
1952 /* Move the meta bit to the right place for a string. */
1953 c
= (c
& ~CHAR_META
) | 0x80;
1955 error ("Invalid modifier in string");
1960 return Fsignal (Qend_of_file
, Qnil
);
1962 /* If purifying, and string starts with \ newline,
1963 return zero instead. This is for doc strings
1964 that we are really going to find in etc/DOC.nn.nn */
1965 if (!NILP (Vpurify_flag
) && NILP (Vdoc_file_name
) && cancel
)
1966 return make_number (0);
1968 if (force_multibyte
)
1969 nchars
= multibyte_chars_in_text (read_buffer
, p
- read_buffer
);
1970 else if (force_singlebyte
)
1971 nchars
= p
- read_buffer
;
1972 else if (load_convert_to_unibyte
)
1975 nchars
= multibyte_chars_in_text (read_buffer
, p
- read_buffer
);
1976 if (p
- read_buffer
!= nchars
)
1978 string
= make_multibyte_string (read_buffer
, nchars
,
1980 return Fstring_make_unibyte (string
);
1983 else if (EQ (readcharfun
, Qget_file_char
)
1984 || EQ (readcharfun
, Qlambda
))
1985 /* Nowadays, reading directly from a file
1986 is used only for compiled Emacs Lisp files,
1987 and those always use the Emacs internal encoding.
1988 Meanwhile, Qlambda is used for reading dynamic byte code
1989 (compiled with byte-compile-dynamic = t). */
1990 nchars
= multibyte_chars_in_text (read_buffer
, p
- read_buffer
);
1992 /* In all other cases, if we read these bytes as
1993 separate characters, treat them as separate characters now. */
1994 nchars
= p
- read_buffer
;
1997 return make_pure_string (read_buffer
, nchars
, p
- read_buffer
,
1999 || (p
- read_buffer
!= nchars
)));
2000 return make_specified_string (read_buffer
, nchars
, p
- read_buffer
,
2002 || (p
- read_buffer
!= nchars
)));
2007 #ifdef LISP_FLOAT_TYPE
2008 /* If a period is followed by a number, then we should read it
2009 as a floating point number. Otherwise, it denotes a dotted
2011 int next_char
= READCHAR
;
2014 if (! (next_char
>= '0' && next_char
<= '9'))
2021 /* Otherwise, we fall through! Note that the atom-reading loop
2022 below will now loop at least once, assuring that we will not
2023 try to UNREAD two characters in a row. */
2027 if (c
<= 040) goto retry
;
2029 register char *p
= read_buffer
;
2033 register char *end
= read_buffer
+ read_buffer_size
;
2036 && !(c
== '\"' || c
== '\'' || c
== ';' || c
== '?'
2037 || c
== '(' || c
== ')'
2038 #ifndef LISP_FLOAT_TYPE
2039 /* If we have floating-point support, then we need
2040 to allow <digits><dot><digits>. */
2042 #endif /* not LISP_FLOAT_TYPE */
2043 || c
== '[' || c
== ']' || c
== '#'
2046 if (end
- p
< MAX_MULTIBYTE_LENGTH
)
2048 register char *new = (char *) xrealloc (read_buffer
, read_buffer_size
*= 2);
2049 p
+= new - read_buffer
;
2050 read_buffer
+= new - read_buffer
;
2051 end
= read_buffer
+ read_buffer_size
;
2059 if (! SINGLE_BYTE_CHAR_P (c
))
2060 p
+= CHAR_STRING (c
, p
);
2069 char *new = (char *) xrealloc (read_buffer
, read_buffer_size
*= 2);
2070 p
+= new - read_buffer
;
2071 read_buffer
+= new - read_buffer
;
2072 /* end = read_buffer + read_buffer_size; */
2079 if (!quoted
&& !uninterned_symbol
)
2082 register Lisp_Object val
;
2084 if (*p1
== '+' || *p1
== '-') p1
++;
2085 /* Is it an integer? */
2088 while (p1
!= p
&& (c
= *p1
) >= '0' && c
<= '9') p1
++;
2089 #ifdef LISP_FLOAT_TYPE
2090 /* Integers can have trailing decimal points. */
2091 if (p1
> read_buffer
&& p1
< p
&& *p1
== '.') p1
++;
2094 /* It is an integer. */
2096 #ifdef LISP_FLOAT_TYPE
2100 if (sizeof (int) == sizeof (EMACS_INT
))
2101 XSETINT (val
, atoi (read_buffer
));
2102 else if (sizeof (long) == sizeof (EMACS_INT
))
2103 XSETINT (val
, atol (read_buffer
));
2109 #ifdef LISP_FLOAT_TYPE
2110 if (isfloat_string (read_buffer
))
2112 /* Compute NaN and infinities using 0.0 in a variable,
2113 to cope with compilers that think they are smarter
2119 /* Negate the value ourselves. This treats 0, NaNs,
2120 and infinity properly on IEEE floating point hosts,
2121 and works around a common bug where atof ("-0.0")
2123 int negative
= read_buffer
[0] == '-';
2125 /* The only way p[-1] can be 'F' or 'N', after isfloat_string
2126 returns 1, is if the input ends in e+INF or e+NaN. */
2133 value
= zero
/ zero
;
2136 value
= atof (read_buffer
+ negative
);
2140 return make_float (negative
? - value
: value
);
2145 if (uninterned_symbol
)
2146 return make_symbol (read_buffer
);
2148 return intern (read_buffer
);
2154 /* List of nodes we've seen during substitute_object_in_subtree. */
2155 static Lisp_Object seen_list
;
2158 substitute_object_in_subtree (object
, placeholder
)
2160 Lisp_Object placeholder
;
2162 Lisp_Object check_object
;
2164 /* We haven't seen any objects when we start. */
2167 /* Make all the substitutions. */
2169 = substitute_object_recurse (object
, placeholder
, object
);
2171 /* Clear seen_list because we're done with it. */
2174 /* The returned object here is expected to always eq the
2176 if (!EQ (check_object
, object
))
2177 error ("Unexpected mutation error in reader");
2180 /* Feval doesn't get called from here, so no gc protection is needed. */
2181 #define SUBSTITUTE(get_val, set_val) \
2183 Lisp_Object old_value = get_val; \
2184 Lisp_Object true_value \
2185 = substitute_object_recurse (object, placeholder,\
2188 if (!EQ (old_value, true_value)) \
2195 substitute_object_recurse (object
, placeholder
, subtree
)
2197 Lisp_Object placeholder
;
2198 Lisp_Object subtree
;
2200 /* If we find the placeholder, return the target object. */
2201 if (EQ (placeholder
, subtree
))
2204 /* If we've been to this node before, don't explore it again. */
2205 if (!EQ (Qnil
, Fmemq (subtree
, seen_list
)))
2208 /* If this node can be the entry point to a cycle, remember that
2209 we've seen it. It can only be such an entry point if it was made
2210 by #n=, which means that we can find it as a value in
2212 if (!EQ (Qnil
, Frassq (subtree
, read_objects
)))
2213 seen_list
= Fcons (subtree
, seen_list
);
2215 /* Recurse according to subtree's type.
2216 Every branch must return a Lisp_Object. */
2217 switch (XTYPE (subtree
))
2219 case Lisp_Vectorlike
:
2222 int length
= Flength(subtree
);
2223 for (i
= 0; i
< length
; i
++)
2225 Lisp_Object idx
= make_number (i
);
2226 SUBSTITUTE (Faref (subtree
, idx
),
2227 Faset (subtree
, idx
, true_value
));
2234 SUBSTITUTE (Fcar_safe (subtree
),
2235 Fsetcar (subtree
, true_value
));
2236 SUBSTITUTE (Fcdr_safe (subtree
),
2237 Fsetcdr (subtree
, true_value
));
2243 /* Check for text properties in each interval.
2244 substitute_in_interval contains part of the logic. */
2246 INTERVAL root_interval
= XSTRING (subtree
)->intervals
;
2247 Lisp_Object arg
= Fcons (object
, placeholder
);
2249 traverse_intervals (root_interval
, 1, 0,
2250 &substitute_in_interval
, arg
);
2255 /* Other types don't recurse any further. */
2261 /* Helper function for substitute_object_recurse. */
2263 substitute_in_interval (interval
, arg
)
2267 Lisp_Object object
= Fcar (arg
);
2268 Lisp_Object placeholder
= Fcdr (arg
);
2270 SUBSTITUTE(interval
->plist
, interval
->plist
= true_value
);
2274 #ifdef LISP_FLOAT_TYPE
2291 if (*cp
== '+' || *cp
== '-')
2294 if (*cp
>= '0' && *cp
<= '9')
2297 while (*cp
>= '0' && *cp
<= '9')
2305 if (*cp
>= '0' && *cp
<= '9')
2308 while (*cp
>= '0' && *cp
<= '9')
2311 if (*cp
== 'e' || *cp
== 'E')
2315 if (*cp
== '+' || *cp
== '-')
2319 if (*cp
>= '0' && *cp
<= '9')
2322 while (*cp
>= '0' && *cp
<= '9')
2325 else if (cp
== start
)
2327 else if (cp
[-1] == '+' && cp
[0] == 'I' && cp
[1] == 'N' && cp
[2] == 'F')
2332 else if (cp
[-1] == '+' && cp
[0] == 'N' && cp
[1] == 'a' && cp
[2] == 'N')
2338 return (((*cp
== 0) || (*cp
== ' ') || (*cp
== '\t') || (*cp
== '\n') || (*cp
== '\r') || (*cp
== '\f'))
2339 && (state
== (LEAD_INT
|DOT_CHAR
|TRAIL_INT
)
2340 || state
== (DOT_CHAR
|TRAIL_INT
)
2341 || state
== (LEAD_INT
|E_CHAR
|EXP_INT
)
2342 || state
== (LEAD_INT
|DOT_CHAR
|TRAIL_INT
|E_CHAR
|EXP_INT
)
2343 || state
== (DOT_CHAR
|TRAIL_INT
|E_CHAR
|EXP_INT
)));
2345 #endif /* LISP_FLOAT_TYPE */
2348 read_vector (readcharfun
, bytecodeflag
)
2349 Lisp_Object readcharfun
;
2354 register Lisp_Object
*ptr
;
2355 register Lisp_Object tem
, item
, vector
;
2356 register struct Lisp_Cons
*otem
;
2359 tem
= read_list (1, readcharfun
);
2360 len
= Flength (tem
);
2361 vector
= (read_pure
? make_pure_vector (XINT (len
)) : Fmake_vector (len
, Qnil
));
2363 size
= XVECTOR (vector
)->size
;
2364 ptr
= XVECTOR (vector
)->contents
;
2365 for (i
= 0; i
< size
; i
++)
2368 /* If `load-force-doc-strings' is t when reading a lazily-loaded
2369 bytecode object, the docstring containing the bytecode and
2370 constants values must be treated as unibyte and passed to
2371 Fread, to get the actual bytecode string and constants vector. */
2372 if (bytecodeflag
&& load_force_doc_strings
)
2374 if (i
== COMPILED_BYTECODE
)
2376 if (!STRINGP (item
))
2377 error ("invalid byte code");
2379 /* Delay handling the bytecode slot until we know whether
2380 it is lazily-loaded (we can tell by whether the
2381 constants slot is nil). */
2382 ptr
[COMPILED_CONSTANTS
] = item
;
2385 else if (i
== COMPILED_CONSTANTS
)
2387 Lisp_Object bytestr
= ptr
[COMPILED_CONSTANTS
];
2391 /* Coerce string to unibyte (like string-as-unibyte,
2392 but without generating extra garbage and
2393 guaranteeing no change in the contents). */
2394 XSTRING (bytestr
)->size
= STRING_BYTES (XSTRING (bytestr
));
2395 SET_STRING_BYTES (XSTRING (bytestr
), -1);
2397 item
= Fread (bytestr
);
2399 error ("invalid byte code");
2401 otem
= XCONS (item
);
2402 bytestr
= XCAR (item
);
2407 /* Now handle the bytecode slot. */
2408 ptr
[COMPILED_BYTECODE
] = read_pure
? Fpurecopy (bytestr
) : bytestr
;
2411 ptr
[i
] = read_pure
? Fpurecopy (item
) : item
;
2419 /* FLAG = 1 means check for ] to terminate rather than ) and .
2420 FLAG = -1 means check for starting with defun
2421 and make structure pure. */
2424 read_list (flag
, readcharfun
)
2426 register Lisp_Object readcharfun
;
2428 /* -1 means check next element for defun,
2429 0 means don't check,
2430 1 means already checked and found defun. */
2431 int defunflag
= flag
< 0 ? -1 : 0;
2432 Lisp_Object val
, tail
;
2433 register Lisp_Object elt
, tem
;
2434 struct gcpro gcpro1
, gcpro2
;
2435 /* 0 is the normal case.
2436 1 means this list is a doc reference; replace it with the number 0.
2437 2 means this list is a doc reference; replace it with the doc string. */
2438 int doc_reference
= 0;
2440 /* Initialize this to 1 if we are reading a list. */
2441 int first_in_list
= flag
<= 0;
2450 elt
= read1 (readcharfun
, &ch
, first_in_list
);
2455 /* While building, if the list starts with #$, treat it specially. */
2456 if (EQ (elt
, Vload_file_name
)
2458 && !NILP (Vpurify_flag
))
2460 if (NILP (Vdoc_file_name
))
2461 /* We have not yet called Snarf-documentation, so assume
2462 this file is described in the DOC-MM.NN file
2463 and Snarf-documentation will fill in the right value later.
2464 For now, replace the whole list with 0. */
2467 /* We have already called Snarf-documentation, so make a relative
2468 file name for this file, so it can be found properly
2469 in the installed Lisp directory.
2470 We don't use Fexpand_file_name because that would make
2471 the directory absolute now. */
2472 elt
= concat2 (build_string ("../lisp/"),
2473 Ffile_name_nondirectory (elt
));
2475 else if (EQ (elt
, Vload_file_name
)
2477 && load_force_doc_strings
)
2486 Fsignal (Qinvalid_read_syntax
,
2487 Fcons (make_string (") or . in a vector", 18), Qnil
));
2495 XCDR (tail
) = read0 (readcharfun
);
2497 val
= read0 (readcharfun
);
2498 read1 (readcharfun
, &ch
, 0);
2502 if (doc_reference
== 1)
2503 return make_number (0);
2504 if (doc_reference
== 2)
2506 /* Get a doc string from the file we are loading.
2507 If it's in saved_doc_string, get it from there. */
2508 int pos
= XINT (XCDR (val
));
2509 /* Position is negative for user variables. */
2510 if (pos
< 0) pos
= -pos
;
2511 if (pos
>= saved_doc_string_position
2512 && pos
< (saved_doc_string_position
2513 + saved_doc_string_length
))
2515 int start
= pos
- saved_doc_string_position
;
2518 /* Process quoting with ^A,
2519 and find the end of the string,
2520 which is marked with ^_ (037). */
2521 for (from
= start
, to
= start
;
2522 saved_doc_string
[from
] != 037;)
2524 int c
= saved_doc_string
[from
++];
2527 c
= saved_doc_string
[from
++];
2529 saved_doc_string
[to
++] = c
;
2531 saved_doc_string
[to
++] = 0;
2533 saved_doc_string
[to
++] = 037;
2536 saved_doc_string
[to
++] = c
;
2539 return make_string (saved_doc_string
+ start
,
2542 /* Look in prev_saved_doc_string the same way. */
2543 else if (pos
>= prev_saved_doc_string_position
2544 && pos
< (prev_saved_doc_string_position
2545 + prev_saved_doc_string_length
))
2547 int start
= pos
- prev_saved_doc_string_position
;
2550 /* Process quoting with ^A,
2551 and find the end of the string,
2552 which is marked with ^_ (037). */
2553 for (from
= start
, to
= start
;
2554 prev_saved_doc_string
[from
] != 037;)
2556 int c
= prev_saved_doc_string
[from
++];
2559 c
= prev_saved_doc_string
[from
++];
2561 prev_saved_doc_string
[to
++] = c
;
2563 prev_saved_doc_string
[to
++] = 0;
2565 prev_saved_doc_string
[to
++] = 037;
2568 prev_saved_doc_string
[to
++] = c
;
2571 return make_string (prev_saved_doc_string
+ start
,
2575 return get_doc_string (val
, 0, 0);
2580 return Fsignal (Qinvalid_read_syntax
, Fcons (make_string (". in wrong context", 18), Qnil
));
2582 return Fsignal (Qinvalid_read_syntax
, Fcons (make_string ("] in a list", 11), Qnil
));
2584 tem
= (read_pure
&& flag
<= 0
2585 ? pure_cons (elt
, Qnil
)
2586 : Fcons (elt
, Qnil
));
2593 defunflag
= EQ (elt
, Qdefun
);
2594 else if (defunflag
> 0)
2599 Lisp_Object Vobarray
;
2600 Lisp_Object initial_obarray
;
2602 /* oblookup stores the bucket number here, for the sake of Funintern. */
2604 int oblookup_last_bucket_number
;
2606 static int hash_string ();
2607 Lisp_Object
oblookup ();
2609 /* Get an error if OBARRAY is not an obarray.
2610 If it is one, return it. */
2613 check_obarray (obarray
)
2614 Lisp_Object obarray
;
2616 while (!VECTORP (obarray
) || XVECTOR (obarray
)->size
== 0)
2618 /* If Vobarray is now invalid, force it to be valid. */
2619 if (EQ (Vobarray
, obarray
)) Vobarray
= initial_obarray
;
2621 obarray
= wrong_type_argument (Qvectorp
, obarray
);
2626 /* Intern the C string STR: return a symbol with that name,
2627 interned in the current obarray. */
2634 int len
= strlen (str
);
2635 Lisp_Object obarray
;
2638 if (!VECTORP (obarray
) || XVECTOR (obarray
)->size
== 0)
2639 obarray
= check_obarray (obarray
);
2640 tem
= oblookup (obarray
, str
, len
, len
);
2643 return Fintern (make_string (str
, len
), obarray
);
2646 /* Create an uninterned symbol with name STR. */
2652 int len
= strlen (str
);
2654 return Fmake_symbol ((!NILP (Vpurify_flag
)
2655 ? make_pure_string (str
, len
, len
, 0)
2656 : make_string (str
, len
)));
2659 DEFUN ("intern", Fintern
, Sintern
, 1, 2, 0,
2660 "Return the canonical symbol whose name is STRING.\n\
2661 If there is none, one is created by this function and returned.\n\
2662 A second optional argument specifies the obarray to use;\n\
2663 it defaults to the value of `obarray'.")
2665 Lisp_Object string
, obarray
;
2667 register Lisp_Object tem
, sym
, *ptr
;
2669 if (NILP (obarray
)) obarray
= Vobarray
;
2670 obarray
= check_obarray (obarray
);
2672 CHECK_STRING (string
, 0);
2674 tem
= oblookup (obarray
, XSTRING (string
)->data
,
2675 XSTRING (string
)->size
,
2676 STRING_BYTES (XSTRING (string
)));
2677 if (!INTEGERP (tem
))
2680 if (!NILP (Vpurify_flag
))
2681 string
= Fpurecopy (string
);
2682 sym
= Fmake_symbol (string
);
2683 XSYMBOL (sym
)->obarray
= obarray
;
2685 if ((XSTRING (string
)->data
[0] == ':')
2686 && EQ (obarray
, initial_obarray
))
2687 XSYMBOL (sym
)->value
= sym
;
2689 ptr
= &XVECTOR (obarray
)->contents
[XINT (tem
)];
2691 XSYMBOL (sym
)->next
= XSYMBOL (*ptr
);
2693 XSYMBOL (sym
)->next
= 0;
2698 DEFUN ("intern-soft", Fintern_soft
, Sintern_soft
, 1, 2, 0,
2699 "Return the canonical symbol named NAME, or nil if none exists.\n\
2700 NAME may be a string or a symbol. If it is a symbol, that exact\n\
2701 symbol is searched for.\n\
2702 A second optional argument specifies the obarray to use;\n\
2703 it defaults to the value of `obarray'.")
2705 Lisp_Object name
, obarray
;
2707 register Lisp_Object tem
;
2708 struct Lisp_String
*string
;
2710 if (NILP (obarray
)) obarray
= Vobarray
;
2711 obarray
= check_obarray (obarray
);
2713 if (!SYMBOLP (name
))
2715 CHECK_STRING (name
, 0);
2716 string
= XSTRING (name
);
2719 string
= XSYMBOL (name
)->name
;
2721 tem
= oblookup (obarray
, string
->data
, string
->size
, STRING_BYTES (string
));
2722 if (INTEGERP (tem
) || (SYMBOLP (name
) && !EQ (name
, tem
)))
2728 DEFUN ("unintern", Funintern
, Sunintern
, 1, 2, 0,
2729 "Delete the symbol named NAME, if any, from OBARRAY.\n\
2730 The value is t if a symbol was found and deleted, nil otherwise.\n\
2731 NAME may be a string or a symbol. If it is a symbol, that symbol\n\
2732 is deleted, if it belongs to OBARRAY--no other symbol is deleted.\n\
2733 OBARRAY defaults to the value of the variable `obarray'.")
2735 Lisp_Object name
, obarray
;
2737 register Lisp_Object string
, tem
;
2740 if (NILP (obarray
)) obarray
= Vobarray
;
2741 obarray
= check_obarray (obarray
);
2744 XSETSTRING (string
, XSYMBOL (name
)->name
);
2747 CHECK_STRING (name
, 0);
2751 tem
= oblookup (obarray
, XSTRING (string
)->data
,
2752 XSTRING (string
)->size
,
2753 STRING_BYTES (XSTRING (string
)));
2756 /* If arg was a symbol, don't delete anything but that symbol itself. */
2757 if (SYMBOLP (name
) && !EQ (name
, tem
))
2760 XSYMBOL (tem
)->obarray
= Qnil
;
2762 hash
= oblookup_last_bucket_number
;
2764 if (EQ (XVECTOR (obarray
)->contents
[hash
], tem
))
2766 if (XSYMBOL (tem
)->next
)
2767 XSETSYMBOL (XVECTOR (obarray
)->contents
[hash
], XSYMBOL (tem
)->next
);
2769 XSETINT (XVECTOR (obarray
)->contents
[hash
], 0);
2773 Lisp_Object tail
, following
;
2775 for (tail
= XVECTOR (obarray
)->contents
[hash
];
2776 XSYMBOL (tail
)->next
;
2779 XSETSYMBOL (following
, XSYMBOL (tail
)->next
);
2780 if (EQ (following
, tem
))
2782 XSYMBOL (tail
)->next
= XSYMBOL (following
)->next
;
2791 /* Return the symbol in OBARRAY whose names matches the string
2792 of SIZE characters (SIZE_BYTE bytes) at PTR.
2793 If there is no such symbol in OBARRAY, return nil.
2795 Also store the bucket number in oblookup_last_bucket_number. */
2798 oblookup (obarray
, ptr
, size
, size_byte
)
2799 Lisp_Object obarray
;
2801 int size
, size_byte
;
2805 register Lisp_Object tail
;
2806 Lisp_Object bucket
, tem
;
2808 if (!VECTORP (obarray
)
2809 || (obsize
= XVECTOR (obarray
)->size
) == 0)
2811 obarray
= check_obarray (obarray
);
2812 obsize
= XVECTOR (obarray
)->size
;
2814 /* This is sometimes needed in the middle of GC. */
2815 obsize
&= ~ARRAY_MARK_FLAG
;
2816 /* Combining next two lines breaks VMS C 2.3. */
2817 hash
= hash_string (ptr
, size_byte
);
2819 bucket
= XVECTOR (obarray
)->contents
[hash
];
2820 oblookup_last_bucket_number
= hash
;
2821 if (XFASTINT (bucket
) == 0)
2823 else if (!SYMBOLP (bucket
))
2824 error ("Bad data in guts of obarray"); /* Like CADR error message */
2826 for (tail
= bucket
; ; XSETSYMBOL (tail
, XSYMBOL (tail
)->next
))
2828 if (STRING_BYTES (XSYMBOL (tail
)->name
) == size_byte
2829 && XSYMBOL (tail
)->name
->size
== size
2830 && !bcmp (XSYMBOL (tail
)->name
->data
, ptr
, size_byte
))
2832 else if (XSYMBOL (tail
)->next
== 0)
2835 XSETINT (tem
, hash
);
2840 hash_string (ptr
, len
)
2844 register unsigned char *p
= ptr
;
2845 register unsigned char *end
= p
+ len
;
2846 register unsigned char c
;
2847 register int hash
= 0;
2852 if (c
>= 0140) c
-= 40;
2853 hash
= ((hash
<<3) + (hash
>>28) + c
);
2855 return hash
& 07777777777;
2859 map_obarray (obarray
, fn
, arg
)
2860 Lisp_Object obarray
;
2861 void (*fn
) P_ ((Lisp_Object
, Lisp_Object
));
2865 register Lisp_Object tail
;
2866 CHECK_VECTOR (obarray
, 1);
2867 for (i
= XVECTOR (obarray
)->size
- 1; i
>= 0; i
--)
2869 tail
= XVECTOR (obarray
)->contents
[i
];
2874 if (XSYMBOL (tail
)->next
== 0)
2876 XSETSYMBOL (tail
, XSYMBOL (tail
)->next
);
2882 mapatoms_1 (sym
, function
)
2883 Lisp_Object sym
, function
;
2885 call1 (function
, sym
);
2888 DEFUN ("mapatoms", Fmapatoms
, Smapatoms
, 1, 2, 0,
2889 "Call FUNCTION on every symbol in OBARRAY.\n\
2890 OBARRAY defaults to the value of `obarray'.")
2892 Lisp_Object function
, obarray
;
2894 if (NILP (obarray
)) obarray
= Vobarray
;
2895 obarray
= check_obarray (obarray
);
2897 map_obarray (obarray
, mapatoms_1
, function
);
2901 #define OBARRAY_SIZE 1511
2906 Lisp_Object oblength
;
2910 XSETFASTINT (oblength
, OBARRAY_SIZE
);
2912 Qnil
= Fmake_symbol (make_pure_string ("nil", 3, 3, 0));
2913 Vobarray
= Fmake_vector (oblength
, make_number (0));
2914 initial_obarray
= Vobarray
;
2915 staticpro (&initial_obarray
);
2916 /* Intern nil in the obarray */
2917 XSYMBOL (Qnil
)->obarray
= Vobarray
;
2918 /* These locals are to kludge around a pyramid compiler bug. */
2919 hash
= hash_string ("nil", 3);
2920 /* Separate statement here to avoid VAXC bug. */
2921 hash
%= OBARRAY_SIZE
;
2922 tem
= &XVECTOR (Vobarray
)->contents
[hash
];
2925 Qunbound
= Fmake_symbol (make_pure_string ("unbound", 7, 7, 0));
2926 XSYMBOL (Qnil
)->function
= Qunbound
;
2927 XSYMBOL (Qunbound
)->value
= Qunbound
;
2928 XSYMBOL (Qunbound
)->function
= Qunbound
;
2931 XSYMBOL (Qnil
)->value
= Qnil
;
2932 XSYMBOL (Qnil
)->plist
= Qnil
;
2933 XSYMBOL (Qt
)->value
= Qt
;
2935 /* Qt is correct even if CANNOT_DUMP. loadup.el will set to nil at end. */
2938 Qvariable_documentation
= intern ("variable-documentation");
2939 staticpro (&Qvariable_documentation
);
2941 read_buffer_size
= 100 + MAX_MULTIBYTE_LENGTH
;
2942 read_buffer
= (char *) malloc (read_buffer_size
);
2947 struct Lisp_Subr
*sname
;
2950 sym
= intern (sname
->symbol_name
);
2951 XSETSUBR (XSYMBOL (sym
)->function
, sname
);
2954 #ifdef NOTDEF /* use fset in subr.el now */
2956 defalias (sname
, string
)
2957 struct Lisp_Subr
*sname
;
2961 sym
= intern (string
);
2962 XSETSUBR (XSYMBOL (sym
)->function
, sname
);
2966 /* Define an "integer variable"; a symbol whose value is forwarded
2967 to a C variable of type int. Sample call: */
2968 /* DEFVAR_INT ("indent-tabs-mode", &indent_tabs_mode, "Documentation"); */
2970 defvar_int (namestring
, address
)
2974 Lisp_Object sym
, val
;
2975 sym
= intern (namestring
);
2976 val
= allocate_misc ();
2977 XMISCTYPE (val
) = Lisp_Misc_Intfwd
;
2978 XINTFWD (val
)->intvar
= address
;
2979 XSYMBOL (sym
)->value
= val
;
2982 /* Similar but define a variable whose value is T if address contains 1,
2983 NIL if address contains 0 */
2985 defvar_bool (namestring
, address
)
2989 Lisp_Object sym
, val
;
2990 sym
= intern (namestring
);
2991 val
= allocate_misc ();
2992 XMISCTYPE (val
) = Lisp_Misc_Boolfwd
;
2993 XBOOLFWD (val
)->boolvar
= address
;
2994 XSYMBOL (sym
)->value
= val
;
2995 Vbyte_boolean_vars
= Fcons (sym
, Vbyte_boolean_vars
);
2998 /* Similar but define a variable whose value is the Lisp Object stored
2999 at address. Two versions: with and without gc-marking of the C
3000 variable. The nopro version is used when that variable will be
3001 gc-marked for some other reason, since marking the same slot twice
3002 can cause trouble with strings. */
3004 defvar_lisp_nopro (namestring
, address
)
3006 Lisp_Object
*address
;
3008 Lisp_Object sym
, val
;
3009 sym
= intern (namestring
);
3010 val
= allocate_misc ();
3011 XMISCTYPE (val
) = Lisp_Misc_Objfwd
;
3012 XOBJFWD (val
)->objvar
= address
;
3013 XSYMBOL (sym
)->value
= val
;
3017 defvar_lisp (namestring
, address
)
3019 Lisp_Object
*address
;
3021 defvar_lisp_nopro (namestring
, address
);
3022 staticpro (address
);
3027 /* Similar but define a variable whose value is the Lisp Object stored in
3028 the current buffer. address is the address of the slot in the buffer
3029 that is current now. */
3032 defvar_per_buffer (namestring
, address
, type
, doc
)
3034 Lisp_Object
*address
;
3038 Lisp_Object sym
, val
;
3040 extern struct buffer buffer_local_symbols
;
3042 sym
= intern (namestring
);
3043 val
= allocate_misc ();
3044 offset
= (char *)address
- (char *)current_buffer
;
3046 XMISCTYPE (val
) = Lisp_Misc_Buffer_Objfwd
;
3047 XBUFFER_OBJFWD (val
)->offset
= offset
;
3048 XSYMBOL (sym
)->value
= val
;
3049 *(Lisp_Object
*)(offset
+ (char *)&buffer_local_symbols
) = sym
;
3050 *(Lisp_Object
*)(offset
+ (char *)&buffer_local_types
) = type
;
3051 if (XINT (*(Lisp_Object
*)(offset
+ (char *)&buffer_local_flags
)) == 0)
3052 /* Did a DEFVAR_PER_BUFFER without initializing the corresponding
3053 slot of buffer_local_flags */
3057 #endif /* standalone */
3059 /* Similar but define a variable whose value is the Lisp Object stored
3060 at a particular offset in the current kboard object. */
3063 defvar_kboard (namestring
, offset
)
3067 Lisp_Object sym
, val
;
3068 sym
= intern (namestring
);
3069 val
= allocate_misc ();
3070 XMISCTYPE (val
) = Lisp_Misc_Kboard_Objfwd
;
3071 XKBOARD_OBJFWD (val
)->offset
= offset
;
3072 XSYMBOL (sym
)->value
= val
;
3075 /* Record the value of load-path used at the start of dumping
3076 so we can see if the site changed it later during dumping. */
3077 static Lisp_Object dump_path
;
3083 int turn_off_warning
= 0;
3085 /* Compute the default load-path. */
3087 normal
= PATH_LOADSEARCH
;
3088 Vload_path
= decode_env_path (0, normal
);
3090 if (NILP (Vpurify_flag
))
3091 normal
= PATH_LOADSEARCH
;
3093 normal
= PATH_DUMPLOADSEARCH
;
3095 /* In a dumped Emacs, we normally have to reset the value of
3096 Vload_path from PATH_LOADSEARCH, since the value that was dumped
3097 uses ../lisp, instead of the path of the installed elisp
3098 libraries. However, if it appears that Vload_path was changed
3099 from the default before dumping, don't override that value. */
3102 if (! NILP (Fequal (dump_path
, Vload_path
)))
3104 Vload_path
= decode_env_path (0, normal
);
3105 if (!NILP (Vinstallation_directory
))
3107 /* Add to the path the lisp subdir of the
3108 installation dir, if it exists. */
3109 Lisp_Object tem
, tem1
;
3110 tem
= Fexpand_file_name (build_string ("lisp"),
3111 Vinstallation_directory
);
3112 tem1
= Ffile_exists_p (tem
);
3115 if (NILP (Fmember (tem
, Vload_path
)))
3117 turn_off_warning
= 1;
3118 Vload_path
= nconc2 (Vload_path
, Fcons (tem
, Qnil
));
3122 /* That dir doesn't exist, so add the build-time
3123 Lisp dirs instead. */
3124 Vload_path
= nconc2 (Vload_path
, dump_path
);
3126 /* Add leim under the installation dir, if it exists. */
3127 tem
= Fexpand_file_name (build_string ("leim"),
3128 Vinstallation_directory
);
3129 tem1
= Ffile_exists_p (tem
);
3132 if (NILP (Fmember (tem
, Vload_path
)))
3133 Vload_path
= nconc2 (Vload_path
, Fcons (tem
, Qnil
));
3136 /* Add site-list under the installation dir, if it exists. */
3137 tem
= Fexpand_file_name (build_string ("site-lisp"),
3138 Vinstallation_directory
);
3139 tem1
= Ffile_exists_p (tem
);
3142 if (NILP (Fmember (tem
, Vload_path
)))
3143 Vload_path
= nconc2 (Vload_path
, Fcons (tem
, Qnil
));
3146 /* If Emacs was not built in the source directory,
3147 and it is run from where it was built, add to load-path
3148 the lisp, leim and site-lisp dirs under that directory. */
3150 if (NILP (Fequal (Vinstallation_directory
, Vsource_directory
)))
3154 tem
= Fexpand_file_name (build_string ("src/Makefile"),
3155 Vinstallation_directory
);
3156 tem1
= Ffile_exists_p (tem
);
3158 /* Don't be fooled if they moved the entire source tree
3159 AFTER dumping Emacs. If the build directory is indeed
3160 different from the source dir, src/Makefile.in and
3161 src/Makefile will not be found together. */
3162 tem
= Fexpand_file_name (build_string ("src/Makefile.in"),
3163 Vinstallation_directory
);
3164 tem2
= Ffile_exists_p (tem
);
3165 if (!NILP (tem1
) && NILP (tem2
))
3167 tem
= Fexpand_file_name (build_string ("lisp"),
3170 if (NILP (Fmember (tem
, Vload_path
)))
3171 Vload_path
= nconc2 (Vload_path
, Fcons (tem
, Qnil
));
3173 tem
= Fexpand_file_name (build_string ("leim"),
3176 if (NILP (Fmember (tem
, Vload_path
)))
3177 Vload_path
= nconc2 (Vload_path
, Fcons (tem
, Qnil
));
3179 tem
= Fexpand_file_name (build_string ("site-lisp"),
3182 if (NILP (Fmember (tem
, Vload_path
)))
3183 Vload_path
= nconc2 (Vload_path
, Fcons (tem
, Qnil
));
3191 /* NORMAL refers to the lisp dir in the source directory. */
3192 /* We used to add ../lisp at the front here, but
3193 that caused trouble because it was copied from dump_path
3194 into Vload_path, aboe, when Vinstallation_directory was non-nil.
3195 It should be unnecessary. */
3196 Vload_path
= decode_env_path (0, normal
);
3197 dump_path
= Vload_path
;
3202 /* When Emacs is invoked over network shares on NT, PATH_LOADSEARCH is
3203 almost never correct, thereby causing a warning to be printed out that
3204 confuses users. Since PATH_LOADSEARCH is always overridden by the
3205 EMACSLOADPATH environment variable below, disable the warning on NT. */
3207 /* Warn if dirs in the *standard* path don't exist. */
3208 if (!turn_off_warning
)
3210 Lisp_Object path_tail
;
3212 for (path_tail
= Vload_path
;
3214 path_tail
= XCDR (path_tail
))
3216 Lisp_Object dirfile
;
3217 dirfile
= Fcar (path_tail
);
3218 if (STRINGP (dirfile
))
3220 dirfile
= Fdirectory_file_name (dirfile
);
3221 if (access (XSTRING (dirfile
)->data
, 0) < 0)
3222 dir_warning ("Warning: Lisp directory `%s' does not exist.\n",
3227 #endif /* WINDOWSNT */
3229 /* If the EMACSLOADPATH environment variable is set, use its value.
3230 This doesn't apply if we're dumping. */
3232 if (NILP (Vpurify_flag
)
3233 && egetenv ("EMACSLOADPATH"))
3235 Vload_path
= decode_env_path ("EMACSLOADPATH", normal
);
3239 load_in_progress
= 0;
3240 Vload_file_name
= Qnil
;
3242 load_descriptor_list
= Qnil
;
3244 Vstandard_input
= Qt
;
3247 /* Print a warning, using format string FORMAT, that directory DIRNAME
3248 does not exist. Print it on stderr and put it in *Message*. */
3251 dir_warning (format
, dirname
)
3253 Lisp_Object dirname
;
3256 = (char *) alloca (XSTRING (dirname
)->size
+ strlen (format
) + 5);
3258 fprintf (stderr
, format
, XSTRING (dirname
)->data
);
3259 sprintf (buffer
, format
, XSTRING (dirname
)->data
);
3260 /* Don't log the warning before we've initialized!! */
3262 message_dolog (buffer
, strlen (buffer
), 0, STRING_MULTIBYTE (dirname
));
3269 defsubr (&Sread_from_string
);
3271 defsubr (&Sintern_soft
);
3272 defsubr (&Sunintern
);
3274 defsubr (&Seval_buffer
);
3275 defsubr (&Seval_region
);
3276 defsubr (&Sread_char
);
3277 defsubr (&Sread_char_exclusive
);
3278 defsubr (&Sread_event
);
3279 defsubr (&Sget_file_char
);
3280 defsubr (&Smapatoms
);
3282 DEFVAR_LISP ("obarray", &Vobarray
,
3283 "Symbol table for use by `intern' and `read'.\n\
3284 It is a vector whose length ought to be prime for best results.\n\
3285 The vector's contents don't make sense if examined from Lisp programs;\n\
3286 to find all the symbols in an obarray, use `mapatoms'.");
3288 DEFVAR_LISP ("values", &Vvalues
,
3289 "List of values of all expressions which were read, evaluated and printed.\n\
3290 Order is reverse chronological.");
3292 DEFVAR_LISP ("standard-input", &Vstandard_input
,
3293 "Stream for read to get input from.\n\
3294 See documentation of `read' for possible values.");
3295 Vstandard_input
= Qt
;
3297 DEFVAR_LISP ("load-path", &Vload_path
,
3298 "*List of directories to search for files to load.\n\
3299 Each element is a string (directory name) or nil (try default directory).\n\
3300 Initialized based on EMACSLOADPATH environment variable, if any,\n\
3301 otherwise to default specified by file `epaths.h' when Emacs was built.");
3303 DEFVAR_BOOL ("load-in-progress", &load_in_progress
,
3304 "Non-nil iff inside of `load'.");
3306 DEFVAR_LISP ("after-load-alist", &Vafter_load_alist
,
3307 "An alist of expressions to be evalled when particular files are loaded.\n\
3308 Each element looks like (FILENAME FORMS...).\n\
3309 When `load' is run and the file-name argument is FILENAME,\n\
3310 the FORMS in the corresponding element are executed at the end of loading.\n\n\
3311 FILENAME must match exactly! Normally FILENAME is the name of a library,\n\
3312 with no directory specified, since that is how `load' is normally called.\n\
3313 An error in FORMS does not undo the load,\n\
3314 but does prevent execution of the rest of the FORMS.");
3315 Vafter_load_alist
= Qnil
;
3317 DEFVAR_LISP ("load-history", &Vload_history
,
3318 "Alist mapping source file names to symbols and features.\n\
3319 Each alist element is a list that starts with a file name,\n\
3320 except for one element (optional) that starts with nil and describes\n\
3321 definitions evaluated from buffers not visiting files.\n\
3322 The remaining elements of each list are symbols defined as functions\n\
3323 or variables, and cons cells `(provide . FEATURE)' and `(require . FEATURE)'.");
3324 Vload_history
= Qnil
;
3326 DEFVAR_LISP ("load-file-name", &Vload_file_name
,
3327 "Full name of file being loaded by `load'.");
3328 Vload_file_name
= Qnil
;
3330 DEFVAR_LISP ("user-init-file", &Vuser_init_file
,
3331 "File name, including directory, of user's initialization file.\n\
3332 If the file loaded had extension `.elc' and there was a corresponding `.el'\n\
3333 file, this variable contains the name of the .el file, suitable for use\n\
3334 by functions like `custom-save-all' which edit the init file.");
3335 Vuser_init_file
= Qnil
;
3337 DEFVAR_LISP ("current-load-list", &Vcurrent_load_list
,
3338 "Used for internal purposes by `load'.");
3339 Vcurrent_load_list
= Qnil
;
3341 DEFVAR_LISP ("load-read-function", &Vload_read_function
,
3342 "Function used by `load' and `eval-region' for reading expressions.\n\
3343 The default is nil, which means use the function `read'.");
3344 Vload_read_function
= Qnil
;
3346 DEFVAR_LISP ("load-source-file-function", &Vload_source_file_function
,
3347 "Function called in `load' for loading an Emacs lisp source file.\n\
3348 This function is for doing code conversion before reading the source file.\n\
3349 If nil, loading is done without any code conversion.\n\
3350 Arguments are FULLNAME, FILE, NOERROR, NOMESSAGE, where\n\
3351 FULLNAME is the full name of FILE.\n\
3352 See `load' for the meaning of the remaining arguments.");
3353 Vload_source_file_function
= Qnil
;
3355 DEFVAR_BOOL ("load-force-doc-strings", &load_force_doc_strings
,
3356 "Non-nil means `load' should force-load all dynamic doc strings.\n\
3357 This is useful when the file being loaded is a temporary copy.");
3358 load_force_doc_strings
= 0;
3360 DEFVAR_BOOL ("load-convert-to-unibyte", &load_convert_to_unibyte
,
3361 "Non-nil means `load' converts strings to unibyte whenever possible.\n\
3362 This is normally used in `load-with-code-conversion'\n\
3363 for loading non-compiled files.");
3364 load_convert_to_unibyte
= 0;
3366 DEFVAR_LISP ("source-directory", &Vsource_directory
,
3367 "Directory in which Emacs sources were found when Emacs was built.\n\
3368 You cannot count on them to still be there!");
3370 = Fexpand_file_name (build_string ("../"),
3371 Fcar (decode_env_path (0, PATH_DUMPLOADSEARCH
)));
3373 DEFVAR_LISP ("preloaded-file-list", &Vpreloaded_file_list
,
3374 "List of files that were preloaded (when dumping Emacs).");
3375 Vpreloaded_file_list
= Qnil
;
3377 DEFVAR_LISP ("byte-boolean-vars", &Vbyte_boolean_vars
,
3378 "List of all DEFVAR_BOOL variables, used by the byte code optimizer.");
3379 Vbyte_boolean_vars
= Qnil
;
3381 /* Vsource_directory was initialized in init_lread. */
3383 load_descriptor_list
= Qnil
;
3384 staticpro (&load_descriptor_list
);
3386 Qcurrent_load_list
= intern ("current-load-list");
3387 staticpro (&Qcurrent_load_list
);
3389 Qstandard_input
= intern ("standard-input");
3390 staticpro (&Qstandard_input
);
3392 Qread_char
= intern ("read-char");
3393 staticpro (&Qread_char
);
3395 Qget_file_char
= intern ("get-file-char");
3396 staticpro (&Qget_file_char
);
3398 Qbackquote
= intern ("`");
3399 staticpro (&Qbackquote
);
3400 Qcomma
= intern (",");
3401 staticpro (&Qcomma
);
3402 Qcomma_at
= intern (",@");
3403 staticpro (&Qcomma_at
);
3404 Qcomma_dot
= intern (",.");
3405 staticpro (&Qcomma_dot
);
3407 Qinhibit_file_name_operation
= intern ("inhibit-file-name-operation");
3408 staticpro (&Qinhibit_file_name_operation
);
3410 Qascii_character
= intern ("ascii-character");
3411 staticpro (&Qascii_character
);
3413 Qfunction
= intern ("function");
3414 staticpro (&Qfunction
);
3416 Qload
= intern ("load");
3419 Qload_file_name
= intern ("load-file-name");
3420 staticpro (&Qload_file_name
);
3422 staticpro (&dump_path
);
3424 staticpro (&read_objects
);
3425 read_objects
= Qnil
;
3426 staticpro (&seen_list
);