1 /* Lisp parsing and input streams.
2 Copyright (C) 1985, 1986, 1987, 1988, 1989, 1993, 1994, 1995,
3 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
4 2005, 2006, 2007 Free Software Foundation, Inc.
6 This file is part of GNU Emacs.
8 GNU Emacs is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 3, or (at your option)
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs; see the file COPYING. If not, write to
20 the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
21 Boston, MA 02110-1301, USA. */
26 #include <sys/types.h>
31 #include "intervals.h"
37 #include "termhooks.h"
39 #include "blockinput.h"
42 #include <sys/inode.h>
47 #include <unistd.h> /* to get X_OK */
64 #endif /* HAVE_SETLOCALE */
74 #define file_offset off_t
75 #define file_tell ftello
77 #define file_offset long
78 #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
;
90 Lisp_Object Qeval_buffer_list
, Veval_buffer_list
;
91 Lisp_Object Qfile_truename
, Qdo_after_load_evaluation
; /* ACM 2006/5/16 */
93 extern Lisp_Object Qevent_symbol_element_mask
;
94 extern Lisp_Object Qfile_exists_p
;
96 /* non-zero if inside `load' */
99 /* Directory in which the sources were found. */
100 Lisp_Object Vsource_directory
;
102 /* Search path and suffixes for files to be loaded. */
103 Lisp_Object Vload_path
, Vload_suffixes
, Vload_file_rep_suffixes
;
105 /* File name of user's init file. */
106 Lisp_Object Vuser_init_file
;
108 /* This is the user-visible association list that maps features to
109 lists of defs in their load files. */
110 Lisp_Object Vload_history
;
112 /* This is used to build the load history. */
113 Lisp_Object Vcurrent_load_list
;
115 /* List of files that were preloaded. */
116 Lisp_Object Vpreloaded_file_list
;
118 /* Name of file actually being read by `load'. */
119 Lisp_Object Vload_file_name
;
121 /* Function to use for reading, in `load' and friends. */
122 Lisp_Object Vload_read_function
;
124 /* The association list of objects read with the #n=object form.
125 Each member of the list has the form (n . object), and is used to
126 look up the object for the corresponding #n# construct.
127 It must be set to nil before all top-level calls to read0. */
128 Lisp_Object read_objects
;
130 /* Nonzero means load should forcibly load all dynamic doc strings. */
131 static int load_force_doc_strings
;
133 /* Nonzero means read should convert strings to unibyte. */
134 static int load_convert_to_unibyte
;
136 /* Function to use for loading an Emacs Lisp source file (not
137 compiled) instead of readevalloop. */
138 Lisp_Object Vload_source_file_function
;
140 /* List of all DEFVAR_BOOL variables. Used by the byte optimizer. */
141 Lisp_Object Vbyte_boolean_vars
;
143 /* Whether or not to add a `read-positions' property to symbols
145 Lisp_Object Vread_with_symbol_positions
;
147 /* List of (SYMBOL . POSITION) accumulated so far. */
148 Lisp_Object Vread_symbol_positions_list
;
150 /* List of descriptors now open for Fload. */
151 static Lisp_Object load_descriptor_list
;
153 /* File for get_file_char to read from. Use by load. */
154 static FILE *instream
;
156 /* When nonzero, read conses in pure space */
157 static int read_pure
;
159 /* For use within read-from-string (this reader is non-reentrant!!) */
160 static int read_from_string_index
;
161 static int read_from_string_index_byte
;
162 static int read_from_string_limit
;
164 /* Number of bytes left to read in the buffer character
165 that `readchar' has already advanced over. */
166 static int readchar_backlog
;
167 /* Number of characters read in the current call to Fread or
168 Fread_from_string. */
169 static int readchar_count
;
171 /* This contains the last string skipped with #@. */
172 static char *saved_doc_string
;
173 /* Length of buffer allocated in saved_doc_string. */
174 static int saved_doc_string_size
;
175 /* Length of actual data in saved_doc_string. */
176 static int saved_doc_string_length
;
177 /* This is the file position that string came from. */
178 static file_offset saved_doc_string_position
;
180 /* This contains the previous string skipped with #@.
181 We copy it from saved_doc_string when a new string
182 is put in saved_doc_string. */
183 static char *prev_saved_doc_string
;
184 /* Length of buffer allocated in prev_saved_doc_string. */
185 static int prev_saved_doc_string_size
;
186 /* Length of actual data in prev_saved_doc_string. */
187 static int prev_saved_doc_string_length
;
188 /* This is the file position that string came from. */
189 static file_offset prev_saved_doc_string_position
;
191 /* Nonzero means inside a new-style backquote
192 with no surrounding parentheses.
193 Fread initializes this to zero, so we need not specbind it
194 or worry about what happens to it when there is an error. */
195 static int new_backquote_flag
;
196 static Lisp_Object Vold_style_backquotes
;
198 /* A list of file names for files being loaded in Fload. Used to
199 check for recursive loads. */
201 static Lisp_Object Vloads_in_progress
;
203 /* Non-zero means load dangerous compiled Lisp files. */
205 int load_dangerous_libraries
;
207 /* A regular expression used to detect files compiled with Emacs. */
209 static Lisp_Object Vbytecomp_version_regexp
;
211 static void to_multibyte
P_ ((char **, char **, int *));
212 static void readevalloop
P_ ((Lisp_Object
, FILE*, Lisp_Object
,
213 Lisp_Object (*) (), int,
214 Lisp_Object
, Lisp_Object
,
215 Lisp_Object
, Lisp_Object
));
216 static Lisp_Object load_unwind
P_ ((Lisp_Object
));
217 static Lisp_Object load_descriptor_unwind
P_ ((Lisp_Object
));
219 static void invalid_syntax
P_ ((const char *, int)) NO_RETURN
;
220 static void end_of_file_error
P_ (()) NO_RETURN
;
223 /* Handle unreading and rereading of characters.
224 Write READCHAR to read a character,
225 UNREAD(c) to unread c to be read again.
227 The READCHAR and UNREAD macros are meant for reading/unreading a
228 byte code; they do not handle multibyte characters. The caller
229 should manage them if necessary.
231 [ Actually that seems to be a lie; READCHAR will definitely read
232 multibyte characters from buffer sources, at least. Is the
233 comment just out of date?
234 -- Colin Walters <walters@gnu.org>, 22 May 2002 16:36:50 -0400 ]
237 #define READCHAR readchar (readcharfun)
238 #define UNREAD(c) unreadchar (readcharfun, c)
241 readchar (readcharfun
)
242 Lisp_Object readcharfun
;
249 if (BUFFERP (readcharfun
))
251 register struct buffer
*inbuffer
= XBUFFER (readcharfun
);
253 int pt_byte
= BUF_PT_BYTE (inbuffer
);
254 int orig_pt_byte
= pt_byte
;
256 if (readchar_backlog
> 0)
257 /* We get the address of the byte just passed,
258 which is the last byte of the character.
259 The other bytes in this character are consecutive with it,
260 because the gap can't be in the middle of a character. */
261 return *(BUF_BYTE_ADDRESS (inbuffer
, BUF_PT_BYTE (inbuffer
) - 1)
262 - --readchar_backlog
);
264 if (pt_byte
>= BUF_ZV_BYTE (inbuffer
))
267 readchar_backlog
= -1;
269 if (! NILP (inbuffer
->enable_multibyte_characters
))
271 /* Fetch the character code from the buffer. */
272 unsigned char *p
= BUF_BYTE_ADDRESS (inbuffer
, pt_byte
);
273 BUF_INC_POS (inbuffer
, pt_byte
);
274 c
= STRING_CHAR (p
, pt_byte
- orig_pt_byte
);
278 c
= BUF_FETCH_BYTE (inbuffer
, pt_byte
);
281 SET_BUF_PT_BOTH (inbuffer
, BUF_PT (inbuffer
) + 1, pt_byte
);
285 if (MARKERP (readcharfun
))
287 register struct buffer
*inbuffer
= XMARKER (readcharfun
)->buffer
;
289 int bytepos
= marker_byte_position (readcharfun
);
290 int orig_bytepos
= bytepos
;
292 if (readchar_backlog
> 0)
293 /* We get the address of the byte just passed,
294 which is the last byte of the character.
295 The other bytes in this character are consecutive with it,
296 because the gap can't be in the middle of a character. */
297 return *(BUF_BYTE_ADDRESS (inbuffer
, XMARKER (readcharfun
)->bytepos
- 1)
298 - --readchar_backlog
);
300 if (bytepos
>= BUF_ZV_BYTE (inbuffer
))
303 readchar_backlog
= -1;
305 if (! NILP (inbuffer
->enable_multibyte_characters
))
307 /* Fetch the character code from the buffer. */
308 unsigned char *p
= BUF_BYTE_ADDRESS (inbuffer
, bytepos
);
309 BUF_INC_POS (inbuffer
, bytepos
);
310 c
= STRING_CHAR (p
, bytepos
- orig_bytepos
);
314 c
= BUF_FETCH_BYTE (inbuffer
, bytepos
);
318 XMARKER (readcharfun
)->bytepos
= bytepos
;
319 XMARKER (readcharfun
)->charpos
++;
324 if (EQ (readcharfun
, Qlambda
))
325 return read_bytecode_char (0);
327 if (EQ (readcharfun
, Qget_file_char
))
332 /* Interrupted reads have been observed while reading over the network */
333 while (c
== EOF
&& ferror (instream
) && errno
== EINTR
)
346 if (STRINGP (readcharfun
))
348 if (read_from_string_index
>= read_from_string_limit
)
351 FETCH_STRING_CHAR_ADVANCE (c
, readcharfun
,
352 read_from_string_index
,
353 read_from_string_index_byte
);
358 tem
= call0 (readcharfun
);
365 /* Unread the character C in the way appropriate for the stream READCHARFUN.
366 If the stream is a user function, call it with the char as argument. */
369 unreadchar (readcharfun
, c
)
370 Lisp_Object readcharfun
;
375 /* Don't back up the pointer if we're unreading the end-of-input mark,
376 since readchar didn't advance it when we read it. */
378 else if (BUFFERP (readcharfun
))
380 struct buffer
*b
= XBUFFER (readcharfun
);
381 int bytepos
= BUF_PT_BYTE (b
);
383 if (readchar_backlog
>= 0)
388 if (! NILP (b
->enable_multibyte_characters
))
389 BUF_DEC_POS (b
, bytepos
);
393 BUF_PT_BYTE (b
) = bytepos
;
396 else if (MARKERP (readcharfun
))
398 struct buffer
*b
= XMARKER (readcharfun
)->buffer
;
399 int bytepos
= XMARKER (readcharfun
)->bytepos
;
401 if (readchar_backlog
>= 0)
405 XMARKER (readcharfun
)->charpos
--;
406 if (! NILP (b
->enable_multibyte_characters
))
407 BUF_DEC_POS (b
, bytepos
);
411 XMARKER (readcharfun
)->bytepos
= bytepos
;
414 else if (STRINGP (readcharfun
))
416 read_from_string_index
--;
417 read_from_string_index_byte
418 = string_char_to_byte (readcharfun
, read_from_string_index
);
420 else if (EQ (readcharfun
, Qlambda
))
421 read_bytecode_char (1);
422 else if (EQ (readcharfun
, Qget_file_char
))
425 ungetc (c
, instream
);
429 call1 (readcharfun
, make_number (c
));
432 static Lisp_Object read_internal_start
P_ ((Lisp_Object
, Lisp_Object
,
434 static Lisp_Object read0
P_ ((Lisp_Object
));
435 static Lisp_Object read1
P_ ((Lisp_Object
, int *, int));
437 static Lisp_Object read_list
P_ ((int, Lisp_Object
));
438 static Lisp_Object read_vector
P_ ((Lisp_Object
, int));
439 static int read_multibyte
P_ ((int, Lisp_Object
));
441 static Lisp_Object substitute_object_recurse
P_ ((Lisp_Object
, Lisp_Object
,
443 static void substitute_object_in_subtree
P_ ((Lisp_Object
,
445 static void substitute_in_interval
P_ ((INTERVAL
, Lisp_Object
));
448 /* Get a character from the tty. */
450 extern Lisp_Object
read_char ();
452 /* Read input events until we get one that's acceptable for our purposes.
454 If NO_SWITCH_FRAME is non-zero, switch-frame events are stashed
455 until we get a character we like, and then stuffed into
458 If ASCII_REQUIRED is non-zero, we check function key events to see
459 if the unmodified version of the symbol has a Qascii_character
460 property, and use that character, if present.
462 If ERROR_NONASCII is non-zero, we signal an error if the input we
463 get isn't an ASCII character with modifiers. If it's zero but
464 ASCII_REQUIRED is non-zero, we just re-read until we get an ASCII
467 If INPUT_METHOD is nonzero, we invoke the current input method
468 if the character warrants that.
470 If SECONDS is a number, we wait that many seconds for input, and
471 return Qnil if no input arrives within that time. */
474 read_filtered_event (no_switch_frame
, ascii_required
, error_nonascii
,
475 input_method
, seconds
)
476 int no_switch_frame
, ascii_required
, error_nonascii
, input_method
;
479 Lisp_Object val
, delayed_switch_frame
;
482 #ifdef HAVE_WINDOW_SYSTEM
483 if (display_hourglass_p
)
487 delayed_switch_frame
= Qnil
;
489 /* Compute timeout. */
490 if (NUMBERP (seconds
))
492 EMACS_TIME wait_time
;
494 double duration
= extract_float (seconds
);
496 sec
= (int) duration
;
497 usec
= (duration
- sec
) * 1000000;
498 EMACS_GET_TIME (end_time
);
499 EMACS_SET_SECS_USECS (wait_time
, sec
, usec
);
500 EMACS_ADD_TIME (end_time
, end_time
, wait_time
);
503 /* Read until we get an acceptable event. */
505 val
= read_char (0, 0, 0, (input_method
? Qnil
: Qt
), 0,
506 NUMBERP (seconds
) ? &end_time
: NULL
);
511 /* switch-frame events are put off until after the next ASCII
512 character. This is better than signaling an error just because
513 the last characters were typed to a separate minibuffer frame,
514 for example. Eventually, some code which can deal with
515 switch-frame events will read it and process it. */
517 && EVENT_HAS_PARAMETERS (val
)
518 && EQ (EVENT_HEAD_KIND (EVENT_HEAD (val
)), Qswitch_frame
))
520 delayed_switch_frame
= val
;
524 if (ascii_required
&& !(NUMBERP (seconds
) && NILP (val
)))
526 /* Convert certain symbols to their ASCII equivalents. */
529 Lisp_Object tem
, tem1
;
530 tem
= Fget (val
, Qevent_symbol_element_mask
);
533 tem1
= Fget (Fcar (tem
), Qascii_character
);
534 /* Merge this symbol's modifier bits
535 with the ASCII equivalent of its basic code. */
537 XSETFASTINT (val
, XINT (tem1
) | XINT (Fcar (Fcdr (tem
))));
541 /* If we don't have a character now, deal with it appropriately. */
546 Vunread_command_events
= Fcons (val
, Qnil
);
547 error ("Non-character input-event");
554 if (! NILP (delayed_switch_frame
))
555 unread_switch_frame
= delayed_switch_frame
;
559 #ifdef HAVE_WINDOW_SYSTEM
560 if (display_hourglass_p
)
569 DEFUN ("read-char", Fread_char
, Sread_char
, 0, 3, 0,
570 doc
: /* Read a character from the command input (keyboard or macro).
571 It is returned as a number.
572 If the user generates an event which is not a character (i.e. a mouse
573 click or function key event), `read-char' signals an error. As an
574 exception, switch-frame events are put off until non-ASCII events can
576 If you want to read non-character events, or ignore them, call
577 `read-event' or `read-char-exclusive' instead.
579 If the optional argument PROMPT is non-nil, display that as a prompt.
580 If the optional argument INHERIT-INPUT-METHOD is non-nil and some
581 input method is turned on in the current buffer, that input method
582 is used for reading a character.
583 If the optional argument SECONDS is non-nil, it should be a number
584 specifying the maximum number of seconds to wait for input. If no
585 input arrives in that time, return nil. SECONDS may be a
586 floating-point value. */)
587 (prompt
, inherit_input_method
, seconds
)
588 Lisp_Object prompt
, inherit_input_method
, seconds
;
591 message_with_string ("%s", prompt
, 0);
592 return read_filtered_event (1, 1, 1, ! NILP (inherit_input_method
), seconds
);
595 DEFUN ("read-event", Fread_event
, Sread_event
, 0, 3, 0,
596 doc
: /* Read an event object from the input stream.
597 If the optional argument PROMPT is non-nil, display that as a prompt.
598 If the optional argument INHERIT-INPUT-METHOD is non-nil and some
599 input method is turned on in the current buffer, that input method
600 is used for reading a character.
601 If the optional argument SECONDS is non-nil, it should be a number
602 specifying the maximum number of seconds to wait for input. If no
603 input arrives in that time, return nil. SECONDS may be a
604 floating-point value. */)
605 (prompt
, inherit_input_method
, seconds
)
606 Lisp_Object prompt
, inherit_input_method
, seconds
;
609 message_with_string ("%s", prompt
, 0);
610 return read_filtered_event (0, 0, 0, ! NILP (inherit_input_method
), seconds
);
613 DEFUN ("read-char-exclusive", Fread_char_exclusive
, Sread_char_exclusive
, 0, 3, 0,
614 doc
: /* Read a character from the command input (keyboard or macro).
615 It is returned as a number. Non-character events are ignored.
617 If the optional argument PROMPT is non-nil, display that as a prompt.
618 If the optional argument INHERIT-INPUT-METHOD is non-nil and some
619 input method is turned on in the current buffer, that input method
620 is used for reading a character.
621 If the optional argument SECONDS is non-nil, it should be a number
622 specifying the maximum number of seconds to wait for input. If no
623 input arrives in that time, return nil. SECONDS may be a
624 floating-point value. */)
625 (prompt
, inherit_input_method
, seconds
)
626 Lisp_Object prompt
, inherit_input_method
, seconds
;
629 message_with_string ("%s", prompt
, 0);
630 return read_filtered_event (1, 1, 0, ! NILP (inherit_input_method
), seconds
);
633 DEFUN ("get-file-char", Fget_file_char
, Sget_file_char
, 0, 0, 0,
634 doc
: /* Don't use this yourself. */)
637 register Lisp_Object val
;
639 XSETINT (val
, getc (instream
));
646 /* Value is non-zero if the file asswociated with file descriptor FD
647 is a compiled Lisp file that's safe to load. Only files compiled
648 with Emacs are safe to load. Files compiled with XEmacs can lead
649 to a crash in Fbyte_code because of an incompatible change in the
660 /* Read the first few bytes from the file, and look for a line
661 specifying the byte compiler version used. */
662 nbytes
= emacs_read (fd
, buf
, sizeof buf
- 1);
667 /* Skip to the next newline, skipping over the initial `ELC'
668 with NUL bytes following it. */
669 for (i
= 0; i
< nbytes
&& buf
[i
] != '\n'; ++i
)
673 && fast_c_string_match_ignore_case (Vbytecomp_version_regexp
,
678 lseek (fd
, 0, SEEK_SET
);
683 /* Callback for record_unwind_protect. Restore the old load list OLD,
684 after loading a file successfully. */
687 record_load_unwind (old
)
690 return Vloads_in_progress
= old
;
693 /* This handler function is used via internal_condition_case_1. */
696 load_error_handler (data
)
702 DEFUN ("get-load-suffixes", Fget_load_suffixes
, Sget_load_suffixes
, 0, 0, 0,
703 doc
: /* Return the suffixes that `load' should try if a suffix is \
705 This uses the variables `load-suffixes' and `load-file-rep-suffixes'. */)
708 Lisp_Object lst
= Qnil
, suffixes
= Vload_suffixes
, suffix
, ext
;
709 while (CONSP (suffixes
))
711 Lisp_Object exts
= Vload_file_rep_suffixes
;
712 suffix
= XCAR (suffixes
);
713 suffixes
= XCDR (suffixes
);
718 lst
= Fcons (concat2 (suffix
, ext
), lst
);
721 return Fnreverse (lst
);
724 DEFUN ("load", Fload
, Sload
, 1, 5, 0,
725 doc
: /* Execute a file of Lisp code named FILE.
726 First try FILE with `.elc' appended, then try with `.el',
727 then try FILE unmodified (the exact suffixes in the exact order are
728 determined by `load-suffixes'). Environment variable references in
729 FILE are replaced with their values by calling `substitute-in-file-name'.
730 This function searches the directories in `load-path'.
732 If optional second arg NOERROR is non-nil,
733 report no error if FILE doesn't exist.
734 Print messages at start and end of loading unless
735 optional third arg NOMESSAGE is non-nil.
736 If optional fourth arg NOSUFFIX is non-nil, don't try adding
737 suffixes `.elc' or `.el' to the specified name FILE.
738 If optional fifth arg MUST-SUFFIX is non-nil, insist on
739 the suffix `.elc' or `.el'; don't accept just FILE unless
740 it ends in one of those suffixes or includes a directory name.
742 If this function fails to find a file, it may look for different
743 representations of that file before trying another file.
744 It does so by adding the non-empty suffixes in `load-file-rep-suffixes'
745 to the file name. Emacs uses this feature mainly to find compressed
746 versions of files when Auto Compression mode is enabled.
748 The exact suffixes that this function tries out, in the exact order,
749 are given by the value of the variable `load-file-rep-suffixes' if
750 NOSUFFIX is non-nil and by the return value of the function
751 `get-load-suffixes' if MUST-SUFFIX is non-nil. If both NOSUFFIX and
752 MUST-SUFFIX are nil, this function first tries out the latter suffixes
755 Loading a file records its definitions, and its `provide' and
756 `require' calls, in an element of `load-history' whose
757 car is the file name loaded. See `load-history'.
759 Return t if the file exists and loads successfully. */)
760 (file
, noerror
, nomessage
, nosuffix
, must_suffix
)
761 Lisp_Object file
, noerror
, nomessage
, nosuffix
, must_suffix
;
763 register FILE *stream
;
764 register int fd
= -1;
765 int count
= SPECPDL_INDEX ();
767 struct gcpro gcpro1
, gcpro2
, gcpro3
;
768 Lisp_Object found
, efound
, hist_file_name
;
769 /* 1 means we printed the ".el is newer" message. */
771 /* 1 means we are loading a compiled file. */
783 /* If file name is magic, call the handler. */
784 /* This shouldn't be necessary any more now that `openp' handles it right.
785 handler = Ffind_file_name_handler (file, Qload);
787 return call5 (handler, Qload, file, noerror, nomessage, nosuffix); */
789 /* Do this after the handler to avoid
790 the need to gcpro noerror, nomessage and nosuffix.
791 (Below here, we care only whether they are nil or not.)
792 The presence of this call is the result of a historical accident:
793 it used to be in every file-operation and when it got removed
794 everywhere, it accidentally stayed here. Since then, enough people
795 supposedly have things like (load "$PROJECT/foo.el") in their .emacs
796 that it seemed risky to remove. */
797 if (! NILP (noerror
))
799 file
= internal_condition_case_1 (Fsubstitute_in_file_name
, file
,
800 Qt
, load_error_handler
);
805 file
= Fsubstitute_in_file_name (file
);
808 /* Avoid weird lossage with null string as arg,
809 since it would try to load a directory as a Lisp file */
810 if (SCHARS (file
) > 0)
812 int size
= SBYTES (file
);
815 GCPRO2 (file
, found
);
817 if (! NILP (must_suffix
))
819 /* Don't insist on adding a suffix if FILE already ends with one. */
821 && !strcmp (SDATA (file
) + size
- 3, ".el"))
824 && !strcmp (SDATA (file
) + size
- 4, ".elc"))
826 /* Don't insist on adding a suffix
827 if the argument includes a directory name. */
828 else if (! NILP (Ffile_name_directory (file
)))
832 fd
= openp (Vload_path
, file
,
833 (!NILP (nosuffix
) ? Qnil
834 : !NILP (must_suffix
) ? Fget_load_suffixes ()
835 : Fappend (2, (tmp
[0] = Fget_load_suffixes (),
836 tmp
[1] = Vload_file_rep_suffixes
,
845 xsignal2 (Qfile_error
, build_string ("Cannot open load file"), file
);
849 /* Tell startup.el whether or not we found the user's init file. */
850 if (EQ (Qt
, Vuser_init_file
))
851 Vuser_init_file
= found
;
853 /* If FD is -2, that means openp found a magic file. */
856 if (NILP (Fequal (found
, file
)))
857 /* If FOUND is a different file name from FILE,
858 find its handler even if we have already inhibited
859 the `load' operation on FILE. */
860 handler
= Ffind_file_name_handler (found
, Qt
);
862 handler
= Ffind_file_name_handler (found
, Qload
);
863 if (! NILP (handler
))
864 return call5 (handler
, Qload
, found
, noerror
, nomessage
, Qt
);
867 /* Check if we're stuck in a recursive load cycle.
869 2000-09-21: It's not possible to just check for the file loaded
870 being a member of Vloads_in_progress. This fails because of the
871 way the byte compiler currently works; `provide's are not
872 evaluted, see font-lock.el/jit-lock.el as an example. This
873 leads to a certain amount of ``normal'' recursion.
875 Also, just loading a file recursively is not always an error in
876 the general case; the second load may do something different. */
880 for (tem
= Vloads_in_progress
; CONSP (tem
); tem
= XCDR (tem
))
881 if (!NILP (Fequal (found
, XCAR (tem
))))
887 signal_error ("Recursive load", Fcons (found
, Vloads_in_progress
));
889 record_unwind_protect (record_load_unwind
, Vloads_in_progress
);
890 Vloads_in_progress
= Fcons (found
, Vloads_in_progress
);
893 /* Get the name for load-history. */
894 hist_file_name
= (! NILP (Vpurify_flag
)
895 ? Fconcat (2, (tmp
[0] = Ffile_name_directory (file
),
896 tmp
[1] = Ffile_name_nondirectory (found
),
900 if (!bcmp (SDATA (found
) + SBYTES (found
) - 4,
902 /* Load .elc files directly, but not when they are
903 remote and have no handler! */
910 GCPRO3 (file
, found
, hist_file_name
);
912 if (!safe_to_load_p (fd
))
915 if (!load_dangerous_libraries
)
919 error ("File `%s' was not compiled in Emacs",
922 else if (!NILP (nomessage
))
923 message_with_string ("File `%s' not compiled in Emacs", found
, 1);
928 efound
= ENCODE_FILE (found
);
933 stat ((char *)SDATA (efound
), &s1
);
934 SSET (efound
, SBYTES (efound
) - 1, 0);
935 result
= stat ((char *)SDATA (efound
), &s2
);
936 SSET (efound
, SBYTES (efound
) - 1, 'c');
938 if (result
>= 0 && (unsigned) s1
.st_mtime
< (unsigned) s2
.st_mtime
)
940 /* Make the progress messages mention that source is newer. */
943 /* If we won't print another message, mention this anyway. */
944 if (!NILP (nomessage
))
946 Lisp_Object msg_file
;
947 msg_file
= Fsubstring (found
, make_number (0), make_number (-1));
948 message_with_string ("Source file `%s' newer than byte-compiled file",
957 /* We are loading a source file (*.el). */
958 if (!NILP (Vload_source_file_function
))
964 val
= call4 (Vload_source_file_function
, found
, hist_file_name
,
965 NILP (noerror
) ? Qnil
: Qt
,
966 NILP (nomessage
) ? Qnil
: Qt
);
967 return unbind_to (count
, val
);
971 GCPRO3 (file
, found
, hist_file_name
);
975 efound
= ENCODE_FILE (found
);
976 stream
= fopen ((char *) SDATA (efound
), fmode
);
977 #else /* not WINDOWSNT */
978 stream
= fdopen (fd
, fmode
);
979 #endif /* not WINDOWSNT */
983 error ("Failure to create stdio stream for %s", SDATA (file
));
986 if (! NILP (Vpurify_flag
))
987 Vpreloaded_file_list
= Fcons (file
, Vpreloaded_file_list
);
989 if (NILP (nomessage
))
992 message_with_string ("Loading %s (compiled; note unsafe, not compiled in Emacs)...",
995 message_with_string ("Loading %s (source)...", file
, 1);
997 message_with_string ("Loading %s (compiled; note, source file is newer)...",
999 else /* The typical case; compiled file newer than source file. */
1000 message_with_string ("Loading %s...", file
, 1);
1003 record_unwind_protect (load_unwind
, make_save_value (stream
, 0));
1004 record_unwind_protect (load_descriptor_unwind
, load_descriptor_list
);
1005 specbind (Qload_file_name
, found
);
1006 specbind (Qinhibit_file_name_operation
, Qnil
);
1007 load_descriptor_list
1008 = Fcons (make_number (fileno (stream
)), load_descriptor_list
);
1010 readevalloop (Qget_file_char
, stream
, hist_file_name
,
1011 Feval
, 0, Qnil
, Qnil
, Qnil
, Qnil
);
1012 unbind_to (count
, Qnil
);
1014 /* Run any eval-after-load forms for this file */
1015 if (NILP (Vpurify_flag
)
1016 && (!NILP (Ffboundp (Qdo_after_load_evaluation
))))
1017 call1 (Qdo_after_load_evaluation
, hist_file_name
) ;
1021 if (saved_doc_string
)
1022 free (saved_doc_string
);
1023 saved_doc_string
= 0;
1024 saved_doc_string_size
= 0;
1026 if (prev_saved_doc_string
)
1027 xfree (prev_saved_doc_string
);
1028 prev_saved_doc_string
= 0;
1029 prev_saved_doc_string_size
= 0;
1031 if (!noninteractive
&& NILP (nomessage
))
1034 message_with_string ("Loading %s (compiled; note unsafe, not compiled in Emacs)...done",
1037 message_with_string ("Loading %s (source)...done", file
, 1);
1039 message_with_string ("Loading %s (compiled; note, source file is newer)...done",
1041 else /* The typical case; compiled file newer than source file. */
1042 message_with_string ("Loading %s...done", file
, 1);
1045 if (!NILP (Fequal (build_string ("obsolete"),
1046 Ffile_name_nondirectory
1047 (Fdirectory_file_name (Ffile_name_directory (found
))))))
1048 message_with_string ("Package %s is obsolete", file
, 1);
1054 load_unwind (arg
) /* used as unwind-protect function in load */
1057 FILE *stream
= (FILE *) XSAVE_VALUE (arg
)->pointer
;
1064 if (--load_in_progress
< 0) load_in_progress
= 0;
1069 load_descriptor_unwind (oldlist
)
1070 Lisp_Object oldlist
;
1072 load_descriptor_list
= oldlist
;
1076 /* Close all descriptors in use for Floads.
1077 This is used when starting a subprocess. */
1084 for (tail
= load_descriptor_list
; !NILP (tail
); tail
= XCDR (tail
))
1085 emacs_close (XFASTINT (XCAR (tail
)));
1090 complete_filename_p (pathname
)
1091 Lisp_Object pathname
;
1093 register const unsigned char *s
= SDATA (pathname
);
1094 return (IS_DIRECTORY_SEP (s
[0])
1095 || (SCHARS (pathname
) > 2
1096 && IS_DEVICE_SEP (s
[1]) && IS_DIRECTORY_SEP (s
[2]))
1106 DEFUN ("locate-file-internal", Flocate_file_internal
, Slocate_file_internal
, 2, 4, 0,
1107 doc
: /* Search for FILENAME through PATH.
1108 Returns the file's name in absolute form, or nil if not found.
1109 If SUFFIXES is non-nil, it should be a list of suffixes to append to
1110 file name when searching.
1111 If non-nil, PREDICATE is used instead of `file-readable-p'.
1112 PREDICATE can also be an integer to pass to the access(2) function,
1113 in which case file-name-handlers are ignored. */)
1114 (filename
, path
, suffixes
, predicate
)
1115 Lisp_Object filename
, path
, suffixes
, predicate
;
1118 int fd
= openp (path
, filename
, suffixes
, &file
, predicate
);
1119 if (NILP (predicate
) && fd
> 0)
1125 /* Search for a file whose name is STR, looking in directories
1126 in the Lisp list PATH, and trying suffixes from SUFFIX.
1127 On success, returns a file descriptor. On failure, returns -1.
1129 SUFFIXES is a list of strings containing possible suffixes.
1130 The empty suffix is automatically added if the list is empty.
1132 PREDICATE non-nil means don't open the files,
1133 just look for one that satisfies the predicate. In this case,
1134 returns 1 on success. The predicate can be a lisp function or
1135 an integer to pass to `access' (in which case file-name-handlers
1138 If STOREPTR is nonzero, it points to a slot where the name of
1139 the file actually found should be stored as a Lisp string.
1140 nil is stored there on failure.
1142 If the file we find is remote, return -2
1143 but store the found remote file name in *STOREPTR. */
1146 openp (path
, str
, suffixes
, storeptr
, predicate
)
1147 Lisp_Object path
, str
;
1148 Lisp_Object suffixes
;
1149 Lisp_Object
*storeptr
;
1150 Lisp_Object predicate
;
1155 register char *fn
= buf
;
1158 Lisp_Object filename
;
1160 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
, gcpro5
, gcpro6
;
1161 Lisp_Object string
, tail
, encoded_fn
;
1162 int max_suffix_len
= 0;
1166 for (tail
= suffixes
; CONSP (tail
); tail
= XCDR (tail
))
1168 CHECK_STRING_CAR (tail
);
1169 max_suffix_len
= max (max_suffix_len
,
1170 SBYTES (XCAR (tail
)));
1173 string
= filename
= encoded_fn
= Qnil
;
1174 GCPRO6 (str
, string
, filename
, path
, suffixes
, encoded_fn
);
1179 if (complete_filename_p (str
))
1182 for (; CONSP (path
); path
= XCDR (path
))
1184 filename
= Fexpand_file_name (str
, XCAR (path
));
1185 if (!complete_filename_p (filename
))
1186 /* If there are non-absolute elts in PATH (eg ".") */
1187 /* Of course, this could conceivably lose if luser sets
1188 default-directory to be something non-absolute... */
1190 filename
= Fexpand_file_name (filename
, current_buffer
->directory
);
1191 if (!complete_filename_p (filename
))
1192 /* Give up on this path element! */
1196 /* Calculate maximum size of any filename made from
1197 this path element/specified file name and any possible suffix. */
1198 want_size
= max_suffix_len
+ SBYTES (filename
) + 1;
1199 if (fn_size
< want_size
)
1200 fn
= (char *) alloca (fn_size
= 100 + want_size
);
1202 /* Loop over suffixes. */
1203 for (tail
= NILP (suffixes
) ? Fcons (build_string (""), Qnil
) : suffixes
;
1204 CONSP (tail
); tail
= XCDR (tail
))
1206 int lsuffix
= SBYTES (XCAR (tail
));
1207 Lisp_Object handler
;
1210 /* Concatenate path element/specified name with the suffix.
1211 If the directory starts with /:, remove that. */
1212 if (SCHARS (filename
) > 2
1213 && SREF (filename
, 0) == '/'
1214 && SREF (filename
, 1) == ':')
1216 strncpy (fn
, SDATA (filename
) + 2,
1217 SBYTES (filename
) - 2);
1218 fn
[SBYTES (filename
) - 2] = 0;
1222 strncpy (fn
, SDATA (filename
),
1224 fn
[SBYTES (filename
)] = 0;
1227 if (lsuffix
!= 0) /* Bug happens on CCI if lsuffix is 0. */
1228 strncat (fn
, SDATA (XCAR (tail
)), lsuffix
);
1230 /* Check that the file exists and is not a directory. */
1231 /* We used to only check for handlers on non-absolute file names:
1235 handler = Ffind_file_name_handler (filename, Qfile_exists_p);
1236 It's not clear why that was the case and it breaks things like
1237 (load "/bar.el") where the file is actually "/bar.el.gz". */
1238 string
= build_string (fn
);
1239 handler
= Ffind_file_name_handler (string
, Qfile_exists_p
);
1240 if ((!NILP (handler
) || !NILP (predicate
)) && !NATNUMP (predicate
))
1242 if (NILP (predicate
))
1243 exists
= !NILP (Ffile_readable_p (string
));
1245 exists
= !NILP (call1 (predicate
, string
));
1246 if (exists
&& !NILP (Ffile_directory_p (string
)))
1251 /* We succeeded; return this descriptor and filename. */
1262 encoded_fn
= ENCODE_FILE (string
);
1263 pfn
= SDATA (encoded_fn
);
1264 exists
= (stat (pfn
, &st
) >= 0
1265 && (st
.st_mode
& S_IFMT
) != S_IFDIR
);
1268 /* Check that we can access or open it. */
1269 if (NATNUMP (predicate
))
1270 fd
= (access (pfn
, XFASTINT (predicate
)) == 0) ? 1 : -1;
1272 fd
= emacs_open (pfn
, O_RDONLY
, 0);
1276 /* We succeeded; return this descriptor and filename. */
1294 /* Merge the list we've accumulated of globals from the current input source
1295 into the load_history variable. The details depend on whether
1296 the source has an associated file name or not.
1298 FILENAME is the file name that we are loading from.
1299 ENTIRE is 1 if loading that entire file, 0 if evaluating part of it. */
1302 build_load_history (filename
, entire
)
1303 Lisp_Object filename
;
1306 register Lisp_Object tail
, prev
, newelt
;
1307 register Lisp_Object tem
, tem2
;
1308 register int foundit
= 0;
1310 tail
= Vload_history
;
1313 while (CONSP (tail
))
1317 /* Find the feature's previous assoc list... */
1318 if (!NILP (Fequal (filename
, Fcar (tem
))))
1322 /* If we're loading the entire file, remove old data. */
1326 Vload_history
= XCDR (tail
);
1328 Fsetcdr (prev
, XCDR (tail
));
1331 /* Otherwise, cons on new symbols that are not already members. */
1334 tem2
= Vcurrent_load_list
;
1336 while (CONSP (tem2
))
1338 newelt
= XCAR (tem2
);
1340 if (NILP (Fmember (newelt
, tem
)))
1341 Fsetcar (tail
, Fcons (XCAR (tem
),
1342 Fcons (newelt
, XCDR (tem
))));
1355 /* If we're loading an entire file, cons the new assoc onto the
1356 front of load-history, the most-recently-loaded position. Also
1357 do this if we didn't find an existing member for the file. */
1358 if (entire
|| !foundit
)
1359 Vload_history
= Fcons (Fnreverse (Vcurrent_load_list
),
1364 unreadpure (junk
) /* Used as unwind-protect function in readevalloop */
1372 readevalloop_1 (old
)
1375 load_convert_to_unibyte
= ! NILP (old
);
1379 /* Signal an `end-of-file' error, if possible with file name
1383 end_of_file_error ()
1387 if (STRINGP (Vload_file_name
))
1388 xsignal1 (Qend_of_file
, Vload_file_name
);
1390 xsignal0 (Qend_of_file
);
1393 /* UNIBYTE specifies how to set load_convert_to_unibyte
1394 for this invocation.
1395 READFUN, if non-nil, is used instead of `read'.
1397 START, END specify region to read in current buffer (from eval-region).
1398 If the input is not from a buffer, they must be nil. */
1401 readevalloop (readcharfun
, stream
, sourcename
, evalfun
,
1402 printflag
, unibyte
, readfun
, start
, end
)
1403 Lisp_Object readcharfun
;
1405 Lisp_Object sourcename
;
1406 Lisp_Object (*evalfun
) ();
1408 Lisp_Object unibyte
, readfun
;
1409 Lisp_Object start
, end
;
1412 register Lisp_Object val
;
1413 int count
= SPECPDL_INDEX ();
1414 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1415 struct buffer
*b
= 0;
1416 int continue_reading_p
;
1417 /* Nonzero if reading an entire buffer. */
1418 int whole_buffer
= 0;
1419 /* 1 on the first time around. */
1422 if (MARKERP (readcharfun
))
1425 start
= readcharfun
;
1428 if (BUFFERP (readcharfun
))
1429 b
= XBUFFER (readcharfun
);
1430 else if (MARKERP (readcharfun
))
1431 b
= XMARKER (readcharfun
)->buffer
;
1433 /* We assume START is nil when input is not from a buffer. */
1434 if (! NILP (start
) && !b
)
1437 specbind (Qstandard_input
, readcharfun
); /* GCPROs readcharfun. */
1438 specbind (Qcurrent_load_list
, Qnil
);
1439 record_unwind_protect (readevalloop_1
, load_convert_to_unibyte
? Qt
: Qnil
);
1440 load_convert_to_unibyte
= !NILP (unibyte
);
1442 readchar_backlog
= -1;
1444 GCPRO4 (sourcename
, readfun
, start
, end
);
1446 /* Try to ensure sourcename is a truename, except whilst preloading. */
1447 if (NILP (Vpurify_flag
)
1448 && !NILP (sourcename
) && !NILP (Ffile_name_absolute_p (sourcename
))
1449 && !NILP (Ffboundp (Qfile_truename
)))
1450 sourcename
= call1 (Qfile_truename
, sourcename
) ;
1452 LOADHIST_ATTACH (sourcename
);
1454 continue_reading_p
= 1;
1455 while (continue_reading_p
)
1457 int count1
= SPECPDL_INDEX ();
1459 if (b
!= 0 && NILP (b
->name
))
1460 error ("Reading from killed buffer");
1464 /* Switch to the buffer we are reading from. */
1465 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
1466 set_buffer_internal (b
);
1468 /* Save point in it. */
1469 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
1470 /* Save ZV in it. */
1471 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
1472 /* Those get unbound after we read one expression. */
1474 /* Set point and ZV around stuff to be read. */
1477 Fnarrow_to_region (make_number (BEGV
), end
);
1479 /* Just for cleanliness, convert END to a marker
1480 if it is an integer. */
1482 end
= Fpoint_max_marker ();
1485 /* On the first cycle, we can easily test here
1486 whether we are reading the whole buffer. */
1487 if (b
&& first_sexp
)
1488 whole_buffer
= (PT
== BEG
&& ZV
== Z
);
1495 while ((c
= READCHAR
) != '\n' && c
!= -1);
1500 unbind_to (count1
, Qnil
);
1504 /* Ignore whitespace here, so we can detect eof. */
1505 if (c
== ' ' || c
== '\t' || c
== '\n' || c
== '\f' || c
== '\r')
1508 if (!NILP (Vpurify_flag
) && c
== '(')
1510 record_unwind_protect (unreadpure
, Qnil
);
1511 val
= read_list (-1, readcharfun
);
1516 read_objects
= Qnil
;
1517 if (!NILP (readfun
))
1519 val
= call1 (readfun
, readcharfun
);
1521 /* If READCHARFUN has set point to ZV, we should
1522 stop reading, even if the form read sets point
1523 to a different value when evaluated. */
1524 if (BUFFERP (readcharfun
))
1526 struct buffer
*b
= XBUFFER (readcharfun
);
1527 if (BUF_PT (b
) == BUF_ZV (b
))
1528 continue_reading_p
= 0;
1531 else if (! NILP (Vload_read_function
))
1532 val
= call1 (Vload_read_function
, readcharfun
);
1534 val
= read_internal_start (readcharfun
, Qnil
, Qnil
);
1537 if (!NILP (start
) && continue_reading_p
)
1538 start
= Fpoint_marker ();
1540 /* Restore saved point and BEGV. */
1541 unbind_to (count1
, Qnil
);
1543 /* Now eval what we just read. */
1544 val
= (*evalfun
) (val
);
1548 Vvalues
= Fcons (val
, Vvalues
);
1549 if (EQ (Vstandard_output
, Qt
))
1558 build_load_history (sourcename
,
1559 stream
|| whole_buffer
);
1563 unbind_to (count
, Qnil
);
1566 DEFUN ("eval-buffer", Feval_buffer
, Seval_buffer
, 0, 5, "",
1567 doc
: /* Execute the current buffer as Lisp code.
1568 Programs can pass two arguments, BUFFER and PRINTFLAG.
1569 BUFFER is the buffer to evaluate (nil means use current buffer).
1570 PRINTFLAG controls printing of output:
1571 A value of nil means discard it; anything else is stream for print.
1573 If the optional third argument FILENAME is non-nil,
1574 it specifies the file name to use for `load-history'.
1575 The optional fourth argument UNIBYTE specifies `load-convert-to-unibyte'
1576 for this invocation.
1578 The optional fifth argument DO-ALLOW-PRINT, if non-nil, specifies that
1579 `print' and related functions should work normally even if PRINTFLAG is nil.
1581 This function preserves the position of point. */)
1582 (buffer
, printflag
, filename
, unibyte
, do_allow_print
)
1583 Lisp_Object buffer
, printflag
, filename
, unibyte
, do_allow_print
;
1585 int count
= SPECPDL_INDEX ();
1586 Lisp_Object tem
, buf
;
1589 buf
= Fcurrent_buffer ();
1591 buf
= Fget_buffer (buffer
);
1593 error ("No such buffer");
1595 if (NILP (printflag
) && NILP (do_allow_print
))
1600 if (NILP (filename
))
1601 filename
= XBUFFER (buf
)->filename
;
1603 specbind (Qeval_buffer_list
, Fcons (buf
, Veval_buffer_list
));
1604 specbind (Qstandard_output
, tem
);
1605 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
1606 BUF_SET_PT (XBUFFER (buf
), BUF_BEGV (XBUFFER (buf
)));
1607 readevalloop (buf
, 0, filename
, Feval
,
1608 !NILP (printflag
), unibyte
, Qnil
, Qnil
, Qnil
);
1609 unbind_to (count
, Qnil
);
1614 DEFUN ("eval-region", Feval_region
, Seval_region
, 2, 4, "r",
1615 doc
: /* Execute the region as Lisp code.
1616 When called from programs, expects two arguments,
1617 giving starting and ending indices in the current buffer
1618 of the text to be executed.
1619 Programs can pass third argument PRINTFLAG which controls output:
1620 A value of nil means discard it; anything else is stream for printing it.
1621 Also the fourth argument READ-FUNCTION, if non-nil, is used
1622 instead of `read' to read each expression. It gets one argument
1623 which is the input stream for reading characters.
1625 This function does not move point. */)
1626 (start
, end
, printflag
, read_function
)
1627 Lisp_Object start
, end
, printflag
, read_function
;
1629 int count
= SPECPDL_INDEX ();
1630 Lisp_Object tem
, cbuf
;
1632 cbuf
= Fcurrent_buffer ();
1634 if (NILP (printflag
))
1638 specbind (Qstandard_output
, tem
);
1639 specbind (Qeval_buffer_list
, Fcons (cbuf
, Veval_buffer_list
));
1641 /* readevalloop calls functions which check the type of start and end. */
1642 readevalloop (cbuf
, 0, XBUFFER (cbuf
)->filename
, Feval
,
1643 !NILP (printflag
), Qnil
, read_function
,
1646 return unbind_to (count
, Qnil
);
1650 DEFUN ("read", Fread
, Sread
, 0, 1, 0,
1651 doc
: /* Read one Lisp expression as text from STREAM, return as Lisp object.
1652 If STREAM is nil, use the value of `standard-input' (which see).
1653 STREAM or the value of `standard-input' may be:
1654 a buffer (read from point and advance it)
1655 a marker (read from where it points and advance it)
1656 a function (call it with no arguments for each character,
1657 call it with a char as argument to push a char back)
1658 a string (takes text from string, starting at the beginning)
1659 t (read text line using minibuffer and use it, or read from
1660 standard input in batch mode). */)
1665 stream
= Vstandard_input
;
1666 if (EQ (stream
, Qt
))
1667 stream
= Qread_char
;
1668 if (EQ (stream
, Qread_char
))
1669 return Fread_minibuffer (build_string ("Lisp expression: "), Qnil
);
1671 return read_internal_start (stream
, Qnil
, Qnil
);
1674 DEFUN ("read-from-string", Fread_from_string
, Sread_from_string
, 1, 3, 0,
1675 doc
: /* Read one Lisp expression which is represented as text by STRING.
1676 Returns a cons: (OBJECT-READ . FINAL-STRING-INDEX).
1677 START and END optionally delimit a substring of STRING from which to read;
1678 they default to 0 and (length STRING) respectively. */)
1679 (string
, start
, end
)
1680 Lisp_Object string
, start
, end
;
1683 CHECK_STRING (string
);
1684 /* read_internal_start sets read_from_string_index. */
1685 ret
= read_internal_start (string
, start
, end
);
1686 return Fcons (ret
, make_number (read_from_string_index
));
1689 /* Function to set up the global context we need in toplevel read
1692 read_internal_start (stream
, start
, end
)
1694 Lisp_Object start
; /* Only used when stream is a string. */
1695 Lisp_Object end
; /* Only used when stream is a string. */
1699 readchar_backlog
= -1;
1701 new_backquote_flag
= 0;
1702 read_objects
= Qnil
;
1703 if (EQ (Vread_with_symbol_positions
, Qt
)
1704 || EQ (Vread_with_symbol_positions
, stream
))
1705 Vread_symbol_positions_list
= Qnil
;
1707 if (STRINGP (stream
))
1709 int startval
, endval
;
1711 endval
= SCHARS (stream
);
1715 endval
= XINT (end
);
1716 if (endval
< 0 || endval
> SCHARS (stream
))
1717 args_out_of_range (stream
, end
);
1724 CHECK_NUMBER (start
);
1725 startval
= XINT (start
);
1726 if (startval
< 0 || startval
> endval
)
1727 args_out_of_range (stream
, start
);
1729 read_from_string_index
= startval
;
1730 read_from_string_index_byte
= string_char_to_byte (stream
, startval
);
1731 read_from_string_limit
= endval
;
1734 retval
= read0 (stream
);
1735 if (EQ (Vread_with_symbol_positions
, Qt
)
1736 || EQ (Vread_with_symbol_positions
, stream
))
1737 Vread_symbol_positions_list
= Fnreverse (Vread_symbol_positions_list
);
1742 /* Signal Qinvalid_read_syntax error.
1743 S is error string of length N (if > 0) */
1746 invalid_syntax (s
, n
)
1752 xsignal1 (Qinvalid_read_syntax
, make_string (s
, n
));
1756 /* Use this for recursive reads, in contexts where internal tokens
1761 Lisp_Object readcharfun
;
1763 register Lisp_Object val
;
1766 val
= read1 (readcharfun
, &c
, 0);
1770 xsignal1 (Qinvalid_read_syntax
,
1771 Fmake_string (make_number (1), make_number (c
)));
1774 static int read_buffer_size
;
1775 static char *read_buffer
;
1777 /* Read multibyte form and return it as a character. C is a first
1778 byte of multibyte form, and rest of them are read from
1782 read_multibyte (c
, readcharfun
)
1784 Lisp_Object readcharfun
;
1786 /* We need the actual character code of this multibyte
1788 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
1796 while ((c
= READCHAR
) >= 0xA0
1797 && len
< MAX_MULTIBYTE_LENGTH
)
1803 if (UNIBYTE_STR_AS_MULTIBYTE_P (str
, len
, bytes
))
1804 return STRING_CHAR (str
, len
);
1805 /* The byte sequence is not valid as multibyte. Unread all bytes
1806 but the first one, and return the first byte. */
1812 /* Read a \-escape sequence, assuming we already read the `\'.
1813 If the escape sequence forces unibyte, store 1 into *BYTEREP.
1814 If the escape sequence forces multibyte, store 2 into *BYTEREP.
1815 Otherwise store 0 into *BYTEREP. */
1818 read_escape (readcharfun
, stringp
, byterep
)
1819 Lisp_Object readcharfun
;
1823 register int c
= READCHAR
;
1824 /* \u allows up to four hex digits, \U up to eight. Default to the
1825 behaviour for \u, and change this value in the case that \U is seen. */
1826 int unicode_hex_count
= 4;
1833 end_of_file_error ();
1863 error ("Invalid escape character syntax");
1866 c
= read_escape (readcharfun
, 0, byterep
);
1867 return c
| meta_modifier
;
1872 error ("Invalid escape character syntax");
1875 c
= read_escape (readcharfun
, 0, byterep
);
1876 return c
| shift_modifier
;
1881 error ("Invalid escape character syntax");
1884 c
= read_escape (readcharfun
, 0, byterep
);
1885 return c
| hyper_modifier
;
1890 error ("Invalid escape character syntax");
1893 c
= read_escape (readcharfun
, 0, byterep
);
1894 return c
| alt_modifier
;
1905 c
= read_escape (readcharfun
, 0, byterep
);
1906 return c
| super_modifier
;
1911 error ("Invalid escape character syntax");
1915 c
= read_escape (readcharfun
, 0, byterep
);
1916 if ((c
& ~CHAR_MODIFIER_MASK
) == '?')
1917 return 0177 | (c
& CHAR_MODIFIER_MASK
);
1918 else if (! SINGLE_BYTE_CHAR_P ((c
& ~CHAR_MODIFIER_MASK
)))
1919 return c
| ctrl_modifier
;
1920 /* ASCII control chars are made from letters (both cases),
1921 as well as the non-letters within 0100...0137. */
1922 else if ((c
& 0137) >= 0101 && (c
& 0137) <= 0132)
1923 return (c
& (037 | ~0177));
1924 else if ((c
& 0177) >= 0100 && (c
& 0177) <= 0137)
1925 return (c
& (037 | ~0177));
1927 return c
| ctrl_modifier
;
1937 /* An octal escape, as in ANSI C. */
1939 register int i
= c
- '0';
1940 register int count
= 0;
1943 if ((c
= READCHAR
) >= '0' && c
<= '7')
1960 /* A hex escape, as in ANSI C. */
1966 if (c
>= '0' && c
<= '9')
1971 else if ((c
>= 'a' && c
<= 'f')
1972 || (c
>= 'A' && c
<= 'F'))
1975 if (c
>= 'a' && c
<= 'f')
1992 /* Post-Unicode-2.0: Up to eight hex chars. */
1993 unicode_hex_count
= 8;
1996 /* A Unicode escape. We only permit them in strings and characters,
1997 not arbitrarily in the source code, as in some other languages. */
2001 Lisp_Object lisp_char
;
2002 struct gcpro gcpro1
;
2004 while (++count
<= unicode_hex_count
)
2007 /* isdigit and isalpha may be locale-specific, which we don't
2009 if (c
>= '0' && c
<= '9') i
= (i
<< 4) + (c
- '0');
2010 else if (c
>= 'a' && c
<= 'f') i
= (i
<< 4) + (c
- 'a') + 10;
2011 else if (c
>= 'A' && c
<= 'F') i
= (i
<< 4) + (c
- 'A') + 10;
2014 error ("Non-hex digit used for Unicode escape");
2019 GCPRO1 (readcharfun
);
2020 lisp_char
= call2 (intern ("decode-char"), intern ("ucs"),
2024 if (NILP (lisp_char
))
2026 error ("Unsupported Unicode code point: U+%x", (unsigned)i
);
2029 return XFASTINT (lisp_char
);
2033 if (BASE_LEADING_CODE_P (c
))
2034 c
= read_multibyte (c
, readcharfun
);
2039 /* Read an integer in radix RADIX using READCHARFUN to read
2040 characters. RADIX must be in the interval [2..36]; if it isn't, a
2041 read error is signaled . Value is the integer read. Signals an
2042 error if encountering invalid read syntax or if RADIX is out of
2046 read_integer (readcharfun
, radix
)
2047 Lisp_Object readcharfun
;
2050 int ndigits
= 0, invalid_p
, c
, sign
= 0;
2051 EMACS_INT number
= 0;
2053 if (radix
< 2 || radix
> 36)
2057 number
= ndigits
= invalid_p
= 0;
2073 if (c
>= '0' && c
<= '9')
2075 else if (c
>= 'a' && c
<= 'z')
2076 digit
= c
- 'a' + 10;
2077 else if (c
>= 'A' && c
<= 'Z')
2078 digit
= c
- 'A' + 10;
2085 if (digit
< 0 || digit
>= radix
)
2088 number
= radix
* number
+ digit
;
2094 if (ndigits
== 0 || invalid_p
)
2097 sprintf (buf
, "integer, radix %d", radix
);
2098 invalid_syntax (buf
, 0);
2101 return make_number (sign
* number
);
2105 /* Convert unibyte text in read_buffer to multibyte.
2107 Initially, *P is a pointer after the end of the unibyte text, and
2108 the pointer *END points after the end of read_buffer.
2110 If read_buffer doesn't have enough room to hold the result
2111 of the conversion, reallocate it and adjust *P and *END.
2113 At the end, make *P point after the result of the conversion, and
2114 return in *NCHARS the number of characters in the converted
2118 to_multibyte (p
, end
, nchars
)
2124 parse_str_as_multibyte (read_buffer
, *p
- read_buffer
, &nbytes
, nchars
);
2125 if (read_buffer_size
< 2 * nbytes
)
2127 int offset
= *p
- read_buffer
;
2128 read_buffer_size
= 2 * max (read_buffer_size
, nbytes
);
2129 read_buffer
= (char *) xrealloc (read_buffer
, read_buffer_size
);
2130 *p
= read_buffer
+ offset
;
2131 *end
= read_buffer
+ read_buffer_size
;
2134 if (nbytes
!= *nchars
)
2135 nbytes
= str_as_multibyte (read_buffer
, read_buffer_size
,
2136 *p
- read_buffer
, nchars
);
2138 *p
= read_buffer
+ nbytes
;
2142 /* If the next token is ')' or ']' or '.', we store that character
2143 in *PCH and the return value is not interesting. Else, we store
2144 zero in *PCH and we read and return one lisp object.
2146 FIRST_IN_LIST is nonzero if this is the first element of a list. */
2149 read1 (readcharfun
, pch
, first_in_list
)
2150 register Lisp_Object readcharfun
;
2155 int uninterned_symbol
= 0;
2163 end_of_file_error ();
2168 return read_list (0, readcharfun
);
2171 return read_vector (readcharfun
, 0);
2188 tmp
= read_vector (readcharfun
, 0);
2189 if (XVECTOR (tmp
)->size
< CHAR_TABLE_STANDARD_SLOTS
2190 || XVECTOR (tmp
)->size
> CHAR_TABLE_STANDARD_SLOTS
+ 10)
2191 error ("Invalid size char-table");
2192 XSETCHAR_TABLE (tmp
, XCHAR_TABLE (tmp
));
2193 XCHAR_TABLE (tmp
)->top
= Qt
;
2202 tmp
= read_vector (readcharfun
, 0);
2203 if (XVECTOR (tmp
)->size
!= SUB_CHAR_TABLE_STANDARD_SLOTS
)
2204 error ("Invalid size char-table");
2205 XSETCHAR_TABLE (tmp
, XCHAR_TABLE (tmp
));
2206 XCHAR_TABLE (tmp
)->top
= Qnil
;
2209 invalid_syntax ("#^^", 3);
2211 invalid_syntax ("#^", 2);
2216 length
= read1 (readcharfun
, pch
, first_in_list
);
2220 Lisp_Object tmp
, val
;
2222 = ((XFASTINT (length
) + BOOL_VECTOR_BITS_PER_CHAR
- 1)
2223 / BOOL_VECTOR_BITS_PER_CHAR
);
2226 tmp
= read1 (readcharfun
, pch
, first_in_list
);
2227 if (size_in_chars
!= SCHARS (tmp
)
2228 /* We used to print 1 char too many
2229 when the number of bits was a multiple of 8.
2230 Accept such input in case it came from an old version. */
2231 && ! (XFASTINT (length
)
2232 == (SCHARS (tmp
) - 1) * BOOL_VECTOR_BITS_PER_CHAR
))
2233 invalid_syntax ("#&...", 5);
2235 val
= Fmake_bool_vector (length
, Qnil
);
2236 bcopy (SDATA (tmp
), XBOOL_VECTOR (val
)->data
,
2238 /* Clear the extraneous bits in the last byte. */
2239 if (XINT (length
) != size_in_chars
* BOOL_VECTOR_BITS_PER_CHAR
)
2240 XBOOL_VECTOR (val
)->data
[size_in_chars
- 1]
2241 &= (1 << (XINT (length
) % BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2244 invalid_syntax ("#&...", 5);
2248 /* Accept compiled functions at read-time so that we don't have to
2249 build them using function calls. */
2251 tmp
= read_vector (readcharfun
, 1);
2252 return Fmake_byte_code (XVECTOR (tmp
)->size
,
2253 XVECTOR (tmp
)->contents
);
2258 struct gcpro gcpro1
;
2261 /* Read the string itself. */
2262 tmp
= read1 (readcharfun
, &ch
, 0);
2263 if (ch
!= 0 || !STRINGP (tmp
))
2264 invalid_syntax ("#", 1);
2266 /* Read the intervals and their properties. */
2269 Lisp_Object beg
, end
, plist
;
2271 beg
= read1 (readcharfun
, &ch
, 0);
2276 end
= read1 (readcharfun
, &ch
, 0);
2278 plist
= read1 (readcharfun
, &ch
, 0);
2280 invalid_syntax ("Invalid string property list", 0);
2281 Fset_text_properties (beg
, end
, plist
, tmp
);
2287 /* #@NUMBER is used to skip NUMBER following characters.
2288 That's used in .elc files to skip over doc strings
2289 and function definitions. */
2294 /* Read a decimal integer. */
2295 while ((c
= READCHAR
) >= 0
2296 && c
>= '0' && c
<= '9')
2304 if (load_force_doc_strings
&& EQ (readcharfun
, Qget_file_char
))
2306 /* If we are supposed to force doc strings into core right now,
2307 record the last string that we skipped,
2308 and record where in the file it comes from. */
2310 /* But first exchange saved_doc_string
2311 with prev_saved_doc_string, so we save two strings. */
2313 char *temp
= saved_doc_string
;
2314 int temp_size
= saved_doc_string_size
;
2315 file_offset temp_pos
= saved_doc_string_position
;
2316 int temp_len
= saved_doc_string_length
;
2318 saved_doc_string
= prev_saved_doc_string
;
2319 saved_doc_string_size
= prev_saved_doc_string_size
;
2320 saved_doc_string_position
= prev_saved_doc_string_position
;
2321 saved_doc_string_length
= prev_saved_doc_string_length
;
2323 prev_saved_doc_string
= temp
;
2324 prev_saved_doc_string_size
= temp_size
;
2325 prev_saved_doc_string_position
= temp_pos
;
2326 prev_saved_doc_string_length
= temp_len
;
2329 if (saved_doc_string_size
== 0)
2331 saved_doc_string_size
= nskip
+ 100;
2332 saved_doc_string
= (char *) xmalloc (saved_doc_string_size
);
2334 if (nskip
> saved_doc_string_size
)
2336 saved_doc_string_size
= nskip
+ 100;
2337 saved_doc_string
= (char *) xrealloc (saved_doc_string
,
2338 saved_doc_string_size
);
2341 saved_doc_string_position
= file_tell (instream
);
2343 /* Copy that many characters into saved_doc_string. */
2344 for (i
= 0; i
< nskip
&& c
>= 0; i
++)
2345 saved_doc_string
[i
] = c
= READCHAR
;
2347 saved_doc_string_length
= i
;
2351 /* Skip that many characters. */
2352 for (i
= 0; i
< nskip
&& c
>= 0; i
++)
2360 /* #! appears at the beginning of an executable file.
2361 Skip the first line. */
2362 while (c
!= '\n' && c
>= 0)
2367 return Vload_file_name
;
2369 return Fcons (Qfunction
, Fcons (read0 (readcharfun
), Qnil
));
2370 /* #:foo is the uninterned symbol named foo. */
2373 uninterned_symbol
= 1;
2377 /* Reader forms that can reuse previously read objects. */
2378 if (c
>= '0' && c
<= '9')
2383 /* Read a non-negative integer. */
2384 while (c
>= '0' && c
<= '9')
2390 /* #n=object returns object, but associates it with n for #n#. */
2393 /* Make a placeholder for #n# to use temporarily */
2394 Lisp_Object placeholder
;
2397 placeholder
= Fcons(Qnil
, Qnil
);
2398 cell
= Fcons (make_number (n
), placeholder
);
2399 read_objects
= Fcons (cell
, read_objects
);
2401 /* Read the object itself. */
2402 tem
= read0 (readcharfun
);
2404 /* Now put it everywhere the placeholder was... */
2405 substitute_object_in_subtree (tem
, placeholder
);
2407 /* ...and #n# will use the real value from now on. */
2408 Fsetcdr (cell
, tem
);
2412 /* #n# returns a previously read object. */
2415 tem
= Fassq (make_number (n
), read_objects
);
2418 /* Fall through to error message. */
2420 else if (c
== 'r' || c
== 'R')
2421 return read_integer (readcharfun
, n
);
2423 /* Fall through to error message. */
2425 else if (c
== 'x' || c
== 'X')
2426 return read_integer (readcharfun
, 16);
2427 else if (c
== 'o' || c
== 'O')
2428 return read_integer (readcharfun
, 8);
2429 else if (c
== 'b' || c
== 'B')
2430 return read_integer (readcharfun
, 2);
2433 invalid_syntax ("#", 1);
2436 while ((c
= READCHAR
) >= 0 && c
!= '\n');
2441 return Fcons (Qquote
, Fcons (read0 (readcharfun
), Qnil
));
2447 Vold_style_backquotes
= Qt
;
2454 new_backquote_flag
++;
2455 value
= read0 (readcharfun
);
2456 new_backquote_flag
--;
2458 return Fcons (Qbackquote
, Fcons (value
, Qnil
));
2462 if (new_backquote_flag
)
2464 Lisp_Object comma_type
= Qnil
;
2469 comma_type
= Qcomma_at
;
2471 comma_type
= Qcomma_dot
;
2474 if (ch
>= 0) UNREAD (ch
);
2475 comma_type
= Qcomma
;
2478 new_backquote_flag
--;
2479 value
= read0 (readcharfun
);
2480 new_backquote_flag
++;
2481 return Fcons (comma_type
, Fcons (value
, Qnil
));
2485 Vold_style_backquotes
= Qt
;
2497 end_of_file_error ();
2499 /* Accept `single space' syntax like (list ? x) where the
2500 whitespace character is SPC or TAB.
2501 Other literal whitespace like NL, CR, and FF are not accepted,
2502 as there are well-established escape sequences for these. */
2503 if (c
== ' ' || c
== '\t')
2504 return make_number (c
);
2507 c
= read_escape (readcharfun
, 0, &discard
);
2508 else if (BASE_LEADING_CODE_P (c
))
2509 c
= read_multibyte (c
, readcharfun
);
2511 next_char
= READCHAR
;
2512 if (next_char
== '.')
2514 /* Only a dotted-pair dot is valid after a char constant. */
2515 int next_next_char
= READCHAR
;
2516 UNREAD (next_next_char
);
2518 ok
= (next_next_char
<= 040
2519 || (next_next_char
< 0200
2520 && (index ("\"';([#?", next_next_char
)
2521 || (!first_in_list
&& next_next_char
== '`')
2522 || (new_backquote_flag
&& next_next_char
== ','))));
2526 ok
= (next_char
<= 040
2527 || (next_char
< 0200
2528 && (index ("\"';()[]#?", next_char
)
2529 || (!first_in_list
&& next_char
== '`')
2530 || (new_backquote_flag
&& next_char
== ','))));
2534 return make_number (c
);
2536 invalid_syntax ("?", 1);
2541 char *p
= read_buffer
;
2542 char *end
= read_buffer
+ read_buffer_size
;
2544 /* 1 if we saw an escape sequence specifying
2545 a multibyte character, or a multibyte character. */
2546 int force_multibyte
= 0;
2547 /* 1 if we saw an escape sequence specifying
2548 a single-byte character. */
2549 int force_singlebyte
= 0;
2550 /* 1 if read_buffer contains multibyte text now. */
2551 int is_multibyte
= 0;
2555 while ((c
= READCHAR
) >= 0
2558 if (end
- p
< MAX_MULTIBYTE_LENGTH
)
2560 int offset
= p
- read_buffer
;
2561 read_buffer
= (char *) xrealloc (read_buffer
,
2562 read_buffer_size
*= 2);
2563 p
= read_buffer
+ offset
;
2564 end
= read_buffer
+ read_buffer_size
;
2571 c
= read_escape (readcharfun
, 1, &byterep
);
2573 /* C is -1 if \ newline has just been seen */
2576 if (p
== read_buffer
)
2582 force_singlebyte
= 1;
2583 else if (byterep
== 2)
2584 force_multibyte
= 1;
2587 /* A character that must be multibyte forces multibyte. */
2588 if (! SINGLE_BYTE_CHAR_P (c
& ~CHAR_MODIFIER_MASK
))
2589 force_multibyte
= 1;
2591 /* If we just discovered the need to be multibyte,
2592 convert the text accumulated thus far. */
2593 if (force_multibyte
&& ! is_multibyte
)
2596 to_multibyte (&p
, &end
, &nchars
);
2599 /* Allow `\C- ' and `\C-?'. */
2600 if (c
== (CHAR_CTL
| ' '))
2602 else if (c
== (CHAR_CTL
| '?'))
2607 /* Shift modifier is valid only with [A-Za-z]. */
2608 if ((c
& 0377) >= 'A' && (c
& 0377) <= 'Z')
2610 else if ((c
& 0377) >= 'a' && (c
& 0377) <= 'z')
2611 c
= (c
& ~CHAR_SHIFT
) - ('a' - 'A');
2615 /* Move the meta bit to the right place for a string. */
2616 c
= (c
& ~CHAR_META
) | 0x80;
2617 if (c
& CHAR_MODIFIER_MASK
)
2618 error ("Invalid modifier in string");
2621 p
+= CHAR_STRING (c
, p
);
2629 end_of_file_error ();
2631 /* If purifying, and string starts with \ newline,
2632 return zero instead. This is for doc strings
2633 that we are really going to find in etc/DOC.nn.nn */
2634 if (!NILP (Vpurify_flag
) && NILP (Vdoc_file_name
) && cancel
)
2635 return make_number (0);
2637 if (is_multibyte
|| force_singlebyte
)
2639 else if (load_convert_to_unibyte
)
2642 to_multibyte (&p
, &end
, &nchars
);
2643 if (p
- read_buffer
!= nchars
)
2645 string
= make_multibyte_string (read_buffer
, nchars
,
2647 return Fstring_make_unibyte (string
);
2649 /* We can make a unibyte string directly. */
2652 else if (EQ (readcharfun
, Qget_file_char
)
2653 || EQ (readcharfun
, Qlambda
))
2655 /* Nowadays, reading directly from a file is used only for
2656 compiled Emacs Lisp files, and those always use the
2657 Emacs internal encoding. Meanwhile, Qlambda is used
2658 for reading dynamic byte code (compiled with
2659 byte-compile-dynamic = t). So make the string multibyte
2660 if the string contains any multibyte sequences.
2661 (to_multibyte is a no-op if not.) */
2662 to_multibyte (&p
, &end
, &nchars
);
2663 is_multibyte
= (p
- read_buffer
) != nchars
;
2666 /* In all other cases, if we read these bytes as
2667 separate characters, treat them as separate characters now. */
2670 /* We want readchar_count to be the number of characters, not
2671 bytes. Hence we adjust for multibyte characters in the
2672 string. ... But it doesn't seem to be necessary, because
2673 READCHAR *does* read multibyte characters from buffers. */
2674 /* readchar_count -= (p - read_buffer) - nchars; */
2676 return make_pure_string (read_buffer
, nchars
, p
- read_buffer
,
2678 return make_specified_string (read_buffer
, nchars
, p
- read_buffer
,
2684 int next_char
= READCHAR
;
2687 if (next_char
<= 040
2688 || (next_char
< 0200
2689 && (index ("\"';([#?", next_char
)
2690 || (!first_in_list
&& next_char
== '`')
2691 || (new_backquote_flag
&& next_char
== ','))))
2697 /* Otherwise, we fall through! Note that the atom-reading loop
2698 below will now loop at least once, assuring that we will not
2699 try to UNREAD two characters in a row. */
2703 if (c
<= 040) goto retry
;
2705 char *p
= read_buffer
;
2709 char *end
= read_buffer
+ read_buffer_size
;
2713 || (!index ("\"';()[]#", c
)
2714 && !(!first_in_list
&& c
== '`')
2715 && !(new_backquote_flag
&& c
== ','))))
2717 if (end
- p
< MAX_MULTIBYTE_LENGTH
)
2719 int offset
= p
- read_buffer
;
2720 read_buffer
= (char *) xrealloc (read_buffer
,
2721 read_buffer_size
*= 2);
2722 p
= read_buffer
+ offset
;
2723 end
= read_buffer
+ read_buffer_size
;
2730 end_of_file_error ();
2734 if (! SINGLE_BYTE_CHAR_P (c
))
2735 p
+= CHAR_STRING (c
, p
);
2744 int offset
= p
- read_buffer
;
2745 read_buffer
= (char *) xrealloc (read_buffer
,
2746 read_buffer_size
*= 2);
2747 p
= read_buffer
+ offset
;
2748 end
= read_buffer
+ read_buffer_size
;
2755 if (!quoted
&& !uninterned_symbol
)
2758 register Lisp_Object val
;
2760 if (*p1
== '+' || *p1
== '-') p1
++;
2761 /* Is it an integer? */
2764 while (p1
!= p
&& (c
= *p1
) >= '0' && c
<= '9') p1
++;
2765 /* Integers can have trailing decimal points. */
2766 if (p1
> read_buffer
&& p1
< p
&& *p1
== '.') p1
++;
2768 /* It is an integer. */
2772 if (sizeof (int) == sizeof (EMACS_INT
))
2773 XSETINT (val
, atoi (read_buffer
));
2774 else if (sizeof (long) == sizeof (EMACS_INT
))
2775 XSETINT (val
, atol (read_buffer
));
2781 if (isfloat_string (read_buffer
))
2783 /* Compute NaN and infinities using 0.0 in a variable,
2784 to cope with compilers that think they are smarter
2790 /* Negate the value ourselves. This treats 0, NaNs,
2791 and infinity properly on IEEE floating point hosts,
2792 and works around a common bug where atof ("-0.0")
2794 int negative
= read_buffer
[0] == '-';
2796 /* The only way p[-1] can be 'F' or 'N', after isfloat_string
2797 returns 1, is if the input ends in e+INF or e+NaN. */
2804 value
= zero
/ zero
;
2806 /* If that made a "negative" NaN, negate it. */
2810 union { double d
; char c
[sizeof (double)]; } u_data
, u_minus_zero
;
2813 u_minus_zero
.d
= - 0.0;
2814 for (i
= 0; i
< sizeof (double); i
++)
2815 if (u_data
.c
[i
] & u_minus_zero
.c
[i
])
2821 /* Now VALUE is a positive NaN. */
2824 value
= atof (read_buffer
+ negative
);
2828 return make_float (negative
? - value
: value
);
2832 Lisp_Object result
= uninterned_symbol
? make_symbol (read_buffer
)
2833 : intern (read_buffer
);
2834 if (EQ (Vread_with_symbol_positions
, Qt
)
2835 || EQ (Vread_with_symbol_positions
, readcharfun
))
2836 Vread_symbol_positions_list
=
2837 /* Kind of a hack; this will probably fail if characters
2838 in the symbol name were escaped. Not really a big
2840 Fcons (Fcons (result
,
2841 make_number (readchar_count
2842 - XFASTINT (Flength (Fsymbol_name (result
))))),
2843 Vread_symbol_positions_list
);
2851 /* List of nodes we've seen during substitute_object_in_subtree. */
2852 static Lisp_Object seen_list
;
2855 substitute_object_in_subtree (object
, placeholder
)
2857 Lisp_Object placeholder
;
2859 Lisp_Object check_object
;
2861 /* We haven't seen any objects when we start. */
2864 /* Make all the substitutions. */
2866 = substitute_object_recurse (object
, placeholder
, object
);
2868 /* Clear seen_list because we're done with it. */
2871 /* The returned object here is expected to always eq the
2873 if (!EQ (check_object
, object
))
2874 error ("Unexpected mutation error in reader");
2877 /* Feval doesn't get called from here, so no gc protection is needed. */
2878 #define SUBSTITUTE(get_val, set_val) \
2880 Lisp_Object old_value = get_val; \
2881 Lisp_Object true_value \
2882 = substitute_object_recurse (object, placeholder,\
2885 if (!EQ (old_value, true_value)) \
2892 substitute_object_recurse (object
, placeholder
, subtree
)
2894 Lisp_Object placeholder
;
2895 Lisp_Object subtree
;
2897 /* If we find the placeholder, return the target object. */
2898 if (EQ (placeholder
, subtree
))
2901 /* If we've been to this node before, don't explore it again. */
2902 if (!EQ (Qnil
, Fmemq (subtree
, seen_list
)))
2905 /* If this node can be the entry point to a cycle, remember that
2906 we've seen it. It can only be such an entry point if it was made
2907 by #n=, which means that we can find it as a value in
2909 if (!EQ (Qnil
, Frassq (subtree
, read_objects
)))
2910 seen_list
= Fcons (subtree
, seen_list
);
2912 /* Recurse according to subtree's type.
2913 Every branch must return a Lisp_Object. */
2914 switch (XTYPE (subtree
))
2916 case Lisp_Vectorlike
:
2919 int length
= XINT (Flength(subtree
));
2920 for (i
= 0; i
< length
; i
++)
2922 Lisp_Object idx
= make_number (i
);
2923 SUBSTITUTE (Faref (subtree
, idx
),
2924 Faset (subtree
, idx
, true_value
));
2931 SUBSTITUTE (Fcar_safe (subtree
),
2932 Fsetcar (subtree
, true_value
));
2933 SUBSTITUTE (Fcdr_safe (subtree
),
2934 Fsetcdr (subtree
, true_value
));
2940 /* Check for text properties in each interval.
2941 substitute_in_interval contains part of the logic. */
2943 INTERVAL root_interval
= STRING_INTERVALS (subtree
);
2944 Lisp_Object arg
= Fcons (object
, placeholder
);
2946 traverse_intervals_noorder (root_interval
,
2947 &substitute_in_interval
, arg
);
2952 /* Other types don't recurse any further. */
2958 /* Helper function for substitute_object_recurse. */
2960 substitute_in_interval (interval
, arg
)
2964 Lisp_Object object
= Fcar (arg
);
2965 Lisp_Object placeholder
= Fcdr (arg
);
2967 SUBSTITUTE(interval
->plist
, interval
->plist
= true_value
);
2986 if (*cp
== '+' || *cp
== '-')
2989 if (*cp
>= '0' && *cp
<= '9')
2992 while (*cp
>= '0' && *cp
<= '9')
3000 if (*cp
>= '0' && *cp
<= '9')
3003 while (*cp
>= '0' && *cp
<= '9')
3006 if (*cp
== 'e' || *cp
== 'E')
3010 if (*cp
== '+' || *cp
== '-')
3014 if (*cp
>= '0' && *cp
<= '9')
3017 while (*cp
>= '0' && *cp
<= '9')
3020 else if (cp
== start
)
3022 else if (cp
[-1] == '+' && cp
[0] == 'I' && cp
[1] == 'N' && cp
[2] == 'F')
3027 else if (cp
[-1] == '+' && cp
[0] == 'N' && cp
[1] == 'a' && cp
[2] == 'N')
3033 return (((*cp
== 0) || (*cp
== ' ') || (*cp
== '\t') || (*cp
== '\n') || (*cp
== '\r') || (*cp
== '\f'))
3034 && (state
== (LEAD_INT
|DOT_CHAR
|TRAIL_INT
)
3035 || state
== (DOT_CHAR
|TRAIL_INT
)
3036 || state
== (LEAD_INT
|E_CHAR
|EXP_INT
)
3037 || state
== (LEAD_INT
|DOT_CHAR
|TRAIL_INT
|E_CHAR
|EXP_INT
)
3038 || state
== (DOT_CHAR
|TRAIL_INT
|E_CHAR
|EXP_INT
)));
3043 read_vector (readcharfun
, bytecodeflag
)
3044 Lisp_Object readcharfun
;
3049 register Lisp_Object
*ptr
;
3050 register Lisp_Object tem
, item
, vector
;
3051 register struct Lisp_Cons
*otem
;
3054 tem
= read_list (1, readcharfun
);
3055 len
= Flength (tem
);
3056 vector
= (read_pure
? make_pure_vector (XINT (len
)) : Fmake_vector (len
, Qnil
));
3058 size
= XVECTOR (vector
)->size
;
3059 ptr
= XVECTOR (vector
)->contents
;
3060 for (i
= 0; i
< size
; i
++)
3063 /* If `load-force-doc-strings' is t when reading a lazily-loaded
3064 bytecode object, the docstring containing the bytecode and
3065 constants values must be treated as unibyte and passed to
3066 Fread, to get the actual bytecode string and constants vector. */
3067 if (bytecodeflag
&& load_force_doc_strings
)
3069 if (i
== COMPILED_BYTECODE
)
3071 if (!STRINGP (item
))
3072 error ("Invalid byte code");
3074 /* Delay handling the bytecode slot until we know whether
3075 it is lazily-loaded (we can tell by whether the
3076 constants slot is nil). */
3077 ptr
[COMPILED_CONSTANTS
] = item
;
3080 else if (i
== COMPILED_CONSTANTS
)
3082 Lisp_Object bytestr
= ptr
[COMPILED_CONSTANTS
];
3086 /* Coerce string to unibyte (like string-as-unibyte,
3087 but without generating extra garbage and
3088 guaranteeing no change in the contents). */
3089 STRING_SET_CHARS (bytestr
, SBYTES (bytestr
));
3090 STRING_SET_UNIBYTE (bytestr
);
3092 item
= Fread (bytestr
);
3094 error ("Invalid byte code");
3096 otem
= XCONS (item
);
3097 bytestr
= XCAR (item
);
3102 /* Now handle the bytecode slot. */
3103 ptr
[COMPILED_BYTECODE
] = read_pure
? Fpurecopy (bytestr
) : bytestr
;
3106 ptr
[i
] = read_pure
? Fpurecopy (item
) : item
;
3114 /* FLAG = 1 means check for ] to terminate rather than ) and .
3115 FLAG = -1 means check for starting with defun
3116 and make structure pure. */
3119 read_list (flag
, readcharfun
)
3121 register Lisp_Object readcharfun
;
3123 /* -1 means check next element for defun,
3124 0 means don't check,
3125 1 means already checked and found defun. */
3126 int defunflag
= flag
< 0 ? -1 : 0;
3127 Lisp_Object val
, tail
;
3128 register Lisp_Object elt
, tem
;
3129 struct gcpro gcpro1
, gcpro2
;
3130 /* 0 is the normal case.
3131 1 means this list is a doc reference; replace it with the number 0.
3132 2 means this list is a doc reference; replace it with the doc string. */
3133 int doc_reference
= 0;
3135 /* Initialize this to 1 if we are reading a list. */
3136 int first_in_list
= flag
<= 0;
3145 elt
= read1 (readcharfun
, &ch
, first_in_list
);
3150 /* While building, if the list starts with #$, treat it specially. */
3151 if (EQ (elt
, Vload_file_name
)
3153 && !NILP (Vpurify_flag
))
3155 if (NILP (Vdoc_file_name
))
3156 /* We have not yet called Snarf-documentation, so assume
3157 this file is described in the DOC-MM.NN file
3158 and Snarf-documentation will fill in the right value later.
3159 For now, replace the whole list with 0. */
3162 /* We have already called Snarf-documentation, so make a relative
3163 file name for this file, so it can be found properly
3164 in the installed Lisp directory.
3165 We don't use Fexpand_file_name because that would make
3166 the directory absolute now. */
3167 elt
= concat2 (build_string ("../lisp/"),
3168 Ffile_name_nondirectory (elt
));
3170 else if (EQ (elt
, Vload_file_name
)
3172 && load_force_doc_strings
)
3181 invalid_syntax (") or . in a vector", 18);
3189 XSETCDR (tail
, read0 (readcharfun
));
3191 val
= read0 (readcharfun
);
3192 read1 (readcharfun
, &ch
, 0);
3196 if (doc_reference
== 1)
3197 return make_number (0);
3198 if (doc_reference
== 2)
3200 /* Get a doc string from the file we are loading.
3201 If it's in saved_doc_string, get it from there. */
3202 int pos
= XINT (XCDR (val
));
3203 /* Position is negative for user variables. */
3204 if (pos
< 0) pos
= -pos
;
3205 if (pos
>= saved_doc_string_position
3206 && pos
< (saved_doc_string_position
3207 + saved_doc_string_length
))
3209 int start
= pos
- saved_doc_string_position
;
3212 /* Process quoting with ^A,
3213 and find the end of the string,
3214 which is marked with ^_ (037). */
3215 for (from
= start
, to
= start
;
3216 saved_doc_string
[from
] != 037;)
3218 int c
= saved_doc_string
[from
++];
3221 c
= saved_doc_string
[from
++];
3223 saved_doc_string
[to
++] = c
;
3225 saved_doc_string
[to
++] = 0;
3227 saved_doc_string
[to
++] = 037;
3230 saved_doc_string
[to
++] = c
;
3233 return make_string (saved_doc_string
+ start
,
3236 /* Look in prev_saved_doc_string the same way. */
3237 else if (pos
>= prev_saved_doc_string_position
3238 && pos
< (prev_saved_doc_string_position
3239 + prev_saved_doc_string_length
))
3241 int start
= pos
- prev_saved_doc_string_position
;
3244 /* Process quoting with ^A,
3245 and find the end of the string,
3246 which is marked with ^_ (037). */
3247 for (from
= start
, to
= start
;
3248 prev_saved_doc_string
[from
] != 037;)
3250 int c
= prev_saved_doc_string
[from
++];
3253 c
= prev_saved_doc_string
[from
++];
3255 prev_saved_doc_string
[to
++] = c
;
3257 prev_saved_doc_string
[to
++] = 0;
3259 prev_saved_doc_string
[to
++] = 037;
3262 prev_saved_doc_string
[to
++] = c
;
3265 return make_string (prev_saved_doc_string
+ start
,
3269 return get_doc_string (val
, 0, 0);
3274 invalid_syntax (". in wrong context", 18);
3276 invalid_syntax ("] in a list", 11);
3278 tem
= (read_pure
&& flag
<= 0
3279 ? pure_cons (elt
, Qnil
)
3280 : Fcons (elt
, Qnil
));
3282 XSETCDR (tail
, tem
);
3287 defunflag
= EQ (elt
, Qdefun
);
3288 else if (defunflag
> 0)
3293 Lisp_Object Vobarray
;
3294 Lisp_Object initial_obarray
;
3296 /* oblookup stores the bucket number here, for the sake of Funintern. */
3298 int oblookup_last_bucket_number
;
3300 static int hash_string ();
3302 /* Get an error if OBARRAY is not an obarray.
3303 If it is one, return it. */
3306 check_obarray (obarray
)
3307 Lisp_Object obarray
;
3309 if (!VECTORP (obarray
) || XVECTOR (obarray
)->size
== 0)
3311 /* If Vobarray is now invalid, force it to be valid. */
3312 if (EQ (Vobarray
, obarray
)) Vobarray
= initial_obarray
;
3313 wrong_type_argument (Qvectorp
, obarray
);
3318 /* Intern the C string STR: return a symbol with that name,
3319 interned in the current obarray. */
3326 int len
= strlen (str
);
3327 Lisp_Object obarray
;
3330 if (!VECTORP (obarray
) || XVECTOR (obarray
)->size
== 0)
3331 obarray
= check_obarray (obarray
);
3332 tem
= oblookup (obarray
, str
, len
, len
);
3335 return Fintern (make_string (str
, len
), obarray
);
3338 /* Create an uninterned symbol with name STR. */
3344 int len
= strlen (str
);
3346 return Fmake_symbol ((!NILP (Vpurify_flag
)
3347 ? make_pure_string (str
, len
, len
, 0)
3348 : make_string (str
, len
)));
3351 DEFUN ("intern", Fintern
, Sintern
, 1, 2, 0,
3352 doc
: /* Return the canonical symbol whose name is STRING.
3353 If there is none, one is created by this function and returned.
3354 A second optional argument specifies the obarray to use;
3355 it defaults to the value of `obarray'. */)
3357 Lisp_Object string
, obarray
;
3359 register Lisp_Object tem
, sym
, *ptr
;
3361 if (NILP (obarray
)) obarray
= Vobarray
;
3362 obarray
= check_obarray (obarray
);
3364 CHECK_STRING (string
);
3366 tem
= oblookup (obarray
, SDATA (string
),
3369 if (!INTEGERP (tem
))
3372 if (!NILP (Vpurify_flag
))
3373 string
= Fpurecopy (string
);
3374 sym
= Fmake_symbol (string
);
3376 if (EQ (obarray
, initial_obarray
))
3377 XSYMBOL (sym
)->interned
= SYMBOL_INTERNED_IN_INITIAL_OBARRAY
;
3379 XSYMBOL (sym
)->interned
= SYMBOL_INTERNED
;
3381 if ((SREF (string
, 0) == ':')
3382 && EQ (obarray
, initial_obarray
))
3384 XSYMBOL (sym
)->constant
= 1;
3385 XSYMBOL (sym
)->value
= sym
;
3388 ptr
= &XVECTOR (obarray
)->contents
[XINT (tem
)];
3390 XSYMBOL (sym
)->next
= XSYMBOL (*ptr
);
3392 XSYMBOL (sym
)->next
= 0;
3397 DEFUN ("intern-soft", Fintern_soft
, Sintern_soft
, 1, 2, 0,
3398 doc
: /* Return the canonical symbol named NAME, or nil if none exists.
3399 NAME may be a string or a symbol. If it is a symbol, that exact
3400 symbol is searched for.
3401 A second optional argument specifies the obarray to use;
3402 it defaults to the value of `obarray'. */)
3404 Lisp_Object name
, obarray
;
3406 register Lisp_Object tem
, string
;
3408 if (NILP (obarray
)) obarray
= Vobarray
;
3409 obarray
= check_obarray (obarray
);
3411 if (!SYMBOLP (name
))
3413 CHECK_STRING (name
);
3417 string
= SYMBOL_NAME (name
);
3419 tem
= oblookup (obarray
, SDATA (string
), SCHARS (string
), SBYTES (string
));
3420 if (INTEGERP (tem
) || (SYMBOLP (name
) && !EQ (name
, tem
)))
3426 DEFUN ("unintern", Funintern
, Sunintern
, 1, 2, 0,
3427 doc
: /* Delete the symbol named NAME, if any, from OBARRAY.
3428 The value is t if a symbol was found and deleted, nil otherwise.
3429 NAME may be a string or a symbol. If it is a symbol, that symbol
3430 is deleted, if it belongs to OBARRAY--no other symbol is deleted.
3431 OBARRAY defaults to the value of the variable `obarray'. */)
3433 Lisp_Object name
, obarray
;
3435 register Lisp_Object string
, tem
;
3438 if (NILP (obarray
)) obarray
= Vobarray
;
3439 obarray
= check_obarray (obarray
);
3442 string
= SYMBOL_NAME (name
);
3445 CHECK_STRING (name
);
3449 tem
= oblookup (obarray
, SDATA (string
),
3454 /* If arg was a symbol, don't delete anything but that symbol itself. */
3455 if (SYMBOLP (name
) && !EQ (name
, tem
))
3458 XSYMBOL (tem
)->interned
= SYMBOL_UNINTERNED
;
3459 XSYMBOL (tem
)->constant
= 0;
3460 XSYMBOL (tem
)->indirect_variable
= 0;
3462 hash
= oblookup_last_bucket_number
;
3464 if (EQ (XVECTOR (obarray
)->contents
[hash
], tem
))
3466 if (XSYMBOL (tem
)->next
)
3467 XSETSYMBOL (XVECTOR (obarray
)->contents
[hash
], XSYMBOL (tem
)->next
);
3469 XSETINT (XVECTOR (obarray
)->contents
[hash
], 0);
3473 Lisp_Object tail
, following
;
3475 for (tail
= XVECTOR (obarray
)->contents
[hash
];
3476 XSYMBOL (tail
)->next
;
3479 XSETSYMBOL (following
, XSYMBOL (tail
)->next
);
3480 if (EQ (following
, tem
))
3482 XSYMBOL (tail
)->next
= XSYMBOL (following
)->next
;
3491 /* Return the symbol in OBARRAY whose names matches the string
3492 of SIZE characters (SIZE_BYTE bytes) at PTR.
3493 If there is no such symbol in OBARRAY, return nil.
3495 Also store the bucket number in oblookup_last_bucket_number. */
3498 oblookup (obarray
, ptr
, size
, size_byte
)
3499 Lisp_Object obarray
;
3500 register const char *ptr
;
3501 int size
, size_byte
;
3505 register Lisp_Object tail
;
3506 Lisp_Object bucket
, tem
;
3508 if (!VECTORP (obarray
)
3509 || (obsize
= XVECTOR (obarray
)->size
) == 0)
3511 obarray
= check_obarray (obarray
);
3512 obsize
= XVECTOR (obarray
)->size
;
3514 /* This is sometimes needed in the middle of GC. */
3515 obsize
&= ~ARRAY_MARK_FLAG
;
3516 /* Combining next two lines breaks VMS C 2.3. */
3517 hash
= hash_string (ptr
, size_byte
);
3519 bucket
= XVECTOR (obarray
)->contents
[hash
];
3520 oblookup_last_bucket_number
= hash
;
3521 if (EQ (bucket
, make_number (0)))
3523 else if (!SYMBOLP (bucket
))
3524 error ("Bad data in guts of obarray"); /* Like CADR error message */
3526 for (tail
= bucket
; ; XSETSYMBOL (tail
, XSYMBOL (tail
)->next
))
3528 if (SBYTES (SYMBOL_NAME (tail
)) == size_byte
3529 && SCHARS (SYMBOL_NAME (tail
)) == size
3530 && !bcmp (SDATA (SYMBOL_NAME (tail
)), ptr
, size_byte
))
3532 else if (XSYMBOL (tail
)->next
== 0)
3535 XSETINT (tem
, hash
);
3540 hash_string (ptr
, len
)
3541 const unsigned char *ptr
;
3544 register const unsigned char *p
= ptr
;
3545 register const unsigned char *end
= p
+ len
;
3546 register unsigned char c
;
3547 register int hash
= 0;
3552 if (c
>= 0140) c
-= 40;
3553 hash
= ((hash
<<3) + (hash
>>28) + c
);
3555 return hash
& 07777777777;
3559 map_obarray (obarray
, fn
, arg
)
3560 Lisp_Object obarray
;
3561 void (*fn
) P_ ((Lisp_Object
, Lisp_Object
));
3565 register Lisp_Object tail
;
3566 CHECK_VECTOR (obarray
);
3567 for (i
= XVECTOR (obarray
)->size
- 1; i
>= 0; i
--)
3569 tail
= XVECTOR (obarray
)->contents
[i
];
3574 if (XSYMBOL (tail
)->next
== 0)
3576 XSETSYMBOL (tail
, XSYMBOL (tail
)->next
);
3582 mapatoms_1 (sym
, function
)
3583 Lisp_Object sym
, function
;
3585 call1 (function
, sym
);
3588 DEFUN ("mapatoms", Fmapatoms
, Smapatoms
, 1, 2, 0,
3589 doc
: /* Call FUNCTION on every symbol in OBARRAY.
3590 OBARRAY defaults to the value of `obarray'. */)
3592 Lisp_Object function
, obarray
;
3594 if (NILP (obarray
)) obarray
= Vobarray
;
3595 obarray
= check_obarray (obarray
);
3597 map_obarray (obarray
, mapatoms_1
, function
);
3601 #define OBARRAY_SIZE 1511
3606 Lisp_Object oblength
;
3610 XSETFASTINT (oblength
, OBARRAY_SIZE
);
3612 Qnil
= Fmake_symbol (make_pure_string ("nil", 3, 3, 0));
3613 Vobarray
= Fmake_vector (oblength
, make_number (0));
3614 initial_obarray
= Vobarray
;
3615 staticpro (&initial_obarray
);
3616 /* Intern nil in the obarray */
3617 XSYMBOL (Qnil
)->interned
= SYMBOL_INTERNED_IN_INITIAL_OBARRAY
;
3618 XSYMBOL (Qnil
)->constant
= 1;
3620 /* These locals are to kludge around a pyramid compiler bug. */
3621 hash
= hash_string ("nil", 3);
3622 /* Separate statement here to avoid VAXC bug. */
3623 hash
%= OBARRAY_SIZE
;
3624 tem
= &XVECTOR (Vobarray
)->contents
[hash
];
3627 Qunbound
= Fmake_symbol (make_pure_string ("unbound", 7, 7, 0));
3628 XSYMBOL (Qnil
)->function
= Qunbound
;
3629 XSYMBOL (Qunbound
)->value
= Qunbound
;
3630 XSYMBOL (Qunbound
)->function
= Qunbound
;
3633 XSYMBOL (Qnil
)->value
= Qnil
;
3634 XSYMBOL (Qnil
)->plist
= Qnil
;
3635 XSYMBOL (Qt
)->value
= Qt
;
3636 XSYMBOL (Qt
)->constant
= 1;
3638 /* Qt is correct even if CANNOT_DUMP. loadup.el will set to nil at end. */
3641 Qvariable_documentation
= intern ("variable-documentation");
3642 staticpro (&Qvariable_documentation
);
3644 read_buffer_size
= 100 + MAX_MULTIBYTE_LENGTH
;
3645 read_buffer
= (char *) xmalloc (read_buffer_size
);
3650 struct Lisp_Subr
*sname
;
3653 sym
= intern (sname
->symbol_name
);
3654 XSETSUBR (XSYMBOL (sym
)->function
, sname
);
3657 #ifdef NOTDEF /* use fset in subr.el now */
3659 defalias (sname
, string
)
3660 struct Lisp_Subr
*sname
;
3664 sym
= intern (string
);
3665 XSETSUBR (XSYMBOL (sym
)->function
, sname
);
3669 /* Define an "integer variable"; a symbol whose value is forwarded
3670 to a C variable of type int. Sample call: */
3671 /* DEFVAR_INT ("indent-tabs-mode", &indent_tabs_mode, "Documentation"); */
3673 defvar_int (namestring
, address
)
3677 Lisp_Object sym
, val
;
3678 sym
= intern (namestring
);
3679 val
= allocate_misc ();
3680 XMISCTYPE (val
) = Lisp_Misc_Intfwd
;
3681 XINTFWD (val
)->intvar
= address
;
3682 SET_SYMBOL_VALUE (sym
, val
);
3685 /* Similar but define a variable whose value is t if address contains 1,
3686 nil if address contains 0 */
3688 defvar_bool (namestring
, address
)
3692 Lisp_Object sym
, val
;
3693 sym
= intern (namestring
);
3694 val
= allocate_misc ();
3695 XMISCTYPE (val
) = Lisp_Misc_Boolfwd
;
3696 XBOOLFWD (val
)->boolvar
= address
;
3697 SET_SYMBOL_VALUE (sym
, val
);
3698 Vbyte_boolean_vars
= Fcons (sym
, Vbyte_boolean_vars
);
3701 /* Similar but define a variable whose value is the Lisp Object stored
3702 at address. Two versions: with and without gc-marking of the C
3703 variable. The nopro version is used when that variable will be
3704 gc-marked for some other reason, since marking the same slot twice
3705 can cause trouble with strings. */
3707 defvar_lisp_nopro (namestring
, address
)
3709 Lisp_Object
*address
;
3711 Lisp_Object sym
, val
;
3712 sym
= intern (namestring
);
3713 val
= allocate_misc ();
3714 XMISCTYPE (val
) = Lisp_Misc_Objfwd
;
3715 XOBJFWD (val
)->objvar
= address
;
3716 SET_SYMBOL_VALUE (sym
, val
);
3720 defvar_lisp (namestring
, address
)
3722 Lisp_Object
*address
;
3724 defvar_lisp_nopro (namestring
, address
);
3725 staticpro (address
);
3728 /* Similar but define a variable whose value is the Lisp Object stored in
3729 the current buffer. address is the address of the slot in the buffer
3730 that is current now. */
3733 defvar_per_buffer (namestring
, address
, type
, doc
)
3735 Lisp_Object
*address
;
3739 Lisp_Object sym
, val
;
3742 sym
= intern (namestring
);
3743 val
= allocate_misc ();
3744 offset
= (char *)address
- (char *)current_buffer
;
3746 XMISCTYPE (val
) = Lisp_Misc_Buffer_Objfwd
;
3747 XBUFFER_OBJFWD (val
)->offset
= offset
;
3748 SET_SYMBOL_VALUE (sym
, val
);
3749 PER_BUFFER_SYMBOL (offset
) = sym
;
3750 PER_BUFFER_TYPE (offset
) = type
;
3752 if (PER_BUFFER_IDX (offset
) == 0)
3753 /* Did a DEFVAR_PER_BUFFER without initializing the corresponding
3754 slot of buffer_local_flags */
3759 /* Similar but define a variable whose value is the Lisp Object stored
3760 at a particular offset in the current kboard object. */
3763 defvar_kboard (namestring
, offset
)
3767 Lisp_Object sym
, val
;
3768 sym
= intern (namestring
);
3769 val
= allocate_misc ();
3770 XMISCTYPE (val
) = Lisp_Misc_Kboard_Objfwd
;
3771 XKBOARD_OBJFWD (val
)->offset
= offset
;
3772 SET_SYMBOL_VALUE (sym
, val
);
3775 /* Record the value of load-path used at the start of dumping
3776 so we can see if the site changed it later during dumping. */
3777 static Lisp_Object dump_path
;
3783 int turn_off_warning
= 0;
3785 /* Compute the default load-path. */
3787 normal
= PATH_LOADSEARCH
;
3788 Vload_path
= decode_env_path (0, normal
);
3790 if (NILP (Vpurify_flag
))
3791 normal
= PATH_LOADSEARCH
;
3793 normal
= PATH_DUMPLOADSEARCH
;
3795 /* In a dumped Emacs, we normally have to reset the value of
3796 Vload_path from PATH_LOADSEARCH, since the value that was dumped
3797 uses ../lisp, instead of the path of the installed elisp
3798 libraries. However, if it appears that Vload_path was changed
3799 from the default before dumping, don't override that value. */
3802 if (! NILP (Fequal (dump_path
, Vload_path
)))
3804 Vload_path
= decode_env_path (0, normal
);
3805 if (!NILP (Vinstallation_directory
))
3807 Lisp_Object tem
, tem1
, sitelisp
;
3809 /* Remove site-lisp dirs from path temporarily and store
3810 them in sitelisp, then conc them on at the end so
3811 they're always first in path. */
3815 tem
= Fcar (Vload_path
);
3816 tem1
= Fstring_match (build_string ("site-lisp"),
3820 Vload_path
= Fcdr (Vload_path
);
3821 sitelisp
= Fcons (tem
, sitelisp
);
3827 /* Add to the path the lisp subdir of the
3828 installation dir, if it exists. */
3829 tem
= Fexpand_file_name (build_string ("lisp"),
3830 Vinstallation_directory
);
3831 tem1
= Ffile_exists_p (tem
);
3834 if (NILP (Fmember (tem
, Vload_path
)))
3836 turn_off_warning
= 1;
3837 Vload_path
= Fcons (tem
, Vload_path
);
3841 /* That dir doesn't exist, so add the build-time
3842 Lisp dirs instead. */
3843 Vload_path
= nconc2 (Vload_path
, dump_path
);
3845 /* Add leim under the installation dir, if it exists. */
3846 tem
= Fexpand_file_name (build_string ("leim"),
3847 Vinstallation_directory
);
3848 tem1
= Ffile_exists_p (tem
);
3851 if (NILP (Fmember (tem
, Vload_path
)))
3852 Vload_path
= Fcons (tem
, Vload_path
);
3855 /* Add site-list under the installation dir, if it exists. */
3856 tem
= Fexpand_file_name (build_string ("site-lisp"),
3857 Vinstallation_directory
);
3858 tem1
= Ffile_exists_p (tem
);
3861 if (NILP (Fmember (tem
, Vload_path
)))
3862 Vload_path
= Fcons (tem
, Vload_path
);
3865 /* If Emacs was not built in the source directory,
3866 and it is run from where it was built, add to load-path
3867 the lisp, leim and site-lisp dirs under that directory. */
3869 if (NILP (Fequal (Vinstallation_directory
, Vsource_directory
)))
3873 tem
= Fexpand_file_name (build_string ("src/Makefile"),
3874 Vinstallation_directory
);
3875 tem1
= Ffile_exists_p (tem
);
3877 /* Don't be fooled if they moved the entire source tree
3878 AFTER dumping Emacs. If the build directory is indeed
3879 different from the source dir, src/Makefile.in and
3880 src/Makefile will not be found together. */
3881 tem
= Fexpand_file_name (build_string ("src/Makefile.in"),
3882 Vinstallation_directory
);
3883 tem2
= Ffile_exists_p (tem
);
3884 if (!NILP (tem1
) && NILP (tem2
))
3886 tem
= Fexpand_file_name (build_string ("lisp"),
3889 if (NILP (Fmember (tem
, Vload_path
)))
3890 Vload_path
= Fcons (tem
, Vload_path
);
3892 tem
= Fexpand_file_name (build_string ("leim"),
3895 if (NILP (Fmember (tem
, Vload_path
)))
3896 Vload_path
= Fcons (tem
, Vload_path
);
3898 tem
= Fexpand_file_name (build_string ("site-lisp"),
3901 if (NILP (Fmember (tem
, Vload_path
)))
3902 Vload_path
= Fcons (tem
, Vload_path
);
3905 if (!NILP (sitelisp
))
3906 Vload_path
= nconc2 (Fnreverse (sitelisp
), Vload_path
);
3912 /* NORMAL refers to the lisp dir in the source directory. */
3913 /* We used to add ../lisp at the front here, but
3914 that caused trouble because it was copied from dump_path
3915 into Vload_path, aboe, when Vinstallation_directory was non-nil.
3916 It should be unnecessary. */
3917 Vload_path
= decode_env_path (0, normal
);
3918 dump_path
= Vload_path
;
3922 #if (!(defined(WINDOWSNT) || (defined(HAVE_CARBON))))
3923 /* When Emacs is invoked over network shares on NT, PATH_LOADSEARCH is
3924 almost never correct, thereby causing a warning to be printed out that
3925 confuses users. Since PATH_LOADSEARCH is always overridden by the
3926 EMACSLOADPATH environment variable below, disable the warning on NT.
3927 Also, when using the "self-contained" option for Carbon Emacs for MacOSX,
3928 the "standard" paths may not exist and would be overridden by
3929 EMACSLOADPATH as on NT. Since this depends on how the executable
3930 was build and packaged, turn off the warnings in general */
3932 /* Warn if dirs in the *standard* path don't exist. */
3933 if (!turn_off_warning
)
3935 Lisp_Object path_tail
;
3937 for (path_tail
= Vload_path
;
3939 path_tail
= XCDR (path_tail
))
3941 Lisp_Object dirfile
;
3942 dirfile
= Fcar (path_tail
);
3943 if (STRINGP (dirfile
))
3945 dirfile
= Fdirectory_file_name (dirfile
);
3946 if (access (SDATA (dirfile
), 0) < 0)
3947 dir_warning ("Warning: Lisp directory `%s' does not exist.\n",
3952 #endif /* !(WINDOWSNT || HAVE_CARBON) */
3954 /* If the EMACSLOADPATH environment variable is set, use its value.
3955 This doesn't apply if we're dumping. */
3957 if (NILP (Vpurify_flag
)
3958 && egetenv ("EMACSLOADPATH"))
3960 Vload_path
= decode_env_path ("EMACSLOADPATH", normal
);
3964 load_in_progress
= 0;
3965 Vload_file_name
= Qnil
;
3967 load_descriptor_list
= Qnil
;
3969 Vstandard_input
= Qt
;
3970 Vloads_in_progress
= Qnil
;
3973 /* Print a warning, using format string FORMAT, that directory DIRNAME
3974 does not exist. Print it on stderr and put it in *Message*. */
3977 dir_warning (format
, dirname
)
3979 Lisp_Object dirname
;
3982 = (char *) alloca (SCHARS (dirname
) + strlen (format
) + 5);
3984 fprintf (stderr
, format
, SDATA (dirname
));
3985 sprintf (buffer
, format
, SDATA (dirname
));
3986 /* Don't log the warning before we've initialized!! */
3988 message_dolog (buffer
, strlen (buffer
), 0, STRING_MULTIBYTE (dirname
));
3995 defsubr (&Sread_from_string
);
3997 defsubr (&Sintern_soft
);
3998 defsubr (&Sunintern
);
3999 defsubr (&Sget_load_suffixes
);
4001 defsubr (&Seval_buffer
);
4002 defsubr (&Seval_region
);
4003 defsubr (&Sread_char
);
4004 defsubr (&Sread_char_exclusive
);
4005 defsubr (&Sread_event
);
4006 defsubr (&Sget_file_char
);
4007 defsubr (&Smapatoms
);
4008 defsubr (&Slocate_file_internal
);
4010 DEFVAR_LISP ("obarray", &Vobarray
,
4011 doc
: /* Symbol table for use by `intern' and `read'.
4012 It is a vector whose length ought to be prime for best results.
4013 The vector's contents don't make sense if examined from Lisp programs;
4014 to find all the symbols in an obarray, use `mapatoms'. */);
4016 DEFVAR_LISP ("values", &Vvalues
,
4017 doc
: /* List of values of all expressions which were read, evaluated and printed.
4018 Order is reverse chronological. */);
4020 DEFVAR_LISP ("standard-input", &Vstandard_input
,
4021 doc
: /* Stream for read to get input from.
4022 See documentation of `read' for possible values. */);
4023 Vstandard_input
= Qt
;
4025 DEFVAR_LISP ("read-with-symbol-positions", &Vread_with_symbol_positions
,
4026 doc
: /* If non-nil, add position of read symbols to `read-symbol-positions-list'.
4028 If this variable is a buffer, then only forms read from that buffer
4029 will be added to `read-symbol-positions-list'.
4030 If this variable is t, then all read forms will be added.
4031 The effect of all other values other than nil are not currently
4032 defined, although they may be in the future.
4034 The positions are relative to the last call to `read' or
4035 `read-from-string'. It is probably a bad idea to set this variable at
4036 the toplevel; bind it instead. */);
4037 Vread_with_symbol_positions
= Qnil
;
4039 DEFVAR_LISP ("read-symbol-positions-list", &Vread_symbol_positions_list
,
4040 doc
: /* A list mapping read symbols to their positions.
4041 This variable is modified during calls to `read' or
4042 `read-from-string', but only when `read-with-symbol-positions' is
4045 Each element of the list looks like (SYMBOL . CHAR-POSITION), where
4046 CHAR-POSITION is an integer giving the offset of that occurrence of the
4047 symbol from the position where `read' or `read-from-string' started.
4049 Note that a symbol will appear multiple times in this list, if it was
4050 read multiple times. The list is in the same order as the symbols
4052 Vread_symbol_positions_list
= Qnil
;
4054 DEFVAR_LISP ("load-path", &Vload_path
,
4055 doc
: /* *List of directories to search for files to load.
4056 Each element is a string (directory name) or nil (try default directory).
4057 Initialized based on EMACSLOADPATH environment variable, if any,
4058 otherwise to default specified by file `epaths.h' when Emacs was built. */);
4060 DEFVAR_LISP ("load-suffixes", &Vload_suffixes
,
4061 doc
: /* List of suffixes for (compiled or source) Emacs Lisp files.
4062 This list should not include the empty string.
4063 `load' and related functions try to append these suffixes, in order,
4064 to the specified file name if a Lisp suffix is allowed or required. */);
4065 Vload_suffixes
= Fcons (build_string (".elc"),
4066 Fcons (build_string (".el"), Qnil
));
4067 DEFVAR_LISP ("load-file-rep-suffixes", &Vload_file_rep_suffixes
,
4068 doc
: /* List of suffixes that indicate representations of \
4070 This list should normally start with the empty string.
4072 Enabling Auto Compression mode appends the suffixes in
4073 `jka-compr-load-suffixes' to this list and disabling Auto Compression
4074 mode removes them again. `load' and related functions use this list to
4075 determine whether they should look for compressed versions of a file
4076 and, if so, which suffixes they should try to append to the file name
4077 in order to do so. However, if you want to customize which suffixes
4078 the loading functions recognize as compression suffixes, you should
4079 customize `jka-compr-load-suffixes' rather than the present variable. */);
4080 /* We don't use empty_string because it's not initialized yet. */
4081 Vload_file_rep_suffixes
= Fcons (build_string (""), Qnil
);
4083 DEFVAR_BOOL ("load-in-progress", &load_in_progress
,
4084 doc
: /* Non-nil if inside of `load'. */);
4086 DEFVAR_LISP ("after-load-alist", &Vafter_load_alist
,
4087 doc
: /* An alist of expressions to be evalled when particular files are loaded.
4088 Each element looks like (REGEXP-OR-FEATURE FORMS...).
4090 REGEXP-OR-FEATURE is either a regular expression to match file names, or
4091 a symbol \(a feature name).
4093 When `load' is run and the file-name argument matches an element's
4094 REGEXP-OR-FEATURE, or when `provide' is run and provides the symbol
4095 REGEXP-OR-FEATURE, the FORMS in the element are executed.
4097 An error in FORMS does not undo the load, but does prevent execution of
4098 the rest of the FORMS. */);
4099 Vafter_load_alist
= Qnil
;
4101 DEFVAR_LISP ("load-history", &Vload_history
,
4102 doc
: /* Alist mapping file names to symbols and features.
4103 Each alist element is a list that starts with a file name,
4104 except for one element (optional) that starts with nil and describes
4105 definitions evaluated from buffers not visiting files.
4107 The file name is absolute and is the true file name (i.e. it doesn't
4108 contain symbolic links) of the loaded file.
4110 The remaining elements of each list are symbols defined as variables
4111 and cons cells of the form `(provide . FEATURE)', `(require . FEATURE)',
4112 `(defun . FUNCTION)', `(autoload . SYMBOL)', `(defface . SYMBOL)'
4113 and `(t . SYMBOL)'. An element `(t . SYMBOL)' precedes an entry
4114 `(defun . FUNCTION)', and means that SYMBOL was an autoload before
4115 this file redefined it as a function.
4117 During preloading, the file name recorded is relative to the main Lisp
4118 directory. These file names are converted to absolute at startup. */);
4119 Vload_history
= Qnil
;
4121 DEFVAR_LISP ("load-file-name", &Vload_file_name
,
4122 doc
: /* Full name of file being loaded by `load'. */);
4123 Vload_file_name
= Qnil
;
4125 DEFVAR_LISP ("user-init-file", &Vuser_init_file
,
4126 doc
: /* File name, including directory, of user's initialization file.
4127 If the file loaded had extension `.elc', and the corresponding source file
4128 exists, this variable contains the name of source file, suitable for use
4129 by functions like `custom-save-all' which edit the init file.
4130 While Emacs loads and evaluates the init file, value is the real name
4131 of the file, regardless of whether or not it has the `.elc' extension. */);
4132 Vuser_init_file
= Qnil
;
4134 DEFVAR_LISP ("current-load-list", &Vcurrent_load_list
,
4135 doc
: /* Used for internal purposes by `load'. */);
4136 Vcurrent_load_list
= Qnil
;
4138 DEFVAR_LISP ("load-read-function", &Vload_read_function
,
4139 doc
: /* Function used by `load' and `eval-region' for reading expressions.
4140 The default is nil, which means use the function `read'. */);
4141 Vload_read_function
= Qnil
;
4143 DEFVAR_LISP ("load-source-file-function", &Vload_source_file_function
,
4144 doc
: /* Function called in `load' for loading an Emacs Lisp source file.
4145 This function is for doing code conversion before reading the source file.
4146 If nil, loading is done without any code conversion.
4147 Arguments are FULLNAME, FILE, NOERROR, NOMESSAGE, where
4148 FULLNAME is the full name of FILE.
4149 See `load' for the meaning of the remaining arguments. */);
4150 Vload_source_file_function
= Qnil
;
4152 DEFVAR_BOOL ("load-force-doc-strings", &load_force_doc_strings
,
4153 doc
: /* Non-nil means `load' should force-load all dynamic doc strings.
4154 This is useful when the file being loaded is a temporary copy. */);
4155 load_force_doc_strings
= 0;
4157 DEFVAR_BOOL ("load-convert-to-unibyte", &load_convert_to_unibyte
,
4158 doc
: /* Non-nil means `read' converts strings to unibyte whenever possible.
4159 This is normally bound by `load' and `eval-buffer' to control `read',
4160 and is not meant for users to change. */);
4161 load_convert_to_unibyte
= 0;
4163 DEFVAR_LISP ("source-directory", &Vsource_directory
,
4164 doc
: /* Directory in which Emacs sources were found when Emacs was built.
4165 You cannot count on them to still be there! */);
4167 = Fexpand_file_name (build_string ("../"),
4168 Fcar (decode_env_path (0, PATH_DUMPLOADSEARCH
)));
4170 DEFVAR_LISP ("preloaded-file-list", &Vpreloaded_file_list
,
4171 doc
: /* List of files that were preloaded (when dumping Emacs). */);
4172 Vpreloaded_file_list
= Qnil
;
4174 DEFVAR_LISP ("byte-boolean-vars", &Vbyte_boolean_vars
,
4175 doc
: /* List of all DEFVAR_BOOL variables, used by the byte code optimizer. */);
4176 Vbyte_boolean_vars
= Qnil
;
4178 DEFVAR_BOOL ("load-dangerous-libraries", &load_dangerous_libraries
,
4179 doc
: /* Non-nil means load dangerous compiled Lisp files.
4180 Some versions of XEmacs use different byte codes than Emacs. These
4181 incompatible byte codes can make Emacs crash when it tries to execute
4183 load_dangerous_libraries
= 0;
4185 DEFVAR_LISP ("bytecomp-version-regexp", &Vbytecomp_version_regexp
,
4186 doc
: /* Regular expression matching safe to load compiled Lisp files.
4187 When Emacs loads a compiled Lisp file, it reads the first 512 bytes
4188 from the file, and matches them against this regular expression.
4189 When the regular expression matches, the file is considered to be safe
4190 to load. See also `load-dangerous-libraries'. */);
4191 Vbytecomp_version_regexp
4192 = build_string ("^;;;.\\(in Emacs version\\|bytecomp version FSF\\)");
4194 DEFVAR_LISP ("eval-buffer-list", &Veval_buffer_list
,
4195 doc
: /* List of buffers being read from by calls to `eval-buffer' and `eval-region'. */);
4196 Veval_buffer_list
= Qnil
;
4198 DEFVAR_LISP ("old-style-backquotes", &Vold_style_backquotes
,
4199 doc
: /* Set to non-nil when `read' encounters an old-style backquote. */);
4200 Vold_style_backquotes
= Qnil
;
4202 /* Vsource_directory was initialized in init_lread. */
4204 load_descriptor_list
= Qnil
;
4205 staticpro (&load_descriptor_list
);
4207 Qcurrent_load_list
= intern ("current-load-list");
4208 staticpro (&Qcurrent_load_list
);
4210 Qstandard_input
= intern ("standard-input");
4211 staticpro (&Qstandard_input
);
4213 Qread_char
= intern ("read-char");
4214 staticpro (&Qread_char
);
4216 Qget_file_char
= intern ("get-file-char");
4217 staticpro (&Qget_file_char
);
4219 Qbackquote
= intern ("`");
4220 staticpro (&Qbackquote
);
4221 Qcomma
= intern (",");
4222 staticpro (&Qcomma
);
4223 Qcomma_at
= intern (",@");
4224 staticpro (&Qcomma_at
);
4225 Qcomma_dot
= intern (",.");
4226 staticpro (&Qcomma_dot
);
4228 Qinhibit_file_name_operation
= intern ("inhibit-file-name-operation");
4229 staticpro (&Qinhibit_file_name_operation
);
4231 Qascii_character
= intern ("ascii-character");
4232 staticpro (&Qascii_character
);
4234 Qfunction
= intern ("function");
4235 staticpro (&Qfunction
);
4237 Qload
= intern ("load");
4240 Qload_file_name
= intern ("load-file-name");
4241 staticpro (&Qload_file_name
);
4243 Qeval_buffer_list
= intern ("eval-buffer-list");
4244 staticpro (&Qeval_buffer_list
);
4246 Qfile_truename
= intern ("file-truename");
4247 staticpro (&Qfile_truename
) ;
4249 Qdo_after_load_evaluation
= intern ("do-after-load-evaluation");
4250 staticpro (&Qdo_after_load_evaluation
) ;
4252 staticpro (&dump_path
);
4254 staticpro (&read_objects
);
4255 read_objects
= Qnil
;
4256 staticpro (&seen_list
);
4259 Vloads_in_progress
= Qnil
;
4260 staticpro (&Vloads_in_progress
);
4263 /* arch-tag: a0d02733-0f96-4844-a659-9fd53c4f414d
4264 (do not change this comment) */