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 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 2, 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>
32 #include "intervals.h"
39 #include "termhooks.h"
43 #include <sys/inode.h>
48 #include <unistd.h> /* to get X_OK */
65 #endif /* HAVE_SETLOCALE */
75 #define file_offset off_t
76 #define file_tell ftello
78 #define file_offset long
79 #define file_tell ftell
86 Lisp_Object Qread_char
, Qget_file_char
, Qstandard_input
, Qcurrent_load_list
;
87 Lisp_Object Qvariable_documentation
, Vvalues
, Vstandard_input
, Vafter_load_alist
;
88 Lisp_Object Qascii_character
, Qload
, Qload_file_name
;
89 Lisp_Object Qbackquote
, Qcomma
, Qcomma_at
, Qcomma_dot
, Qfunction
;
90 Lisp_Object Qinhibit_file_name_operation
;
91 Lisp_Object Qeval_buffer_list
, Veval_buffer_list
;
92 Lisp_Object Qfile_truename
, Qdo_after_load_evaluation
; /* ACM 2006/5/16 */
94 extern Lisp_Object Qevent_symbol_element_mask
;
95 extern Lisp_Object Qfile_exists_p
;
97 /* non-zero iff inside `load' */
100 /* Directory in which the sources were found. */
101 Lisp_Object Vsource_directory
;
103 /* Search path and suffixes for files to be loaded. */
104 Lisp_Object Vload_path
, Vload_suffixes
, Vload_file_rep_suffixes
;
106 /* File name of user's init file. */
107 Lisp_Object Vuser_init_file
;
109 /* This is the user-visible association list that maps features to
110 lists of defs in their load files. */
111 Lisp_Object Vload_history
;
113 /* This is used to build the load history. */
114 Lisp_Object Vcurrent_load_list
;
116 /* List of files that were preloaded. */
117 Lisp_Object Vpreloaded_file_list
;
119 /* Name of file actually being read by `load'. */
120 Lisp_Object Vload_file_name
;
122 /* Function to use for reading, in `load' and friends. */
123 Lisp_Object Vload_read_function
;
125 /* The association list of objects read with the #n=object form.
126 Each member of the list has the form (n . object), and is used to
127 look up the object for the corresponding #n# construct.
128 It must be set to nil before all top-level calls to read0. */
129 Lisp_Object read_objects
;
131 /* Nonzero means load should forcibly load all dynamic doc strings. */
132 static int load_force_doc_strings
;
134 /* Nonzero means read should convert strings to unibyte. */
135 static int load_convert_to_unibyte
;
137 /* Function to use for loading an Emacs lisp source file (not
138 compiled) instead of readevalloop. */
139 Lisp_Object Vload_source_file_function
;
141 /* List of all DEFVAR_BOOL variables. Used by the byte optimizer. */
142 Lisp_Object Vbyte_boolean_vars
;
144 /* Whether or not to add a `read-positions' property to symbols
146 Lisp_Object Vread_with_symbol_positions
;
148 /* List of (SYMBOL . POSITION) accumulated so far. */
149 Lisp_Object Vread_symbol_positions_list
;
151 /* List of descriptors now open for Fload. */
152 static Lisp_Object load_descriptor_list
;
154 /* File for get_file_char to read from. Use by load. */
155 static FILE *instream
;
157 /* When nonzero, read conses in pure space */
158 static int read_pure
;
160 /* For use within read-from-string (this reader is non-reentrant!!) */
161 static int read_from_string_index
;
162 static int read_from_string_index_byte
;
163 static int read_from_string_limit
;
165 /* Number of bytes left to read in the buffer character
166 that `readchar' has already advanced over. */
167 static int readchar_backlog
;
168 /* Number of characters read in the current call to Fread or
169 Fread_from_string. */
170 static int readchar_count
;
172 /* This contains the last string skipped with #@. */
173 static char *saved_doc_string
;
174 /* Length of buffer allocated in saved_doc_string. */
175 static int saved_doc_string_size
;
176 /* Length of actual data in saved_doc_string. */
177 static int saved_doc_string_length
;
178 /* This is the file position that string came from. */
179 static file_offset saved_doc_string_position
;
181 /* This contains the previous string skipped with #@.
182 We copy it from saved_doc_string when a new string
183 is put in saved_doc_string. */
184 static char *prev_saved_doc_string
;
185 /* Length of buffer allocated in prev_saved_doc_string. */
186 static int prev_saved_doc_string_size
;
187 /* Length of actual data in prev_saved_doc_string. */
188 static int prev_saved_doc_string_length
;
189 /* This is the file position that string came from. */
190 static file_offset prev_saved_doc_string_position
;
192 /* Nonzero means inside a new-style backquote
193 with no surrounding parentheses.
194 Fread initializes this to zero, so we need not specbind it
195 or worry about what happens to it when there is an error. */
196 static int new_backquote_flag
;
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
))
331 /* Interrupted reads have been observed while reading over the network */
332 while (c
== EOF
&& ferror (instream
) && errno
== EINTR
)
342 if (STRINGP (readcharfun
))
344 if (read_from_string_index
>= read_from_string_limit
)
347 FETCH_STRING_CHAR_ADVANCE (c
, readcharfun
,
348 read_from_string_index
,
349 read_from_string_index_byte
);
354 tem
= call0 (readcharfun
);
361 /* Unread the character C in the way appropriate for the stream READCHARFUN.
362 If the stream is a user function, call it with the char as argument. */
365 unreadchar (readcharfun
, c
)
366 Lisp_Object readcharfun
;
371 /* Don't back up the pointer if we're unreading the end-of-input mark,
372 since readchar didn't advance it when we read it. */
374 else if (BUFFERP (readcharfun
))
376 struct buffer
*b
= XBUFFER (readcharfun
);
377 int bytepos
= BUF_PT_BYTE (b
);
379 if (readchar_backlog
>= 0)
384 if (! NILP (b
->enable_multibyte_characters
))
385 BUF_DEC_POS (b
, bytepos
);
389 BUF_PT_BYTE (b
) = bytepos
;
392 else if (MARKERP (readcharfun
))
394 struct buffer
*b
= XMARKER (readcharfun
)->buffer
;
395 int bytepos
= XMARKER (readcharfun
)->bytepos
;
397 if (readchar_backlog
>= 0)
401 XMARKER (readcharfun
)->charpos
--;
402 if (! NILP (b
->enable_multibyte_characters
))
403 BUF_DEC_POS (b
, bytepos
);
407 XMARKER (readcharfun
)->bytepos
= bytepos
;
410 else if (STRINGP (readcharfun
))
412 read_from_string_index
--;
413 read_from_string_index_byte
414 = string_char_to_byte (readcharfun
, read_from_string_index
);
416 else if (EQ (readcharfun
, Qlambda
))
417 read_bytecode_char (1);
418 else if (EQ (readcharfun
, Qget_file_char
))
419 ungetc (c
, instream
);
421 call1 (readcharfun
, make_number (c
));
424 static Lisp_Object read_internal_start
P_ ((Lisp_Object
, Lisp_Object
,
426 static Lisp_Object read0
P_ ((Lisp_Object
));
427 static Lisp_Object read1
P_ ((Lisp_Object
, int *, int));
429 static Lisp_Object read_list
P_ ((int, Lisp_Object
));
430 static Lisp_Object read_vector
P_ ((Lisp_Object
, int));
431 static int read_multibyte
P_ ((int, Lisp_Object
));
433 static Lisp_Object substitute_object_recurse
P_ ((Lisp_Object
, Lisp_Object
,
435 static void substitute_object_in_subtree
P_ ((Lisp_Object
,
437 static void substitute_in_interval
P_ ((INTERVAL
, Lisp_Object
));
440 /* Get a character from the tty. */
442 /* Read input events until we get one that's acceptable for our purposes.
444 If NO_SWITCH_FRAME is non-zero, switch-frame events are stashed
445 until we get a character we like, and then stuffed into
448 If ASCII_REQUIRED is non-zero, we check function key events to see
449 if the unmodified version of the symbol has a Qascii_character
450 property, and use that character, if present.
452 If ERROR_NONASCII is non-zero, we signal an error if the input we
453 get isn't an ASCII character with modifiers. If it's zero but
454 ASCII_REQUIRED is non-zero, we just re-read until we get an ASCII
457 If INPUT_METHOD is nonzero, we invoke the current input method
458 if the character warrants that.
460 If SECONDS is a number, we wait that many seconds for input, and
461 return Qnil if no input arrives within that time. */
464 read_filtered_event (no_switch_frame
, ascii_required
, error_nonascii
,
465 input_method
, seconds
)
466 int no_switch_frame
, ascii_required
, error_nonascii
, input_method
;
469 Lisp_Object val
, delayed_switch_frame
;
472 #ifdef HAVE_WINDOW_SYSTEM
473 if (display_hourglass_p
)
477 delayed_switch_frame
= Qnil
;
479 /* Compute timeout. */
480 if (NUMBERP (seconds
))
482 EMACS_TIME wait_time
;
484 double duration
= extract_float (seconds
);
486 sec
= (int) duration
;
487 usec
= (duration
- sec
) * 1000000;
488 EMACS_GET_TIME (end_time
);
489 EMACS_SET_SECS_USECS (wait_time
, sec
, usec
);
490 EMACS_ADD_TIME (end_time
, end_time
, wait_time
);
493 /* Read until we get an acceptable event. */
496 val
= read_char (0, 0, 0, (input_method
? Qnil
: Qt
), 0,
497 NUMBERP (seconds
) ? &end_time
: NULL
);
498 while (INTEGERP (val
) && XINT (val
) == -2); /* wrong_kboard_jmpbuf */
503 /* switch-frame events are put off until after the next ASCII
504 character. This is better than signaling an error just because
505 the last characters were typed to a separate minibuffer frame,
506 for example. Eventually, some code which can deal with
507 switch-frame events will read it and process it. */
509 && EVENT_HAS_PARAMETERS (val
)
510 && EQ (EVENT_HEAD_KIND (EVENT_HEAD (val
)), Qswitch_frame
))
512 delayed_switch_frame
= val
;
516 if (ascii_required
&& !(NUMBERP (seconds
) && NILP (val
)))
518 /* Convert certain symbols to their ASCII equivalents. */
521 Lisp_Object tem
, tem1
;
522 tem
= Fget (val
, Qevent_symbol_element_mask
);
525 tem1
= Fget (Fcar (tem
), Qascii_character
);
526 /* Merge this symbol's modifier bits
527 with the ASCII equivalent of its basic code. */
529 XSETFASTINT (val
, XINT (tem1
) | XINT (Fcar (Fcdr (tem
))));
533 /* If we don't have a character now, deal with it appropriately. */
538 Vunread_command_events
= Fcons (val
, Qnil
);
539 error ("Non-character input-event");
546 if (! NILP (delayed_switch_frame
))
547 unread_switch_frame
= delayed_switch_frame
;
551 #ifdef HAVE_WINDOW_SYSTEM
552 if (display_hourglass_p
)
561 DEFUN ("read-char", Fread_char
, Sread_char
, 0, 3, 0,
562 doc
: /* Read a character from the command input (keyboard or macro).
563 It is returned as a number.
564 If the user generates an event which is not a character (i.e. a mouse
565 click or function key event), `read-char' signals an error. As an
566 exception, switch-frame events are put off until non-ASCII events can
568 If you want to read non-character events, or ignore them, call
569 `read-event' or `read-char-exclusive' instead.
571 If the optional argument PROMPT is non-nil, display that as a prompt.
572 If the optional argument INHERIT-INPUT-METHOD is non-nil and some
573 input method is turned on in the current buffer, that input method
574 is used for reading a character.
575 If the optional argument SECONDS is non-nil, it should be a number
576 specifying the maximum number of seconds to wait for input. If no
577 input arrives in that time, return nil. SECONDS may be a
578 floating-point value. */)
579 (prompt
, inherit_input_method
, seconds
)
580 Lisp_Object prompt
, inherit_input_method
, seconds
;
583 message_with_string ("%s", prompt
, 0);
584 return read_filtered_event (1, 1, 1, ! NILP (inherit_input_method
), seconds
);
587 DEFUN ("read-event", Fread_event
, Sread_event
, 0, 3, 0,
588 doc
: /* Read an event object from the input stream.
589 If the optional argument PROMPT is non-nil, display that as a prompt.
590 If the optional argument INHERIT-INPUT-METHOD is non-nil and some
591 input method is turned on in the current buffer, that input method
592 is used for reading a character.
593 If the optional argument SECONDS is non-nil, it should be a number
594 specifying the maximum number of seconds to wait for input. If no
595 input arrives in that time, return nil. SECONDS may be a
596 floating-point value. */)
597 (prompt
, inherit_input_method
, seconds
)
598 Lisp_Object prompt
, inherit_input_method
, seconds
;
601 message_with_string ("%s", prompt
, 0);
602 return read_filtered_event (0, 0, 0, ! NILP (inherit_input_method
), seconds
);
605 DEFUN ("read-char-exclusive", Fread_char_exclusive
, Sread_char_exclusive
, 0, 3, 0,
606 doc
: /* Read a character from the command input (keyboard or macro).
607 It is returned as a number. Non-character events are ignored.
609 If the optional argument PROMPT is non-nil, display that as a prompt.
610 If the optional argument INHERIT-INPUT-METHOD is non-nil and some
611 input method is turned on in the current buffer, that input method
612 is used for reading a character.
613 If the optional argument SECONDS is non-nil, it should be a number
614 specifying the maximum number of seconds to wait for input. If no
615 input arrives in that time, return nil. SECONDS may be a
616 floating-point value. */)
617 (prompt
, inherit_input_method
, seconds
)
618 Lisp_Object prompt
, inherit_input_method
, seconds
;
621 message_with_string ("%s", prompt
, 0);
622 return read_filtered_event (1, 1, 0, ! NILP (inherit_input_method
), seconds
);
625 DEFUN ("get-file-char", Fget_file_char
, Sget_file_char
, 0, 0, 0,
626 doc
: /* Don't use this yourself. */)
629 register Lisp_Object val
;
630 XSETINT (val
, getc (instream
));
636 /* Value is non-zero if the file asswociated with file descriptor FD
637 is a compiled Lisp file that's safe to load. Only files compiled
638 with Emacs are safe to load. Files compiled with XEmacs can lead
639 to a crash in Fbyte_code because of an incompatible change in the
650 /* Read the first few bytes from the file, and look for a line
651 specifying the byte compiler version used. */
652 nbytes
= emacs_read (fd
, buf
, sizeof buf
- 1);
657 /* Skip to the next newline, skipping over the initial `ELC'
658 with NUL bytes following it. */
659 for (i
= 0; i
< nbytes
&& buf
[i
] != '\n'; ++i
)
663 && fast_c_string_match_ignore_case (Vbytecomp_version_regexp
,
668 lseek (fd
, 0, SEEK_SET
);
673 /* Callback for record_unwind_protect. Restore the old load list OLD,
674 after loading a file successfully. */
677 record_load_unwind (old
)
680 return Vloads_in_progress
= old
;
683 /* This handler function is used via internal_condition_case_1. */
686 load_error_handler (data
)
692 DEFUN ("get-load-suffixes", Fget_load_suffixes
, Sget_load_suffixes
, 0, 0, 0,
693 doc
: /* Return the suffixes that `load' should try if a suffix is \
695 This uses the variables `load-suffixes' and `load-file-rep-suffixes'. */)
698 Lisp_Object lst
= Qnil
, suffixes
= Vload_suffixes
, suffix
, ext
;
699 while (CONSP (suffixes
))
701 Lisp_Object exts
= Vload_file_rep_suffixes
;
702 suffix
= XCAR (suffixes
);
703 suffixes
= XCDR (suffixes
);
708 lst
= Fcons (concat2 (suffix
, ext
), lst
);
711 return Fnreverse (lst
);
714 DEFUN ("load", Fload
, Sload
, 1, 5, 0,
715 doc
: /* Execute a file of Lisp code named FILE.
716 First try FILE with `.elc' appended, then try with `.el',
717 then try FILE unmodified (the exact suffixes in the exact order are
718 determined by `load-suffixes'). Environment variable references in
719 FILE are replaced with their values by calling `substitute-in-file-name'.
720 This function searches the directories in `load-path'.
722 If optional second arg NOERROR is non-nil,
723 report no error if FILE doesn't exist.
724 Print messages at start and end of loading unless
725 optional third arg NOMESSAGE is non-nil.
726 If optional fourth arg NOSUFFIX is non-nil, don't try adding
727 suffixes `.elc' or `.el' to the specified name FILE.
728 If optional fifth arg MUST-SUFFIX is non-nil, insist on
729 the suffix `.elc' or `.el'; don't accept just FILE unless
730 it ends in one of those suffixes or includes a directory name.
732 If this function fails to find a file, it may look for different
733 representations of that file before trying another file.
734 It does so by adding the non-empty suffixes in `load-file-rep-suffixes'
735 to the file name. Emacs uses this feature mainly to find compressed
736 versions of files when Auto Compression mode is enabled.
738 The exact suffixes that this function tries out, in the exact order,
739 are given by the value of the variable `load-file-rep-suffixes' if
740 NOSUFFIX is non-nil and by the return value of the function
741 `get-load-suffixes' if MUST-SUFFIX is non-nil. If both NOSUFFIX and
742 MUST-SUFFIX are nil, this function first tries out the latter suffixes
745 Loading a file records its definitions, and its `provide' and
746 `require' calls, in an element of `load-history' whose
747 car is the file name loaded. See `load-history'.
749 Return t if the file exists and loads successfully. */)
750 (file
, noerror
, nomessage
, nosuffix
, must_suffix
)
751 Lisp_Object file
, noerror
, nomessage
, nosuffix
, must_suffix
;
753 register FILE *stream
;
754 register int fd
= -1;
755 int count
= SPECPDL_INDEX ();
757 struct gcpro gcpro1
, gcpro2
, gcpro3
;
758 Lisp_Object found
, efound
, hist_file_name
;
759 /* 1 means we printed the ".el is newer" message. */
761 /* 1 means we are loading a compiled file. */
773 /* If file name is magic, call the handler. */
774 /* This shouldn't be necessary any more now that `openp' handles it right.
775 handler = Ffind_file_name_handler (file, Qload);
777 return call5 (handler, Qload, file, noerror, nomessage, nosuffix); */
779 /* Do this after the handler to avoid
780 the need to gcpro noerror, nomessage and nosuffix.
781 (Below here, we care only whether they are nil or not.)
782 The presence of this call is the result of a historical accident:
783 it used to be in every file-operation and when it got removed
784 everywhere, it accidentally stayed here. Since then, enough people
785 supposedly have things like (load "$PROJECT/foo.el") in their .emacs
786 that it seemed risky to remove. */
787 if (! NILP (noerror
))
789 file
= internal_condition_case_1 (Fsubstitute_in_file_name
, file
,
790 Qt
, load_error_handler
);
795 file
= Fsubstitute_in_file_name (file
);
798 /* Avoid weird lossage with null string as arg,
799 since it would try to load a directory as a Lisp file */
800 if (SCHARS (file
) > 0)
802 int size
= SBYTES (file
);
805 GCPRO2 (file
, found
);
807 if (! NILP (must_suffix
))
809 /* Don't insist on adding a suffix if FILE already ends with one. */
811 && !strcmp (SDATA (file
) + size
- 3, ".el"))
814 && !strcmp (SDATA (file
) + size
- 4, ".elc"))
816 /* Don't insist on adding a suffix
817 if the argument includes a directory name. */
818 else if (! NILP (Ffile_name_directory (file
)))
822 fd
= openp (Vload_path
, file
,
823 (!NILP (nosuffix
) ? Qnil
824 : !NILP (must_suffix
) ? Fget_load_suffixes ()
825 : Fappend (2, (tmp
[0] = Fget_load_suffixes (),
826 tmp
[1] = Vload_file_rep_suffixes
,
835 xsignal2 (Qfile_error
, build_string ("Cannot open load file"), file
);
839 /* Tell startup.el whether or not we found the user's init file. */
840 if (EQ (Qt
, Vuser_init_file
))
841 Vuser_init_file
= found
;
843 /* If FD is -2, that means openp found a magic file. */
846 if (NILP (Fequal (found
, file
)))
847 /* If FOUND is a different file name from FILE,
848 find its handler even if we have already inhibited
849 the `load' operation on FILE. */
850 handler
= Ffind_file_name_handler (found
, Qt
);
852 handler
= Ffind_file_name_handler (found
, Qload
);
853 if (! NILP (handler
))
854 return call5 (handler
, Qload
, found
, noerror
, nomessage
, Qt
);
857 /* Check if we're stuck in a recursive load cycle.
859 2000-09-21: It's not possible to just check for the file loaded
860 being a member of Vloads_in_progress. This fails because of the
861 way the byte compiler currently works; `provide's are not
862 evaluted, see font-lock.el/jit-lock.el as an example. This
863 leads to a certain amount of ``normal'' recursion.
865 Also, just loading a file recursively is not always an error in
866 the general case; the second load may do something different. */
870 for (tem
= Vloads_in_progress
; CONSP (tem
); tem
= XCDR (tem
))
871 if (!NILP (Fequal (found
, XCAR (tem
))))
877 signal_error ("Recursive load", Fcons (found
, Vloads_in_progress
));
879 record_unwind_protect (record_load_unwind
, Vloads_in_progress
);
880 Vloads_in_progress
= Fcons (found
, Vloads_in_progress
);
883 /* Get the name for load-history. */
884 hist_file_name
= (! NILP (Vpurify_flag
)
885 ? Fconcat (2, (tmp
[0] = Ffile_name_directory (file
),
886 tmp
[1] = Ffile_name_nondirectory (found
),
890 if (!bcmp (SDATA (found
) + SBYTES (found
) - 4,
892 /* Load .elc files directly, but not when they are
893 remote and have no handler! */
900 GCPRO3 (file
, found
, hist_file_name
);
902 if (!safe_to_load_p (fd
))
905 if (!load_dangerous_libraries
)
909 error ("File `%s' was not compiled in Emacs",
912 else if (!NILP (nomessage
))
913 message_with_string ("File `%s' not compiled in Emacs", found
, 1);
918 efound
= ENCODE_FILE (found
);
923 stat ((char *)SDATA (efound
), &s1
);
924 SSET (efound
, SBYTES (efound
) - 1, 0);
925 result
= stat ((char *)SDATA (efound
), &s2
);
926 SSET (efound
, SBYTES (efound
) - 1, 'c');
928 if (result
>= 0 && (unsigned) s1
.st_mtime
< (unsigned) s2
.st_mtime
)
930 /* Make the progress messages mention that source is newer. */
933 /* If we won't print another message, mention this anyway. */
934 if (!NILP (nomessage
))
936 Lisp_Object msg_file
;
937 msg_file
= Fsubstring (found
, make_number (0), make_number (-1));
938 message_with_string ("Source file `%s' newer than byte-compiled file",
947 /* We are loading a source file (*.el). */
948 if (!NILP (Vload_source_file_function
))
954 val
= call4 (Vload_source_file_function
, found
, hist_file_name
,
955 NILP (noerror
) ? Qnil
: Qt
,
956 NILP (nomessage
) ? Qnil
: Qt
);
957 return unbind_to (count
, val
);
961 GCPRO3 (file
, found
, hist_file_name
);
965 efound
= ENCODE_FILE (found
);
966 stream
= fopen ((char *) SDATA (efound
), fmode
);
967 #else /* not WINDOWSNT */
968 stream
= fdopen (fd
, fmode
);
969 #endif /* not WINDOWSNT */
973 error ("Failure to create stdio stream for %s", SDATA (file
));
976 if (! NILP (Vpurify_flag
))
977 Vpreloaded_file_list
= Fcons (file
, Vpreloaded_file_list
);
979 if (NILP (nomessage
))
982 message_with_string ("Loading %s (compiled; note unsafe, not compiled in Emacs)...",
985 message_with_string ("Loading %s (source)...", file
, 1);
987 message_with_string ("Loading %s (compiled; note, source file is newer)...",
989 else /* The typical case; compiled file newer than source file. */
990 message_with_string ("Loading %s...", file
, 1);
993 record_unwind_protect (load_unwind
, make_save_value (stream
, 0));
994 record_unwind_protect (load_descriptor_unwind
, load_descriptor_list
);
995 specbind (Qload_file_name
, found
);
996 specbind (Qinhibit_file_name_operation
, Qnil
);
998 = Fcons (make_number (fileno (stream
)), load_descriptor_list
);
1000 readevalloop (Qget_file_char
, stream
, hist_file_name
,
1001 Feval
, 0, Qnil
, Qnil
, Qnil
, Qnil
);
1002 unbind_to (count
, Qnil
);
1004 /* Run any eval-after-load forms for this file */
1005 if (NILP (Vpurify_flag
)
1006 && (!NILP (Ffboundp (Qdo_after_load_evaluation
))))
1007 call1 (Qdo_after_load_evaluation
, hist_file_name
) ;
1011 if (saved_doc_string
)
1012 free (saved_doc_string
);
1013 saved_doc_string
= 0;
1014 saved_doc_string_size
= 0;
1016 if (prev_saved_doc_string
)
1017 xfree (prev_saved_doc_string
);
1018 prev_saved_doc_string
= 0;
1019 prev_saved_doc_string_size
= 0;
1021 if (!noninteractive
&& NILP (nomessage
))
1024 message_with_string ("Loading %s (compiled; note unsafe, not compiled in Emacs)...done",
1027 message_with_string ("Loading %s (source)...done", file
, 1);
1029 message_with_string ("Loading %s (compiled; note, source file is newer)...done",
1031 else /* The typical case; compiled file newer than source file. */
1032 message_with_string ("Loading %s...done", file
, 1);
1035 if (!NILP (Fequal (build_string ("obsolete"),
1036 Ffile_name_nondirectory
1037 (Fdirectory_file_name (Ffile_name_directory (found
))))))
1038 message_with_string ("Package %s is obsolete", file
, 1);
1044 load_unwind (arg
) /* used as unwind-protect function in load */
1047 FILE *stream
= (FILE *) XSAVE_VALUE (arg
)->pointer
;
1050 if (--load_in_progress
< 0) load_in_progress
= 0;
1055 load_descriptor_unwind (oldlist
)
1056 Lisp_Object oldlist
;
1058 load_descriptor_list
= oldlist
;
1062 /* Close all descriptors in use for Floads.
1063 This is used when starting a subprocess. */
1070 for (tail
= load_descriptor_list
; !NILP (tail
); tail
= XCDR (tail
))
1071 emacs_close (XFASTINT (XCAR (tail
)));
1076 complete_filename_p (pathname
)
1077 Lisp_Object pathname
;
1079 register const unsigned char *s
= SDATA (pathname
);
1080 return (IS_DIRECTORY_SEP (s
[0])
1081 || (SCHARS (pathname
) > 2
1082 && IS_DEVICE_SEP (s
[1]) && IS_DIRECTORY_SEP (s
[2]))
1092 DEFUN ("locate-file-internal", Flocate_file_internal
, Slocate_file_internal
, 2, 4, 0,
1093 doc
: /* Search for FILENAME through PATH.
1094 Returns the file's name in absolute form, or nil if not found.
1095 If SUFFIXES is non-nil, it should be a list of suffixes to append to
1096 file name when searching.
1097 If non-nil, PREDICATE is used instead of `file-readable-p'.
1098 PREDICATE can also be an integer to pass to the access(2) function,
1099 in which case file-name-handlers are ignored. */)
1100 (filename
, path
, suffixes
, predicate
)
1101 Lisp_Object filename
, path
, suffixes
, predicate
;
1104 int fd
= openp (path
, filename
, suffixes
, &file
, predicate
);
1105 if (NILP (predicate
) && fd
> 0)
1111 /* Search for a file whose name is STR, looking in directories
1112 in the Lisp list PATH, and trying suffixes from SUFFIX.
1113 On success, returns a file descriptor. On failure, returns -1.
1115 SUFFIXES is a list of strings containing possible suffixes.
1116 The empty suffix is automatically added iff the list is empty.
1118 PREDICATE non-nil means don't open the files,
1119 just look for one that satisfies the predicate. In this case,
1120 returns 1 on success. The predicate can be a lisp function or
1121 an integer to pass to `access' (in which case file-name-handlers
1124 If STOREPTR is nonzero, it points to a slot where the name of
1125 the file actually found should be stored as a Lisp string.
1126 nil is stored there on failure.
1128 If the file we find is remote, return -2
1129 but store the found remote file name in *STOREPTR. */
1132 openp (path
, str
, suffixes
, storeptr
, predicate
)
1133 Lisp_Object path
, str
;
1134 Lisp_Object suffixes
;
1135 Lisp_Object
*storeptr
;
1136 Lisp_Object predicate
;
1141 register char *fn
= buf
;
1144 Lisp_Object filename
;
1146 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
, gcpro5
, gcpro6
;
1147 Lisp_Object string
, tail
, encoded_fn
;
1148 int max_suffix_len
= 0;
1152 for (tail
= suffixes
; CONSP (tail
); tail
= XCDR (tail
))
1154 CHECK_STRING_CAR (tail
);
1155 max_suffix_len
= max (max_suffix_len
,
1156 SBYTES (XCAR (tail
)));
1159 string
= filename
= encoded_fn
= Qnil
;
1160 GCPRO6 (str
, string
, filename
, path
, suffixes
, encoded_fn
);
1165 if (complete_filename_p (str
))
1168 for (; CONSP (path
); path
= XCDR (path
))
1170 filename
= Fexpand_file_name (str
, XCAR (path
));
1171 if (!complete_filename_p (filename
))
1172 /* If there are non-absolute elts in PATH (eg ".") */
1173 /* Of course, this could conceivably lose if luser sets
1174 default-directory to be something non-absolute... */
1176 filename
= Fexpand_file_name (filename
, current_buffer
->directory
);
1177 if (!complete_filename_p (filename
))
1178 /* Give up on this path element! */
1182 /* Calculate maximum size of any filename made from
1183 this path element/specified file name and any possible suffix. */
1184 want_size
= max_suffix_len
+ SBYTES (filename
) + 1;
1185 if (fn_size
< want_size
)
1186 fn
= (char *) alloca (fn_size
= 100 + want_size
);
1188 /* Loop over suffixes. */
1189 for (tail
= NILP (suffixes
) ? Fcons (build_string (""), Qnil
) : suffixes
;
1190 CONSP (tail
); tail
= XCDR (tail
))
1192 int lsuffix
= SBYTES (XCAR (tail
));
1193 Lisp_Object handler
;
1196 /* Concatenate path element/specified name with the suffix.
1197 If the directory starts with /:, remove that. */
1198 if (SCHARS (filename
) > 2
1199 && SREF (filename
, 0) == '/'
1200 && SREF (filename
, 1) == ':')
1202 strncpy (fn
, SDATA (filename
) + 2,
1203 SBYTES (filename
) - 2);
1204 fn
[SBYTES (filename
) - 2] = 0;
1208 strncpy (fn
, SDATA (filename
),
1210 fn
[SBYTES (filename
)] = 0;
1213 if (lsuffix
!= 0) /* Bug happens on CCI if lsuffix is 0. */
1214 strncat (fn
, SDATA (XCAR (tail
)), lsuffix
);
1216 /* Check that the file exists and is not a directory. */
1217 /* We used to only check for handlers on non-absolute file names:
1221 handler = Ffind_file_name_handler (filename, Qfile_exists_p);
1222 It's not clear why that was the case and it breaks things like
1223 (load "/bar.el") where the file is actually "/bar.el.gz". */
1224 string
= build_string (fn
);
1225 handler
= Ffind_file_name_handler (string
, Qfile_exists_p
);
1226 if ((!NILP (handler
) || !NILP (predicate
)) && !NATNUMP (predicate
))
1228 if (NILP (predicate
))
1229 exists
= !NILP (Ffile_readable_p (string
));
1231 exists
= !NILP (call1 (predicate
, string
));
1232 if (exists
&& !NILP (Ffile_directory_p (string
)))
1237 /* We succeeded; return this descriptor and filename. */
1248 encoded_fn
= ENCODE_FILE (string
);
1249 pfn
= SDATA (encoded_fn
);
1250 exists
= (stat (pfn
, &st
) >= 0
1251 && (st
.st_mode
& S_IFMT
) != S_IFDIR
);
1254 /* Check that we can access or open it. */
1255 if (NATNUMP (predicate
))
1256 fd
= (access (pfn
, XFASTINT (predicate
)) == 0) ? 1 : -1;
1258 fd
= emacs_open (pfn
, O_RDONLY
, 0);
1262 /* We succeeded; return this descriptor and filename. */
1280 /* Merge the list we've accumulated of globals from the current input source
1281 into the load_history variable. The details depend on whether
1282 the source has an associated file name or not.
1284 FILENAME is the file name that we are loading from.
1285 ENTIRE is 1 if loading that entire file, 0 if evaluating part of it. */
1288 build_load_history (filename
, entire
)
1289 Lisp_Object filename
;
1292 register Lisp_Object tail
, prev
, newelt
;
1293 register Lisp_Object tem
, tem2
;
1294 register int foundit
= 0;
1296 tail
= Vload_history
;
1299 while (CONSP (tail
))
1303 /* Find the feature's previous assoc list... */
1304 if (!NILP (Fequal (filename
, Fcar (tem
))))
1308 /* If we're loading the entire file, remove old data. */
1312 Vload_history
= XCDR (tail
);
1314 Fsetcdr (prev
, XCDR (tail
));
1317 /* Otherwise, cons on new symbols that are not already members. */
1320 tem2
= Vcurrent_load_list
;
1322 while (CONSP (tem2
))
1324 newelt
= XCAR (tem2
);
1326 if (NILP (Fmember (newelt
, tem
)))
1327 Fsetcar (tail
, Fcons (XCAR (tem
),
1328 Fcons (newelt
, XCDR (tem
))));
1341 /* If we're loading an entire file, cons the new assoc onto the
1342 front of load-history, the most-recently-loaded position. Also
1343 do this if we didn't find an existing member for the file. */
1344 if (entire
|| !foundit
)
1345 Vload_history
= Fcons (Fnreverse (Vcurrent_load_list
),
1350 unreadpure (junk
) /* Used as unwind-protect function in readevalloop */
1358 readevalloop_1 (old
)
1361 load_convert_to_unibyte
= ! NILP (old
);
1365 /* Signal an `end-of-file' error, if possible with file name
1369 end_of_file_error ()
1373 if (STRINGP (Vload_file_name
))
1374 xsignal1 (Qend_of_file
, Vload_file_name
);
1376 xsignal0 (Qend_of_file
);
1379 /* UNIBYTE specifies how to set load_convert_to_unibyte
1380 for this invocation.
1381 READFUN, if non-nil, is used instead of `read'.
1383 START, END specify region to read in current buffer (from eval-region).
1384 If the input is not from a buffer, they must be nil. */
1387 readevalloop (readcharfun
, stream
, sourcename
, evalfun
,
1388 printflag
, unibyte
, readfun
, start
, end
)
1389 Lisp_Object readcharfun
;
1391 Lisp_Object sourcename
;
1392 Lisp_Object (*evalfun
) ();
1394 Lisp_Object unibyte
, readfun
;
1395 Lisp_Object start
, end
;
1398 register Lisp_Object val
;
1399 int count
= SPECPDL_INDEX ();
1400 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1401 struct buffer
*b
= 0;
1402 int continue_reading_p
;
1403 /* Nonzero if reading an entire buffer. */
1404 int whole_buffer
= 0;
1405 /* 1 on the first time around. */
1408 if (MARKERP (readcharfun
))
1411 start
= readcharfun
;
1414 if (BUFFERP (readcharfun
))
1415 b
= XBUFFER (readcharfun
);
1416 else if (MARKERP (readcharfun
))
1417 b
= XMARKER (readcharfun
)->buffer
;
1419 /* We assume START is nil when input is not from a buffer. */
1420 if (! NILP (start
) && !b
)
1423 specbind (Qstandard_input
, readcharfun
); /* GCPROs readcharfun. */
1424 specbind (Qcurrent_load_list
, Qnil
);
1425 record_unwind_protect (readevalloop_1
, load_convert_to_unibyte
? Qt
: Qnil
);
1426 load_convert_to_unibyte
= !NILP (unibyte
);
1428 readchar_backlog
= -1;
1430 GCPRO4 (sourcename
, readfun
, start
, end
);
1432 /* Try to ensure sourcename is a truename, except whilst preloading. */
1433 if (NILP (Vpurify_flag
)
1434 && !NILP (sourcename
) && !NILP (Ffile_name_absolute_p (sourcename
))
1435 && !NILP (Ffboundp (Qfile_truename
)))
1436 sourcename
= call1 (Qfile_truename
, sourcename
) ;
1438 LOADHIST_ATTACH (sourcename
);
1440 continue_reading_p
= 1;
1441 while (continue_reading_p
)
1443 int count1
= SPECPDL_INDEX ();
1445 if (b
!= 0 && NILP (b
->name
))
1446 error ("Reading from killed buffer");
1450 /* Switch to the buffer we are reading from. */
1451 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
1452 set_buffer_internal (b
);
1454 /* Save point in it. */
1455 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
1456 /* Save ZV in it. */
1457 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
1458 /* Those get unbound after we read one expression. */
1460 /* Set point and ZV around stuff to be read. */
1463 Fnarrow_to_region (make_number (BEGV
), end
);
1465 /* Just for cleanliness, convert END to a marker
1466 if it is an integer. */
1468 end
= Fpoint_max_marker ();
1471 /* On the first cycle, we can easily test here
1472 whether we are reading the whole buffer. */
1473 if (b
&& first_sexp
)
1474 whole_buffer
= (PT
== BEG
&& ZV
== Z
);
1481 while ((c
= READCHAR
) != '\n' && c
!= -1);
1486 unbind_to (count1
, Qnil
);
1490 /* Ignore whitespace here, so we can detect eof. */
1491 if (c
== ' ' || c
== '\t' || c
== '\n' || c
== '\f' || c
== '\r')
1494 if (!NILP (Vpurify_flag
) && c
== '(')
1496 record_unwind_protect (unreadpure
, Qnil
);
1497 val
= read_list (-1, readcharfun
);
1502 read_objects
= Qnil
;
1503 if (!NILP (readfun
))
1505 val
= call1 (readfun
, readcharfun
);
1507 /* If READCHARFUN has set point to ZV, we should
1508 stop reading, even if the form read sets point
1509 to a different value when evaluated. */
1510 if (BUFFERP (readcharfun
))
1512 struct buffer
*b
= XBUFFER (readcharfun
);
1513 if (BUF_PT (b
) == BUF_ZV (b
))
1514 continue_reading_p
= 0;
1517 else if (! NILP (Vload_read_function
))
1518 val
= call1 (Vload_read_function
, readcharfun
);
1520 val
= read_internal_start (readcharfun
, Qnil
, Qnil
);
1523 if (!NILP (start
) && continue_reading_p
)
1524 start
= Fpoint_marker ();
1526 /* Restore saved point and BEGV. */
1527 unbind_to (count1
, Qnil
);
1529 /* Now eval what we just read. */
1530 val
= (*evalfun
) (val
);
1534 Vvalues
= Fcons (val
, Vvalues
);
1535 if (EQ (Vstandard_output
, Qt
))
1544 build_load_history (sourcename
,
1545 stream
|| whole_buffer
);
1549 unbind_to (count
, Qnil
);
1552 DEFUN ("eval-buffer", Feval_buffer
, Seval_buffer
, 0, 5, "",
1553 doc
: /* Execute the current buffer as Lisp code.
1554 Programs can pass two arguments, BUFFER and PRINTFLAG.
1555 BUFFER is the buffer to evaluate (nil means use current buffer).
1556 PRINTFLAG controls printing of output:
1557 nil means discard it; anything else is stream for print.
1559 If the optional third argument FILENAME is non-nil,
1560 it specifies the file name to use for `load-history'.
1561 The optional fourth argument UNIBYTE specifies `load-convert-to-unibyte'
1562 for this invocation.
1564 The optional fifth argument DO-ALLOW-PRINT, if non-nil, specifies that
1565 `print' and related functions should work normally even if PRINTFLAG is nil.
1567 This function preserves the position of point. */)
1568 (buffer
, printflag
, filename
, unibyte
, do_allow_print
)
1569 Lisp_Object buffer
, printflag
, filename
, unibyte
, do_allow_print
;
1571 int count
= SPECPDL_INDEX ();
1572 Lisp_Object tem
, buf
;
1575 buf
= Fcurrent_buffer ();
1577 buf
= Fget_buffer (buffer
);
1579 error ("No such buffer");
1581 if (NILP (printflag
) && NILP (do_allow_print
))
1586 if (NILP (filename
))
1587 filename
= XBUFFER (buf
)->filename
;
1589 specbind (Qeval_buffer_list
, Fcons (buf
, Veval_buffer_list
));
1590 specbind (Qstandard_output
, tem
);
1591 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
1592 BUF_SET_PT (XBUFFER (buf
), BUF_BEGV (XBUFFER (buf
)));
1593 readevalloop (buf
, 0, filename
, Feval
,
1594 !NILP (printflag
), unibyte
, Qnil
, Qnil
, Qnil
);
1595 unbind_to (count
, Qnil
);
1600 DEFUN ("eval-region", Feval_region
, Seval_region
, 2, 4, "r",
1601 doc
: /* Execute the region as Lisp code.
1602 When called from programs, expects two arguments,
1603 giving starting and ending indices in the current buffer
1604 of the text to be executed.
1605 Programs can pass third argument PRINTFLAG which controls output:
1606 nil means discard it; anything else is stream for printing it.
1607 Also the fourth argument READ-FUNCTION, if non-nil, is used
1608 instead of `read' to read each expression. It gets one argument
1609 which is the input stream for reading characters.
1611 This function does not move point. */)
1612 (start
, end
, printflag
, read_function
)
1613 Lisp_Object start
, end
, printflag
, read_function
;
1615 int count
= SPECPDL_INDEX ();
1616 Lisp_Object tem
, cbuf
;
1618 cbuf
= Fcurrent_buffer ();
1620 if (NILP (printflag
))
1624 specbind (Qstandard_output
, tem
);
1625 specbind (Qeval_buffer_list
, Fcons (cbuf
, Veval_buffer_list
));
1627 /* readevalloop calls functions which check the type of start and end. */
1628 readevalloop (cbuf
, 0, XBUFFER (cbuf
)->filename
, Feval
,
1629 !NILP (printflag
), Qnil
, read_function
,
1632 return unbind_to (count
, Qnil
);
1636 DEFUN ("read", Fread
, Sread
, 0, 1, 0,
1637 doc
: /* Read one Lisp expression as text from STREAM, return as Lisp object.
1638 If STREAM is nil, use the value of `standard-input' (which see).
1639 STREAM or the value of `standard-input' may be:
1640 a buffer (read from point and advance it)
1641 a marker (read from where it points and advance it)
1642 a function (call it with no arguments for each character,
1643 call it with a char as argument to push a char back)
1644 a string (takes text from string, starting at the beginning)
1645 t (read text line using minibuffer and use it, or read from
1646 standard input in batch mode). */)
1651 stream
= Vstandard_input
;
1652 if (EQ (stream
, Qt
))
1653 stream
= Qread_char
;
1654 if (EQ (stream
, Qread_char
))
1655 return Fread_minibuffer (build_string ("Lisp expression: "), Qnil
);
1657 return read_internal_start (stream
, Qnil
, Qnil
);
1660 DEFUN ("read-from-string", Fread_from_string
, Sread_from_string
, 1, 3, 0,
1661 doc
: /* Read one Lisp expression which is represented as text by STRING.
1662 Returns a cons: (OBJECT-READ . FINAL-STRING-INDEX).
1663 START and END optionally delimit a substring of STRING from which to read;
1664 they default to 0 and (length STRING) respectively. */)
1665 (string
, start
, end
)
1666 Lisp_Object string
, start
, end
;
1669 CHECK_STRING (string
);
1670 /* read_internal_start sets read_from_string_index. */
1671 ret
= read_internal_start (string
, start
, end
);
1672 return Fcons (ret
, make_number (read_from_string_index
));
1675 /* Function to set up the global context we need in toplevel read
1678 read_internal_start (stream
, start
, end
)
1680 Lisp_Object start
; /* Only used when stream is a string. */
1681 Lisp_Object end
; /* Only used when stream is a string. */
1685 readchar_backlog
= -1;
1687 new_backquote_flag
= 0;
1688 read_objects
= Qnil
;
1689 if (EQ (Vread_with_symbol_positions
, Qt
)
1690 || EQ (Vread_with_symbol_positions
, stream
))
1691 Vread_symbol_positions_list
= Qnil
;
1693 if (STRINGP (stream
))
1695 int startval
, endval
;
1697 endval
= SCHARS (stream
);
1701 endval
= XINT (end
);
1702 if (endval
< 0 || endval
> SCHARS (stream
))
1703 args_out_of_range (stream
, end
);
1710 CHECK_NUMBER (start
);
1711 startval
= XINT (start
);
1712 if (startval
< 0 || startval
> endval
)
1713 args_out_of_range (stream
, start
);
1715 read_from_string_index
= startval
;
1716 read_from_string_index_byte
= string_char_to_byte (stream
, startval
);
1717 read_from_string_limit
= endval
;
1720 retval
= read0 (stream
);
1721 if (EQ (Vread_with_symbol_positions
, Qt
)
1722 || EQ (Vread_with_symbol_positions
, stream
))
1723 Vread_symbol_positions_list
= Fnreverse (Vread_symbol_positions_list
);
1728 /* Signal Qinvalid_read_syntax error.
1729 S is error string of length N (if > 0) */
1732 invalid_syntax (s
, n
)
1738 xsignal1 (Qinvalid_read_syntax
, make_string (s
, n
));
1742 /* Use this for recursive reads, in contexts where internal tokens
1747 Lisp_Object readcharfun
;
1749 register Lisp_Object val
;
1752 val
= read1 (readcharfun
, &c
, 0);
1756 xsignal1 (Qinvalid_read_syntax
,
1757 Fmake_string (make_number (1), make_number (c
)));
1760 static int read_buffer_size
;
1761 static char *read_buffer
;
1763 /* Read multibyte form and return it as a character. C is a first
1764 byte of multibyte form, and rest of them are read from
1768 read_multibyte (c
, readcharfun
)
1770 Lisp_Object readcharfun
;
1772 /* We need the actual character code of this multibyte
1774 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
1782 while ((c
= READCHAR
) >= 0xA0
1783 && len
< MAX_MULTIBYTE_LENGTH
)
1789 if (UNIBYTE_STR_AS_MULTIBYTE_P (str
, len
, bytes
))
1790 return STRING_CHAR (str
, len
);
1791 /* The byte sequence is not valid as multibyte. Unread all bytes
1792 but the first one, and return the first byte. */
1798 /* Read a \-escape sequence, assuming we already read the `\'.
1799 If the escape sequence forces unibyte, store 1 into *BYTEREP.
1800 If the escape sequence forces multibyte, store 2 into *BYTEREP.
1801 Otherwise store 0 into *BYTEREP. */
1804 read_escape (readcharfun
, stringp
, byterep
)
1805 Lisp_Object readcharfun
;
1809 register int c
= READCHAR
;
1810 /* \u allows up to four hex digits, \U up to eight. Default to the
1811 behaviour for \u, and change this value in the case that \U is seen. */
1812 int unicode_hex_count
= 4;
1819 end_of_file_error ();
1849 error ("Invalid escape character syntax");
1852 c
= read_escape (readcharfun
, 0, byterep
);
1853 return c
| meta_modifier
;
1858 error ("Invalid escape character syntax");
1861 c
= read_escape (readcharfun
, 0, byterep
);
1862 return c
| shift_modifier
;
1867 error ("Invalid escape character syntax");
1870 c
= read_escape (readcharfun
, 0, byterep
);
1871 return c
| hyper_modifier
;
1876 error ("Invalid escape character syntax");
1879 c
= read_escape (readcharfun
, 0, byterep
);
1880 return c
| alt_modifier
;
1891 c
= read_escape (readcharfun
, 0, byterep
);
1892 return c
| super_modifier
;
1897 error ("Invalid escape character syntax");
1901 c
= read_escape (readcharfun
, 0, byterep
);
1902 if ((c
& ~CHAR_MODIFIER_MASK
) == '?')
1903 return 0177 | (c
& CHAR_MODIFIER_MASK
);
1904 else if (! SINGLE_BYTE_CHAR_P ((c
& ~CHAR_MODIFIER_MASK
)))
1905 return c
| ctrl_modifier
;
1906 /* ASCII control chars are made from letters (both cases),
1907 as well as the non-letters within 0100...0137. */
1908 else if ((c
& 0137) >= 0101 && (c
& 0137) <= 0132)
1909 return (c
& (037 | ~0177));
1910 else if ((c
& 0177) >= 0100 && (c
& 0177) <= 0137)
1911 return (c
& (037 | ~0177));
1913 return c
| ctrl_modifier
;
1923 /* An octal escape, as in ANSI C. */
1925 register int i
= c
- '0';
1926 register int count
= 0;
1929 if ((c
= READCHAR
) >= '0' && c
<= '7')
1946 /* A hex escape, as in ANSI C. */
1952 if (c
>= '0' && c
<= '9')
1957 else if ((c
>= 'a' && c
<= 'f')
1958 || (c
>= 'A' && c
<= 'F'))
1961 if (c
>= 'a' && c
<= 'f')
1978 /* Post-Unicode-2.0: Up to eight hex chars. */
1979 unicode_hex_count
= 8;
1982 /* A Unicode escape. We only permit them in strings and characters,
1983 not arbitrarily in the source code, as in some other languages. */
1987 Lisp_Object lisp_char
;
1988 struct gcpro gcpro1
;
1990 while (++count
<= unicode_hex_count
)
1993 /* isdigit and isalpha may be locale-specific, which we don't
1995 if (c
>= '0' && c
<= '9') i
= (i
<< 4) + (c
- '0');
1996 else if (c
>= 'a' && c
<= 'f') i
= (i
<< 4) + (c
- 'a') + 10;
1997 else if (c
>= 'A' && c
<= 'F') i
= (i
<< 4) + (c
- 'A') + 10;
2000 error ("Non-hex digit used for Unicode escape");
2005 GCPRO1 (readcharfun
);
2006 lisp_char
= call2 (intern ("decode-char"), intern ("ucs"),
2010 if (NILP (lisp_char
))
2012 error ("Unsupported Unicode code point: U+%x", (unsigned)i
);
2015 return XFASTINT (lisp_char
);
2019 if (BASE_LEADING_CODE_P (c
))
2020 c
= read_multibyte (c
, readcharfun
);
2025 /* Read an integer in radix RADIX using READCHARFUN to read
2026 characters. RADIX must be in the interval [2..36]; if it isn't, a
2027 read error is signaled . Value is the integer read. Signals an
2028 error if encountering invalid read syntax or if RADIX is out of
2032 read_integer (readcharfun
, radix
)
2033 Lisp_Object readcharfun
;
2036 int ndigits
= 0, invalid_p
, c
, sign
= 0;
2037 EMACS_INT number
= 0;
2039 if (radix
< 2 || radix
> 36)
2043 number
= ndigits
= invalid_p
= 0;
2059 if (c
>= '0' && c
<= '9')
2061 else if (c
>= 'a' && c
<= 'z')
2062 digit
= c
- 'a' + 10;
2063 else if (c
>= 'A' && c
<= 'Z')
2064 digit
= c
- 'A' + 10;
2071 if (digit
< 0 || digit
>= radix
)
2074 number
= radix
* number
+ digit
;
2080 if (ndigits
== 0 || invalid_p
)
2083 sprintf (buf
, "integer, radix %d", radix
);
2084 invalid_syntax (buf
, 0);
2087 return make_number (sign
* number
);
2091 /* Convert unibyte text in read_buffer to multibyte.
2093 Initially, *P is a pointer after the end of the unibyte text, and
2094 the pointer *END points after the end of read_buffer.
2096 If read_buffer doesn't have enough room to hold the result
2097 of the conversion, reallocate it and adjust *P and *END.
2099 At the end, make *P point after the result of the conversion, and
2100 return in *NCHARS the number of characters in the converted
2104 to_multibyte (p
, end
, nchars
)
2110 parse_str_as_multibyte (read_buffer
, *p
- read_buffer
, &nbytes
, nchars
);
2111 if (read_buffer_size
< 2 * nbytes
)
2113 int offset
= *p
- read_buffer
;
2114 read_buffer_size
= 2 * max (read_buffer_size
, nbytes
);
2115 read_buffer
= (char *) xrealloc (read_buffer
, read_buffer_size
);
2116 *p
= read_buffer
+ offset
;
2117 *end
= read_buffer
+ read_buffer_size
;
2120 if (nbytes
!= *nchars
)
2121 nbytes
= str_as_multibyte (read_buffer
, read_buffer_size
,
2122 *p
- read_buffer
, nchars
);
2124 *p
= read_buffer
+ nbytes
;
2128 /* If the next token is ')' or ']' or '.', we store that character
2129 in *PCH and the return value is not interesting. Else, we store
2130 zero in *PCH and we read and return one lisp object.
2132 FIRST_IN_LIST is nonzero if this is the first element of a list. */
2135 read1 (readcharfun
, pch
, first_in_list
)
2136 register Lisp_Object readcharfun
;
2141 int uninterned_symbol
= 0;
2149 end_of_file_error ();
2154 return read_list (0, readcharfun
);
2157 return read_vector (readcharfun
, 0);
2174 tmp
= read_vector (readcharfun
, 0);
2175 if (XVECTOR (tmp
)->size
< CHAR_TABLE_STANDARD_SLOTS
2176 || XVECTOR (tmp
)->size
> CHAR_TABLE_STANDARD_SLOTS
+ 10)
2177 error ("Invalid size char-table");
2178 XSETCHAR_TABLE (tmp
, XCHAR_TABLE (tmp
));
2179 XCHAR_TABLE (tmp
)->top
= Qt
;
2188 tmp
= read_vector (readcharfun
, 0);
2189 if (XVECTOR (tmp
)->size
!= SUB_CHAR_TABLE_STANDARD_SLOTS
)
2190 error ("Invalid size char-table");
2191 XSETCHAR_TABLE (tmp
, XCHAR_TABLE (tmp
));
2192 XCHAR_TABLE (tmp
)->top
= Qnil
;
2195 invalid_syntax ("#^^", 3);
2197 invalid_syntax ("#^", 2);
2202 length
= read1 (readcharfun
, pch
, first_in_list
);
2206 Lisp_Object tmp
, val
;
2208 = ((XFASTINT (length
) + BOOL_VECTOR_BITS_PER_CHAR
- 1)
2209 / BOOL_VECTOR_BITS_PER_CHAR
);
2212 tmp
= read1 (readcharfun
, pch
, first_in_list
);
2213 if (size_in_chars
!= SCHARS (tmp
)
2214 /* We used to print 1 char too many
2215 when the number of bits was a multiple of 8.
2216 Accept such input in case it came from an old version. */
2217 && ! (XFASTINT (length
)
2218 == (SCHARS (tmp
) - 1) * BOOL_VECTOR_BITS_PER_CHAR
))
2219 invalid_syntax ("#&...", 5);
2221 val
= Fmake_bool_vector (length
, Qnil
);
2222 bcopy (SDATA (tmp
), XBOOL_VECTOR (val
)->data
,
2224 /* Clear the extraneous bits in the last byte. */
2225 if (XINT (length
) != size_in_chars
* BOOL_VECTOR_BITS_PER_CHAR
)
2226 XBOOL_VECTOR (val
)->data
[size_in_chars
- 1]
2227 &= (1 << (XINT (length
) % BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2230 invalid_syntax ("#&...", 5);
2234 /* Accept compiled functions at read-time so that we don't have to
2235 build them using function calls. */
2237 tmp
= read_vector (readcharfun
, 1);
2238 return Fmake_byte_code (XVECTOR (tmp
)->size
,
2239 XVECTOR (tmp
)->contents
);
2244 struct gcpro gcpro1
;
2247 /* Read the string itself. */
2248 tmp
= read1 (readcharfun
, &ch
, 0);
2249 if (ch
!= 0 || !STRINGP (tmp
))
2250 invalid_syntax ("#", 1);
2252 /* Read the intervals and their properties. */
2255 Lisp_Object beg
, end
, plist
;
2257 beg
= read1 (readcharfun
, &ch
, 0);
2262 end
= read1 (readcharfun
, &ch
, 0);
2264 plist
= read1 (readcharfun
, &ch
, 0);
2266 invalid_syntax ("Invalid string property list", 0);
2267 Fset_text_properties (beg
, end
, plist
, tmp
);
2273 /* #@NUMBER is used to skip NUMBER following characters.
2274 That's used in .elc files to skip over doc strings
2275 and function definitions. */
2280 /* Read a decimal integer. */
2281 while ((c
= READCHAR
) >= 0
2282 && c
>= '0' && c
<= '9')
2290 if (load_force_doc_strings
&& EQ (readcharfun
, Qget_file_char
))
2292 /* If we are supposed to force doc strings into core right now,
2293 record the last string that we skipped,
2294 and record where in the file it comes from. */
2296 /* But first exchange saved_doc_string
2297 with prev_saved_doc_string, so we save two strings. */
2299 char *temp
= saved_doc_string
;
2300 int temp_size
= saved_doc_string_size
;
2301 file_offset temp_pos
= saved_doc_string_position
;
2302 int temp_len
= saved_doc_string_length
;
2304 saved_doc_string
= prev_saved_doc_string
;
2305 saved_doc_string_size
= prev_saved_doc_string_size
;
2306 saved_doc_string_position
= prev_saved_doc_string_position
;
2307 saved_doc_string_length
= prev_saved_doc_string_length
;
2309 prev_saved_doc_string
= temp
;
2310 prev_saved_doc_string_size
= temp_size
;
2311 prev_saved_doc_string_position
= temp_pos
;
2312 prev_saved_doc_string_length
= temp_len
;
2315 if (saved_doc_string_size
== 0)
2317 saved_doc_string_size
= nskip
+ 100;
2318 saved_doc_string
= (char *) xmalloc (saved_doc_string_size
);
2320 if (nskip
> saved_doc_string_size
)
2322 saved_doc_string_size
= nskip
+ 100;
2323 saved_doc_string
= (char *) xrealloc (saved_doc_string
,
2324 saved_doc_string_size
);
2327 saved_doc_string_position
= file_tell (instream
);
2329 /* Copy that many characters into saved_doc_string. */
2330 for (i
= 0; i
< nskip
&& c
>= 0; i
++)
2331 saved_doc_string
[i
] = c
= READCHAR
;
2333 saved_doc_string_length
= i
;
2337 /* Skip that many characters. */
2338 for (i
= 0; i
< nskip
&& c
>= 0; i
++)
2346 /* #! appears at the beginning of an executable file.
2347 Skip the first line. */
2348 while (c
!= '\n' && c
>= 0)
2353 return Vload_file_name
;
2355 return Fcons (Qfunction
, Fcons (read0 (readcharfun
), Qnil
));
2356 /* #:foo is the uninterned symbol named foo. */
2359 uninterned_symbol
= 1;
2363 /* Reader forms that can reuse previously read objects. */
2364 if (c
>= '0' && c
<= '9')
2369 /* Read a non-negative integer. */
2370 while (c
>= '0' && c
<= '9')
2376 /* #n=object returns object, but associates it with n for #n#. */
2379 /* Make a placeholder for #n# to use temporarily */
2380 Lisp_Object placeholder
;
2383 placeholder
= Fcons(Qnil
, Qnil
);
2384 cell
= Fcons (make_number (n
), placeholder
);
2385 read_objects
= Fcons (cell
, read_objects
);
2387 /* Read the object itself. */
2388 tem
= read0 (readcharfun
);
2390 /* Now put it everywhere the placeholder was... */
2391 substitute_object_in_subtree (tem
, placeholder
);
2393 /* ...and #n# will use the real value from now on. */
2394 Fsetcdr (cell
, tem
);
2398 /* #n# returns a previously read object. */
2401 tem
= Fassq (make_number (n
), read_objects
);
2404 /* Fall through to error message. */
2406 else if (c
== 'r' || c
== 'R')
2407 return read_integer (readcharfun
, n
);
2409 /* Fall through to error message. */
2411 else if (c
== 'x' || c
== 'X')
2412 return read_integer (readcharfun
, 16);
2413 else if (c
== 'o' || c
== 'O')
2414 return read_integer (readcharfun
, 8);
2415 else if (c
== 'b' || c
== 'B')
2416 return read_integer (readcharfun
, 2);
2419 invalid_syntax ("#", 1);
2422 while ((c
= READCHAR
) >= 0 && c
!= '\n');
2427 return Fcons (Qquote
, Fcons (read0 (readcharfun
), Qnil
));
2437 new_backquote_flag
++;
2438 value
= read0 (readcharfun
);
2439 new_backquote_flag
--;
2441 return Fcons (Qbackquote
, Fcons (value
, Qnil
));
2445 if (new_backquote_flag
)
2447 Lisp_Object comma_type
= Qnil
;
2452 comma_type
= Qcomma_at
;
2454 comma_type
= Qcomma_dot
;
2457 if (ch
>= 0) UNREAD (ch
);
2458 comma_type
= Qcomma
;
2461 new_backquote_flag
--;
2462 value
= read0 (readcharfun
);
2463 new_backquote_flag
++;
2464 return Fcons (comma_type
, Fcons (value
, Qnil
));
2477 end_of_file_error ();
2479 /* Accept `single space' syntax like (list ? x) where the
2480 whitespace character is SPC or TAB.
2481 Other literal whitespace like NL, CR, and FF are not accepted,
2482 as there are well-established escape sequences for these. */
2483 if (c
== ' ' || c
== '\t')
2484 return make_number (c
);
2487 c
= read_escape (readcharfun
, 0, &discard
);
2488 else if (BASE_LEADING_CODE_P (c
))
2489 c
= read_multibyte (c
, readcharfun
);
2491 next_char
= READCHAR
;
2492 if (next_char
== '.')
2494 /* Only a dotted-pair dot is valid after a char constant. */
2495 int next_next_char
= READCHAR
;
2496 UNREAD (next_next_char
);
2498 ok
= (next_next_char
<= 040
2499 || (next_next_char
< 0200
2500 && (index ("\"';([#?", next_next_char
)
2501 || (!first_in_list
&& next_next_char
== '`')
2502 || (new_backquote_flag
&& next_next_char
== ','))));
2506 ok
= (next_char
<= 040
2507 || (next_char
< 0200
2508 && (index ("\"';()[]#?", next_char
)
2509 || (!first_in_list
&& next_char
== '`')
2510 || (new_backquote_flag
&& next_char
== ','))));
2514 return make_number (c
);
2516 invalid_syntax ("?", 1);
2521 char *p
= read_buffer
;
2522 char *end
= read_buffer
+ read_buffer_size
;
2524 /* 1 if we saw an escape sequence specifying
2525 a multibyte character, or a multibyte character. */
2526 int force_multibyte
= 0;
2527 /* 1 if we saw an escape sequence specifying
2528 a single-byte character. */
2529 int force_singlebyte
= 0;
2530 /* 1 if read_buffer contains multibyte text now. */
2531 int is_multibyte
= 0;
2535 while ((c
= READCHAR
) >= 0
2538 if (end
- p
< MAX_MULTIBYTE_LENGTH
)
2540 int offset
= p
- read_buffer
;
2541 read_buffer
= (char *) xrealloc (read_buffer
,
2542 read_buffer_size
*= 2);
2543 p
= read_buffer
+ offset
;
2544 end
= read_buffer
+ read_buffer_size
;
2551 c
= read_escape (readcharfun
, 1, &byterep
);
2553 /* C is -1 if \ newline has just been seen */
2556 if (p
== read_buffer
)
2562 force_singlebyte
= 1;
2563 else if (byterep
== 2)
2564 force_multibyte
= 1;
2567 /* A character that must be multibyte forces multibyte. */
2568 if (! SINGLE_BYTE_CHAR_P (c
& ~CHAR_MODIFIER_MASK
))
2569 force_multibyte
= 1;
2571 /* If we just discovered the need to be multibyte,
2572 convert the text accumulated thus far. */
2573 if (force_multibyte
&& ! is_multibyte
)
2576 to_multibyte (&p
, &end
, &nchars
);
2579 /* Allow `\C- ' and `\C-?'. */
2580 if (c
== (CHAR_CTL
| ' '))
2582 else if (c
== (CHAR_CTL
| '?'))
2587 /* Shift modifier is valid only with [A-Za-z]. */
2588 if ((c
& 0377) >= 'A' && (c
& 0377) <= 'Z')
2590 else if ((c
& 0377) >= 'a' && (c
& 0377) <= 'z')
2591 c
= (c
& ~CHAR_SHIFT
) - ('a' - 'A');
2595 /* Move the meta bit to the right place for a string. */
2596 c
= (c
& ~CHAR_META
) | 0x80;
2597 if (c
& CHAR_MODIFIER_MASK
)
2598 error ("Invalid modifier in string");
2601 p
+= CHAR_STRING (c
, p
);
2609 end_of_file_error ();
2611 /* If purifying, and string starts with \ newline,
2612 return zero instead. This is for doc strings
2613 that we are really going to find in etc/DOC.nn.nn */
2614 if (!NILP (Vpurify_flag
) && NILP (Vdoc_file_name
) && cancel
)
2615 return make_number (0);
2617 if (is_multibyte
|| force_singlebyte
)
2619 else if (load_convert_to_unibyte
)
2622 to_multibyte (&p
, &end
, &nchars
);
2623 if (p
- read_buffer
!= nchars
)
2625 string
= make_multibyte_string (read_buffer
, nchars
,
2627 return Fstring_make_unibyte (string
);
2629 /* We can make a unibyte string directly. */
2632 else if (EQ (readcharfun
, Qget_file_char
)
2633 || EQ (readcharfun
, Qlambda
))
2635 /* Nowadays, reading directly from a file is used only for
2636 compiled Emacs Lisp files, and those always use the
2637 Emacs internal encoding. Meanwhile, Qlambda is used
2638 for reading dynamic byte code (compiled with
2639 byte-compile-dynamic = t). So make the string multibyte
2640 if the string contains any multibyte sequences.
2641 (to_multibyte is a no-op if not.) */
2642 to_multibyte (&p
, &end
, &nchars
);
2643 is_multibyte
= (p
- read_buffer
) != nchars
;
2646 /* In all other cases, if we read these bytes as
2647 separate characters, treat them as separate characters now. */
2650 /* We want readchar_count to be the number of characters, not
2651 bytes. Hence we adjust for multibyte characters in the
2652 string. ... But it doesn't seem to be necessary, because
2653 READCHAR *does* read multibyte characters from buffers. */
2654 /* readchar_count -= (p - read_buffer) - nchars; */
2656 return make_pure_string (read_buffer
, nchars
, p
- read_buffer
,
2658 return make_specified_string (read_buffer
, nchars
, p
- read_buffer
,
2664 int next_char
= READCHAR
;
2667 if (next_char
<= 040
2668 || (next_char
< 0200
2669 && (index ("\"';([#?", next_char
)
2670 || (!first_in_list
&& next_char
== '`')
2671 || (new_backquote_flag
&& next_char
== ','))))
2677 /* Otherwise, we fall through! Note that the atom-reading loop
2678 below will now loop at least once, assuring that we will not
2679 try to UNREAD two characters in a row. */
2683 if (c
<= 040) goto retry
;
2685 char *p
= read_buffer
;
2689 char *end
= read_buffer
+ read_buffer_size
;
2693 || (!index ("\"';()[]#", c
)
2694 && !(!first_in_list
&& c
== '`')
2695 && !(new_backquote_flag
&& c
== ','))))
2697 if (end
- p
< MAX_MULTIBYTE_LENGTH
)
2699 int offset
= p
- read_buffer
;
2700 read_buffer
= (char *) xrealloc (read_buffer
,
2701 read_buffer_size
*= 2);
2702 p
= read_buffer
+ offset
;
2703 end
= read_buffer
+ read_buffer_size
;
2710 end_of_file_error ();
2714 if (! SINGLE_BYTE_CHAR_P (c
))
2715 p
+= CHAR_STRING (c
, p
);
2724 int offset
= p
- read_buffer
;
2725 read_buffer
= (char *) xrealloc (read_buffer
,
2726 read_buffer_size
*= 2);
2727 p
= read_buffer
+ offset
;
2728 end
= read_buffer
+ read_buffer_size
;
2735 if (!quoted
&& !uninterned_symbol
)
2738 register Lisp_Object val
;
2740 if (*p1
== '+' || *p1
== '-') p1
++;
2741 /* Is it an integer? */
2744 while (p1
!= p
&& (c
= *p1
) >= '0' && c
<= '9') p1
++;
2745 /* Integers can have trailing decimal points. */
2746 if (p1
> read_buffer
&& p1
< p
&& *p1
== '.') p1
++;
2748 /* It is an integer. */
2752 if (sizeof (int) == sizeof (EMACS_INT
))
2753 XSETINT (val
, atoi (read_buffer
));
2754 else if (sizeof (long) == sizeof (EMACS_INT
))
2755 XSETINT (val
, atol (read_buffer
));
2761 if (isfloat_string (read_buffer
))
2763 /* Compute NaN and infinities using 0.0 in a variable,
2764 to cope with compilers that think they are smarter
2770 /* Negate the value ourselves. This treats 0, NaNs,
2771 and infinity properly on IEEE floating point hosts,
2772 and works around a common bug where atof ("-0.0")
2774 int negative
= read_buffer
[0] == '-';
2776 /* The only way p[-1] can be 'F' or 'N', after isfloat_string
2777 returns 1, is if the input ends in e+INF or e+NaN. */
2784 value
= zero
/ zero
;
2786 /* If that made a "negative" NaN, negate it. */
2790 union { double d
; char c
[sizeof (double)]; } u_data
, u_minus_zero
;
2793 u_minus_zero
.d
= - 0.0;
2794 for (i
= 0; i
< sizeof (double); i
++)
2795 if (u_data
.c
[i
] & u_minus_zero
.c
[i
])
2801 /* Now VALUE is a positive NaN. */
2804 value
= atof (read_buffer
+ negative
);
2808 return make_float (negative
? - value
: value
);
2812 Lisp_Object result
= uninterned_symbol
? make_symbol (read_buffer
)
2813 : intern (read_buffer
);
2814 if (EQ (Vread_with_symbol_positions
, Qt
)
2815 || EQ (Vread_with_symbol_positions
, readcharfun
))
2816 Vread_symbol_positions_list
=
2817 /* Kind of a hack; this will probably fail if characters
2818 in the symbol name were escaped. Not really a big
2820 Fcons (Fcons (result
,
2821 make_number (readchar_count
2822 - XFASTINT (Flength (Fsymbol_name (result
))))),
2823 Vread_symbol_positions_list
);
2831 /* List of nodes we've seen during substitute_object_in_subtree. */
2832 static Lisp_Object seen_list
;
2835 substitute_object_in_subtree (object
, placeholder
)
2837 Lisp_Object placeholder
;
2839 Lisp_Object check_object
;
2841 /* We haven't seen any objects when we start. */
2844 /* Make all the substitutions. */
2846 = substitute_object_recurse (object
, placeholder
, object
);
2848 /* Clear seen_list because we're done with it. */
2851 /* The returned object here is expected to always eq the
2853 if (!EQ (check_object
, object
))
2854 error ("Unexpected mutation error in reader");
2857 /* Feval doesn't get called from here, so no gc protection is needed. */
2858 #define SUBSTITUTE(get_val, set_val) \
2860 Lisp_Object old_value = get_val; \
2861 Lisp_Object true_value \
2862 = substitute_object_recurse (object, placeholder,\
2865 if (!EQ (old_value, true_value)) \
2872 substitute_object_recurse (object
, placeholder
, subtree
)
2874 Lisp_Object placeholder
;
2875 Lisp_Object subtree
;
2877 /* If we find the placeholder, return the target object. */
2878 if (EQ (placeholder
, subtree
))
2881 /* If we've been to this node before, don't explore it again. */
2882 if (!EQ (Qnil
, Fmemq (subtree
, seen_list
)))
2885 /* If this node can be the entry point to a cycle, remember that
2886 we've seen it. It can only be such an entry point if it was made
2887 by #n=, which means that we can find it as a value in
2889 if (!EQ (Qnil
, Frassq (subtree
, read_objects
)))
2890 seen_list
= Fcons (subtree
, seen_list
);
2892 /* Recurse according to subtree's type.
2893 Every branch must return a Lisp_Object. */
2894 switch (XTYPE (subtree
))
2896 case Lisp_Vectorlike
:
2899 int length
= XINT (Flength(subtree
));
2900 for (i
= 0; i
< length
; i
++)
2902 Lisp_Object idx
= make_number (i
);
2903 SUBSTITUTE (Faref (subtree
, idx
),
2904 Faset (subtree
, idx
, true_value
));
2911 SUBSTITUTE (Fcar_safe (subtree
),
2912 Fsetcar (subtree
, true_value
));
2913 SUBSTITUTE (Fcdr_safe (subtree
),
2914 Fsetcdr (subtree
, true_value
));
2920 /* Check for text properties in each interval.
2921 substitute_in_interval contains part of the logic. */
2923 INTERVAL root_interval
= STRING_INTERVALS (subtree
);
2924 Lisp_Object arg
= Fcons (object
, placeholder
);
2926 traverse_intervals_noorder (root_interval
,
2927 &substitute_in_interval
, arg
);
2932 /* Other types don't recurse any further. */
2938 /* Helper function for substitute_object_recurse. */
2940 substitute_in_interval (interval
, arg
)
2944 Lisp_Object object
= Fcar (arg
);
2945 Lisp_Object placeholder
= Fcdr (arg
);
2947 SUBSTITUTE(interval
->plist
, interval
->plist
= true_value
);
2966 if (*cp
== '+' || *cp
== '-')
2969 if (*cp
>= '0' && *cp
<= '9')
2972 while (*cp
>= '0' && *cp
<= '9')
2980 if (*cp
>= '0' && *cp
<= '9')
2983 while (*cp
>= '0' && *cp
<= '9')
2986 if (*cp
== 'e' || *cp
== 'E')
2990 if (*cp
== '+' || *cp
== '-')
2994 if (*cp
>= '0' && *cp
<= '9')
2997 while (*cp
>= '0' && *cp
<= '9')
3000 else if (cp
== start
)
3002 else if (cp
[-1] == '+' && cp
[0] == 'I' && cp
[1] == 'N' && cp
[2] == 'F')
3007 else if (cp
[-1] == '+' && cp
[0] == 'N' && cp
[1] == 'a' && cp
[2] == 'N')
3013 return (((*cp
== 0) || (*cp
== ' ') || (*cp
== '\t') || (*cp
== '\n') || (*cp
== '\r') || (*cp
== '\f'))
3014 && (state
== (LEAD_INT
|DOT_CHAR
|TRAIL_INT
)
3015 || state
== (DOT_CHAR
|TRAIL_INT
)
3016 || state
== (LEAD_INT
|E_CHAR
|EXP_INT
)
3017 || state
== (LEAD_INT
|DOT_CHAR
|TRAIL_INT
|E_CHAR
|EXP_INT
)
3018 || state
== (DOT_CHAR
|TRAIL_INT
|E_CHAR
|EXP_INT
)));
3023 read_vector (readcharfun
, bytecodeflag
)
3024 Lisp_Object readcharfun
;
3029 register Lisp_Object
*ptr
;
3030 register Lisp_Object tem
, item
, vector
;
3031 register struct Lisp_Cons
*otem
;
3034 tem
= read_list (1, readcharfun
);
3035 len
= Flength (tem
);
3036 vector
= (read_pure
? make_pure_vector (XINT (len
)) : Fmake_vector (len
, Qnil
));
3038 size
= XVECTOR (vector
)->size
;
3039 ptr
= XVECTOR (vector
)->contents
;
3040 for (i
= 0; i
< size
; i
++)
3043 /* If `load-force-doc-strings' is t when reading a lazily-loaded
3044 bytecode object, the docstring containing the bytecode and
3045 constants values must be treated as unibyte and passed to
3046 Fread, to get the actual bytecode string and constants vector. */
3047 if (bytecodeflag
&& load_force_doc_strings
)
3049 if (i
== COMPILED_BYTECODE
)
3051 if (!STRINGP (item
))
3052 error ("Invalid byte code");
3054 /* Delay handling the bytecode slot until we know whether
3055 it is lazily-loaded (we can tell by whether the
3056 constants slot is nil). */
3057 ptr
[COMPILED_CONSTANTS
] = item
;
3060 else if (i
== COMPILED_CONSTANTS
)
3062 Lisp_Object bytestr
= ptr
[COMPILED_CONSTANTS
];
3066 /* Coerce string to unibyte (like string-as-unibyte,
3067 but without generating extra garbage and
3068 guaranteeing no change in the contents). */
3069 STRING_SET_CHARS (bytestr
, SBYTES (bytestr
));
3070 STRING_SET_UNIBYTE (bytestr
);
3072 item
= Fread (bytestr
);
3074 error ("Invalid byte code");
3076 otem
= XCONS (item
);
3077 bytestr
= XCAR (item
);
3082 /* Now handle the bytecode slot. */
3083 ptr
[COMPILED_BYTECODE
] = read_pure
? Fpurecopy (bytestr
) : bytestr
;
3086 ptr
[i
] = read_pure
? Fpurecopy (item
) : item
;
3094 /* FLAG = 1 means check for ] to terminate rather than ) and .
3095 FLAG = -1 means check for starting with defun
3096 and make structure pure. */
3099 read_list (flag
, readcharfun
)
3101 register Lisp_Object readcharfun
;
3103 /* -1 means check next element for defun,
3104 0 means don't check,
3105 1 means already checked and found defun. */
3106 int defunflag
= flag
< 0 ? -1 : 0;
3107 Lisp_Object val
, tail
;
3108 register Lisp_Object elt
, tem
;
3109 struct gcpro gcpro1
, gcpro2
;
3110 /* 0 is the normal case.
3111 1 means this list is a doc reference; replace it with the number 0.
3112 2 means this list is a doc reference; replace it with the doc string. */
3113 int doc_reference
= 0;
3115 /* Initialize this to 1 if we are reading a list. */
3116 int first_in_list
= flag
<= 0;
3125 elt
= read1 (readcharfun
, &ch
, first_in_list
);
3130 /* While building, if the list starts with #$, treat it specially. */
3131 if (EQ (elt
, Vload_file_name
)
3133 && !NILP (Vpurify_flag
))
3135 if (NILP (Vdoc_file_name
))
3136 /* We have not yet called Snarf-documentation, so assume
3137 this file is described in the DOC-MM.NN file
3138 and Snarf-documentation will fill in the right value later.
3139 For now, replace the whole list with 0. */
3142 /* We have already called Snarf-documentation, so make a relative
3143 file name for this file, so it can be found properly
3144 in the installed Lisp directory.
3145 We don't use Fexpand_file_name because that would make
3146 the directory absolute now. */
3147 elt
= concat2 (build_string ("../lisp/"),
3148 Ffile_name_nondirectory (elt
));
3150 else if (EQ (elt
, Vload_file_name
)
3152 && load_force_doc_strings
)
3161 invalid_syntax (") or . in a vector", 18);
3169 XSETCDR (tail
, read0 (readcharfun
));
3171 val
= read0 (readcharfun
);
3172 read1 (readcharfun
, &ch
, 0);
3176 if (doc_reference
== 1)
3177 return make_number (0);
3178 if (doc_reference
== 2)
3180 /* Get a doc string from the file we are loading.
3181 If it's in saved_doc_string, get it from there. */
3182 int pos
= XINT (XCDR (val
));
3183 /* Position is negative for user variables. */
3184 if (pos
< 0) pos
= -pos
;
3185 if (pos
>= saved_doc_string_position
3186 && pos
< (saved_doc_string_position
3187 + saved_doc_string_length
))
3189 int start
= pos
- saved_doc_string_position
;
3192 /* Process quoting with ^A,
3193 and find the end of the string,
3194 which is marked with ^_ (037). */
3195 for (from
= start
, to
= start
;
3196 saved_doc_string
[from
] != 037;)
3198 int c
= saved_doc_string
[from
++];
3201 c
= saved_doc_string
[from
++];
3203 saved_doc_string
[to
++] = c
;
3205 saved_doc_string
[to
++] = 0;
3207 saved_doc_string
[to
++] = 037;
3210 saved_doc_string
[to
++] = c
;
3213 return make_string (saved_doc_string
+ start
,
3216 /* Look in prev_saved_doc_string the same way. */
3217 else if (pos
>= prev_saved_doc_string_position
3218 && pos
< (prev_saved_doc_string_position
3219 + prev_saved_doc_string_length
))
3221 int start
= pos
- prev_saved_doc_string_position
;
3224 /* Process quoting with ^A,
3225 and find the end of the string,
3226 which is marked with ^_ (037). */
3227 for (from
= start
, to
= start
;
3228 prev_saved_doc_string
[from
] != 037;)
3230 int c
= prev_saved_doc_string
[from
++];
3233 c
= prev_saved_doc_string
[from
++];
3235 prev_saved_doc_string
[to
++] = c
;
3237 prev_saved_doc_string
[to
++] = 0;
3239 prev_saved_doc_string
[to
++] = 037;
3242 prev_saved_doc_string
[to
++] = c
;
3245 return make_string (prev_saved_doc_string
+ start
,
3249 return get_doc_string (val
, 0, 0);
3254 invalid_syntax (". in wrong context", 18);
3256 invalid_syntax ("] in a list", 11);
3258 tem
= (read_pure
&& flag
<= 0
3259 ? pure_cons (elt
, Qnil
)
3260 : Fcons (elt
, Qnil
));
3262 XSETCDR (tail
, tem
);
3267 defunflag
= EQ (elt
, Qdefun
);
3268 else if (defunflag
> 0)
3273 Lisp_Object Vobarray
;
3274 Lisp_Object initial_obarray
;
3276 /* oblookup stores the bucket number here, for the sake of Funintern. */
3278 int oblookup_last_bucket_number
;
3280 static int hash_string ();
3282 /* Get an error if OBARRAY is not an obarray.
3283 If it is one, return it. */
3286 check_obarray (obarray
)
3287 Lisp_Object obarray
;
3289 if (!VECTORP (obarray
) || XVECTOR (obarray
)->size
== 0)
3291 /* If Vobarray is now invalid, force it to be valid. */
3292 if (EQ (Vobarray
, obarray
)) Vobarray
= initial_obarray
;
3293 wrong_type_argument (Qvectorp
, obarray
);
3298 /* Intern the C string STR: return a symbol with that name,
3299 interned in the current obarray. */
3306 int len
= strlen (str
);
3307 Lisp_Object obarray
;
3310 if (!VECTORP (obarray
) || XVECTOR (obarray
)->size
== 0)
3311 obarray
= check_obarray (obarray
);
3312 tem
= oblookup (obarray
, str
, len
, len
);
3315 return Fintern (make_string (str
, len
), obarray
);
3318 /* Create an uninterned symbol with name STR. */
3324 int len
= strlen (str
);
3326 return Fmake_symbol ((!NILP (Vpurify_flag
)
3327 ? make_pure_string (str
, len
, len
, 0)
3328 : make_string (str
, len
)));
3331 DEFUN ("intern", Fintern
, Sintern
, 1, 2, 0,
3332 doc
: /* Return the canonical symbol whose name is STRING.
3333 If there is none, one is created by this function and returned.
3334 A second optional argument specifies the obarray to use;
3335 it defaults to the value of `obarray'. */)
3337 Lisp_Object string
, obarray
;
3339 register Lisp_Object tem
, sym
, *ptr
;
3341 if (NILP (obarray
)) obarray
= Vobarray
;
3342 obarray
= check_obarray (obarray
);
3344 CHECK_STRING (string
);
3346 tem
= oblookup (obarray
, SDATA (string
),
3349 if (!INTEGERP (tem
))
3352 if (!NILP (Vpurify_flag
))
3353 string
= Fpurecopy (string
);
3354 sym
= Fmake_symbol (string
);
3356 if (EQ (obarray
, initial_obarray
))
3357 XSYMBOL (sym
)->interned
= SYMBOL_INTERNED_IN_INITIAL_OBARRAY
;
3359 XSYMBOL (sym
)->interned
= SYMBOL_INTERNED
;
3361 if ((SREF (string
, 0) == ':')
3362 && EQ (obarray
, initial_obarray
))
3364 XSYMBOL (sym
)->constant
= 1;
3365 XSYMBOL (sym
)->value
= sym
;
3368 ptr
= &XVECTOR (obarray
)->contents
[XINT (tem
)];
3370 XSYMBOL (sym
)->next
= XSYMBOL (*ptr
);
3372 XSYMBOL (sym
)->next
= 0;
3377 DEFUN ("intern-soft", Fintern_soft
, Sintern_soft
, 1, 2, 0,
3378 doc
: /* Return the canonical symbol named NAME, or nil if none exists.
3379 NAME may be a string or a symbol. If it is a symbol, that exact
3380 symbol is searched for.
3381 A second optional argument specifies the obarray to use;
3382 it defaults to the value of `obarray'. */)
3384 Lisp_Object name
, obarray
;
3386 register Lisp_Object tem
, string
;
3388 if (NILP (obarray
)) obarray
= Vobarray
;
3389 obarray
= check_obarray (obarray
);
3391 if (!SYMBOLP (name
))
3393 CHECK_STRING (name
);
3397 string
= SYMBOL_NAME (name
);
3399 tem
= oblookup (obarray
, SDATA (string
), SCHARS (string
), SBYTES (string
));
3400 if (INTEGERP (tem
) || (SYMBOLP (name
) && !EQ (name
, tem
)))
3406 DEFUN ("unintern", Funintern
, Sunintern
, 1, 2, 0,
3407 doc
: /* Delete the symbol named NAME, if any, from OBARRAY.
3408 The value is t if a symbol was found and deleted, nil otherwise.
3409 NAME may be a string or a symbol. If it is a symbol, that symbol
3410 is deleted, if it belongs to OBARRAY--no other symbol is deleted.
3411 OBARRAY defaults to the value of the variable `obarray'. */)
3413 Lisp_Object name
, obarray
;
3415 register Lisp_Object string
, tem
;
3418 if (NILP (obarray
)) obarray
= Vobarray
;
3419 obarray
= check_obarray (obarray
);
3422 string
= SYMBOL_NAME (name
);
3425 CHECK_STRING (name
);
3429 tem
= oblookup (obarray
, SDATA (string
),
3434 /* If arg was a symbol, don't delete anything but that symbol itself. */
3435 if (SYMBOLP (name
) && !EQ (name
, tem
))
3438 XSYMBOL (tem
)->interned
= SYMBOL_UNINTERNED
;
3439 XSYMBOL (tem
)->constant
= 0;
3440 XSYMBOL (tem
)->indirect_variable
= 0;
3442 hash
= oblookup_last_bucket_number
;
3444 if (EQ (XVECTOR (obarray
)->contents
[hash
], tem
))
3446 if (XSYMBOL (tem
)->next
)
3447 XSETSYMBOL (XVECTOR (obarray
)->contents
[hash
], XSYMBOL (tem
)->next
);
3449 XSETINT (XVECTOR (obarray
)->contents
[hash
], 0);
3453 Lisp_Object tail
, following
;
3455 for (tail
= XVECTOR (obarray
)->contents
[hash
];
3456 XSYMBOL (tail
)->next
;
3459 XSETSYMBOL (following
, XSYMBOL (tail
)->next
);
3460 if (EQ (following
, tem
))
3462 XSYMBOL (tail
)->next
= XSYMBOL (following
)->next
;
3471 /* Return the symbol in OBARRAY whose names matches the string
3472 of SIZE characters (SIZE_BYTE bytes) at PTR.
3473 If there is no such symbol in OBARRAY, return nil.
3475 Also store the bucket number in oblookup_last_bucket_number. */
3478 oblookup (obarray
, ptr
, size
, size_byte
)
3479 Lisp_Object obarray
;
3480 register const char *ptr
;
3481 int size
, size_byte
;
3485 register Lisp_Object tail
;
3486 Lisp_Object bucket
, tem
;
3488 if (!VECTORP (obarray
)
3489 || (obsize
= XVECTOR (obarray
)->size
) == 0)
3491 obarray
= check_obarray (obarray
);
3492 obsize
= XVECTOR (obarray
)->size
;
3494 /* This is sometimes needed in the middle of GC. */
3495 obsize
&= ~ARRAY_MARK_FLAG
;
3496 /* Combining next two lines breaks VMS C 2.3. */
3497 hash
= hash_string (ptr
, size_byte
);
3499 bucket
= XVECTOR (obarray
)->contents
[hash
];
3500 oblookup_last_bucket_number
= hash
;
3501 if (EQ (bucket
, make_number (0)))
3503 else if (!SYMBOLP (bucket
))
3504 error ("Bad data in guts of obarray"); /* Like CADR error message */
3506 for (tail
= bucket
; ; XSETSYMBOL (tail
, XSYMBOL (tail
)->next
))
3508 if (SBYTES (SYMBOL_NAME (tail
)) == size_byte
3509 && SCHARS (SYMBOL_NAME (tail
)) == size
3510 && !bcmp (SDATA (SYMBOL_NAME (tail
)), ptr
, size_byte
))
3512 else if (XSYMBOL (tail
)->next
== 0)
3515 XSETINT (tem
, hash
);
3520 hash_string (ptr
, len
)
3521 const unsigned char *ptr
;
3524 register const unsigned char *p
= ptr
;
3525 register const unsigned char *end
= p
+ len
;
3526 register unsigned char c
;
3527 register int hash
= 0;
3532 if (c
>= 0140) c
-= 40;
3533 hash
= ((hash
<<3) + (hash
>>28) + c
);
3535 return hash
& 07777777777;
3539 map_obarray (obarray
, fn
, arg
)
3540 Lisp_Object obarray
;
3541 void (*fn
) P_ ((Lisp_Object
, Lisp_Object
));
3545 register Lisp_Object tail
;
3546 CHECK_VECTOR (obarray
);
3547 for (i
= XVECTOR (obarray
)->size
- 1; i
>= 0; i
--)
3549 tail
= XVECTOR (obarray
)->contents
[i
];
3554 if (XSYMBOL (tail
)->next
== 0)
3556 XSETSYMBOL (tail
, XSYMBOL (tail
)->next
);
3562 mapatoms_1 (sym
, function
)
3563 Lisp_Object sym
, function
;
3565 call1 (function
, sym
);
3568 DEFUN ("mapatoms", Fmapatoms
, Smapatoms
, 1, 2, 0,
3569 doc
: /* Call FUNCTION on every symbol in OBARRAY.
3570 OBARRAY defaults to the value of `obarray'. */)
3572 Lisp_Object function
, obarray
;
3574 if (NILP (obarray
)) obarray
= Vobarray
;
3575 obarray
= check_obarray (obarray
);
3577 map_obarray (obarray
, mapatoms_1
, function
);
3581 #define OBARRAY_SIZE 1511
3586 Lisp_Object oblength
;
3590 XSETFASTINT (oblength
, OBARRAY_SIZE
);
3592 Qnil
= Fmake_symbol (make_pure_string ("nil", 3, 3, 0));
3593 Vobarray
= Fmake_vector (oblength
, make_number (0));
3594 initial_obarray
= Vobarray
;
3595 staticpro (&initial_obarray
);
3596 /* Intern nil in the obarray */
3597 XSYMBOL (Qnil
)->interned
= SYMBOL_INTERNED_IN_INITIAL_OBARRAY
;
3598 XSYMBOL (Qnil
)->constant
= 1;
3600 /* These locals are to kludge around a pyramid compiler bug. */
3601 hash
= hash_string ("nil", 3);
3602 /* Separate statement here to avoid VAXC bug. */
3603 hash
%= OBARRAY_SIZE
;
3604 tem
= &XVECTOR (Vobarray
)->contents
[hash
];
3607 Qunbound
= Fmake_symbol (make_pure_string ("unbound", 7, 7, 0));
3608 XSYMBOL (Qnil
)->function
= Qunbound
;
3609 XSYMBOL (Qunbound
)->value
= Qunbound
;
3610 XSYMBOL (Qunbound
)->function
= Qunbound
;
3613 XSYMBOL (Qnil
)->value
= Qnil
;
3614 XSYMBOL (Qnil
)->plist
= Qnil
;
3615 XSYMBOL (Qt
)->value
= Qt
;
3616 XSYMBOL (Qt
)->constant
= 1;
3618 /* Qt is correct even if CANNOT_DUMP. loadup.el will set to nil at end. */
3621 Qvariable_documentation
= intern ("variable-documentation");
3622 staticpro (&Qvariable_documentation
);
3624 read_buffer_size
= 100 + MAX_MULTIBYTE_LENGTH
;
3625 read_buffer
= (char *) xmalloc (read_buffer_size
);
3630 struct Lisp_Subr
*sname
;
3633 sym
= intern (sname
->symbol_name
);
3634 XSETSUBR (XSYMBOL (sym
)->function
, sname
);
3637 #ifdef NOTDEF /* use fset in subr.el now */
3639 defalias (sname
, string
)
3640 struct Lisp_Subr
*sname
;
3644 sym
= intern (string
);
3645 XSETSUBR (XSYMBOL (sym
)->function
, sname
);
3649 /* Define an "integer variable"; a symbol whose value is forwarded
3650 to a C variable of type int. Sample call: */
3651 /* DEFVAR_INT ("indent-tabs-mode", &indent_tabs_mode, "Documentation"); */
3653 defvar_int (namestring
, address
)
3657 Lisp_Object sym
, val
;
3658 sym
= intern (namestring
);
3659 val
= allocate_misc ();
3660 XMISCTYPE (val
) = Lisp_Misc_Intfwd
;
3661 XINTFWD (val
)->intvar
= address
;
3662 SET_SYMBOL_VALUE (sym
, val
);
3665 /* Similar but define a variable whose value is t if address contains 1,
3666 nil if address contains 0 */
3668 defvar_bool (namestring
, address
)
3672 Lisp_Object sym
, val
;
3673 sym
= intern (namestring
);
3674 val
= allocate_misc ();
3675 XMISCTYPE (val
) = Lisp_Misc_Boolfwd
;
3676 XBOOLFWD (val
)->boolvar
= address
;
3677 SET_SYMBOL_VALUE (sym
, val
);
3678 Vbyte_boolean_vars
= Fcons (sym
, Vbyte_boolean_vars
);
3681 /* Similar but define a variable whose value is the Lisp Object stored
3682 at address. Two versions: with and without gc-marking of the C
3683 variable. The nopro version is used when that variable will be
3684 gc-marked for some other reason, since marking the same slot twice
3685 can cause trouble with strings. */
3687 defvar_lisp_nopro (namestring
, address
)
3689 Lisp_Object
*address
;
3691 Lisp_Object sym
, val
;
3692 sym
= intern (namestring
);
3693 val
= allocate_misc ();
3694 XMISCTYPE (val
) = Lisp_Misc_Objfwd
;
3695 XOBJFWD (val
)->objvar
= address
;
3696 SET_SYMBOL_VALUE (sym
, val
);
3700 defvar_lisp (namestring
, address
)
3702 Lisp_Object
*address
;
3704 defvar_lisp_nopro (namestring
, address
);
3705 staticpro (address
);
3708 /* Similar but define a variable whose value is the Lisp Object stored in
3709 the current buffer. address is the address of the slot in the buffer
3710 that is current now. */
3713 defvar_per_buffer (namestring
, address
, type
, doc
)
3715 Lisp_Object
*address
;
3719 Lisp_Object sym
, val
;
3722 sym
= intern (namestring
);
3723 val
= allocate_misc ();
3724 offset
= (char *)address
- (char *)current_buffer
;
3726 XMISCTYPE (val
) = Lisp_Misc_Buffer_Objfwd
;
3727 XBUFFER_OBJFWD (val
)->offset
= offset
;
3728 SET_SYMBOL_VALUE (sym
, val
);
3729 PER_BUFFER_SYMBOL (offset
) = sym
;
3730 PER_BUFFER_TYPE (offset
) = type
;
3732 if (PER_BUFFER_IDX (offset
) == 0)
3733 /* Did a DEFVAR_PER_BUFFER without initializing the corresponding
3734 slot of buffer_local_flags */
3739 /* Similar but define a variable whose value is the Lisp Object stored
3740 at a particular offset in the current kboard object. */
3743 defvar_kboard (namestring
, offset
)
3747 Lisp_Object sym
, val
;
3748 sym
= intern (namestring
);
3749 val
= allocate_misc ();
3750 XMISCTYPE (val
) = Lisp_Misc_Kboard_Objfwd
;
3751 XKBOARD_OBJFWD (val
)->offset
= offset
;
3752 SET_SYMBOL_VALUE (sym
, val
);
3755 /* Record the value of load-path used at the start of dumping
3756 so we can see if the site changed it later during dumping. */
3757 static Lisp_Object dump_path
;
3763 int turn_off_warning
= 0;
3765 /* Compute the default load-path. */
3767 normal
= PATH_LOADSEARCH
;
3768 Vload_path
= decode_env_path (0, normal
);
3770 if (NILP (Vpurify_flag
))
3771 normal
= PATH_LOADSEARCH
;
3773 normal
= PATH_DUMPLOADSEARCH
;
3775 /* In a dumped Emacs, we normally have to reset the value of
3776 Vload_path from PATH_LOADSEARCH, since the value that was dumped
3777 uses ../lisp, instead of the path of the installed elisp
3778 libraries. However, if it appears that Vload_path was changed
3779 from the default before dumping, don't override that value. */
3782 if (! NILP (Fequal (dump_path
, Vload_path
)))
3784 Vload_path
= decode_env_path (0, normal
);
3785 if (!NILP (Vinstallation_directory
))
3787 Lisp_Object tem
, tem1
, sitelisp
;
3789 /* Remove site-lisp dirs from path temporarily and store
3790 them in sitelisp, then conc them on at the end so
3791 they're always first in path. */
3795 tem
= Fcar (Vload_path
);
3796 tem1
= Fstring_match (build_string ("site-lisp"),
3800 Vload_path
= Fcdr (Vload_path
);
3801 sitelisp
= Fcons (tem
, sitelisp
);
3807 /* Add to the path the lisp subdir of the
3808 installation dir, if it exists. */
3809 tem
= Fexpand_file_name (build_string ("lisp"),
3810 Vinstallation_directory
);
3811 tem1
= Ffile_exists_p (tem
);
3814 if (NILP (Fmember (tem
, Vload_path
)))
3816 turn_off_warning
= 1;
3817 Vload_path
= Fcons (tem
, Vload_path
);
3821 /* That dir doesn't exist, so add the build-time
3822 Lisp dirs instead. */
3823 Vload_path
= nconc2 (Vload_path
, dump_path
);
3825 /* Add leim under the installation dir, if it exists. */
3826 tem
= Fexpand_file_name (build_string ("leim"),
3827 Vinstallation_directory
);
3828 tem1
= Ffile_exists_p (tem
);
3831 if (NILP (Fmember (tem
, Vload_path
)))
3832 Vload_path
= Fcons (tem
, Vload_path
);
3835 /* Add site-list under the installation dir, if it exists. */
3836 tem
= Fexpand_file_name (build_string ("site-lisp"),
3837 Vinstallation_directory
);
3838 tem1
= Ffile_exists_p (tem
);
3841 if (NILP (Fmember (tem
, Vload_path
)))
3842 Vload_path
= Fcons (tem
, Vload_path
);
3845 /* If Emacs was not built in the source directory,
3846 and it is run from where it was built, add to load-path
3847 the lisp, leim and site-lisp dirs under that directory. */
3849 if (NILP (Fequal (Vinstallation_directory
, Vsource_directory
)))
3853 tem
= Fexpand_file_name (build_string ("src/Makefile"),
3854 Vinstallation_directory
);
3855 tem1
= Ffile_exists_p (tem
);
3857 /* Don't be fooled if they moved the entire source tree
3858 AFTER dumping Emacs. If the build directory is indeed
3859 different from the source dir, src/Makefile.in and
3860 src/Makefile will not be found together. */
3861 tem
= Fexpand_file_name (build_string ("src/Makefile.in"),
3862 Vinstallation_directory
);
3863 tem2
= Ffile_exists_p (tem
);
3864 if (!NILP (tem1
) && NILP (tem2
))
3866 tem
= Fexpand_file_name (build_string ("lisp"),
3869 if (NILP (Fmember (tem
, Vload_path
)))
3870 Vload_path
= Fcons (tem
, Vload_path
);
3872 tem
= Fexpand_file_name (build_string ("leim"),
3875 if (NILP (Fmember (tem
, Vload_path
)))
3876 Vload_path
= Fcons (tem
, Vload_path
);
3878 tem
= Fexpand_file_name (build_string ("site-lisp"),
3881 if (NILP (Fmember (tem
, Vload_path
)))
3882 Vload_path
= Fcons (tem
, Vload_path
);
3885 if (!NILP (sitelisp
))
3886 Vload_path
= nconc2 (Fnreverse (sitelisp
), Vload_path
);
3892 /* NORMAL refers to the lisp dir in the source directory. */
3893 /* We used to add ../lisp at the front here, but
3894 that caused trouble because it was copied from dump_path
3895 into Vload_path, aboe, when Vinstallation_directory was non-nil.
3896 It should be unnecessary. */
3897 Vload_path
= decode_env_path (0, normal
);
3898 dump_path
= Vload_path
;
3902 #if (!(defined(WINDOWSNT) || (defined(HAVE_CARBON))))
3903 /* When Emacs is invoked over network shares on NT, PATH_LOADSEARCH is
3904 almost never correct, thereby causing a warning to be printed out that
3905 confuses users. Since PATH_LOADSEARCH is always overridden by the
3906 EMACSLOADPATH environment variable below, disable the warning on NT.
3907 Also, when using the "self-contained" option for Carbon Emacs for MacOSX,
3908 the "standard" paths may not exist and would be overridden by
3909 EMACSLOADPATH as on NT. Since this depends on how the executable
3910 was build and packaged, turn off the warnings in general */
3912 /* Warn if dirs in the *standard* path don't exist. */
3913 if (!turn_off_warning
)
3915 Lisp_Object path_tail
;
3917 for (path_tail
= Vload_path
;
3919 path_tail
= XCDR (path_tail
))
3921 Lisp_Object dirfile
;
3922 dirfile
= Fcar (path_tail
);
3923 if (STRINGP (dirfile
))
3925 dirfile
= Fdirectory_file_name (dirfile
);
3926 if (access (SDATA (dirfile
), 0) < 0)
3927 dir_warning ("Warning: Lisp directory `%s' does not exist.\n",
3932 #endif /* !(WINDOWSNT || HAVE_CARBON) */
3934 /* If the EMACSLOADPATH environment variable is set, use its value.
3935 This doesn't apply if we're dumping. */
3937 if (NILP (Vpurify_flag
)
3938 && egetenv ("EMACSLOADPATH"))
3940 Vload_path
= decode_env_path ("EMACSLOADPATH", normal
);
3944 load_in_progress
= 0;
3945 Vload_file_name
= Qnil
;
3947 load_descriptor_list
= Qnil
;
3949 Vstandard_input
= Qt
;
3950 Vloads_in_progress
= Qnil
;
3953 /* Print a warning, using format string FORMAT, that directory DIRNAME
3954 does not exist. Print it on stderr and put it in *Message*. */
3957 dir_warning (format
, dirname
)
3959 Lisp_Object dirname
;
3962 = (char *) alloca (SCHARS (dirname
) + strlen (format
) + 5);
3964 fprintf (stderr
, format
, SDATA (dirname
));
3965 sprintf (buffer
, format
, SDATA (dirname
));
3966 /* Don't log the warning before we've initialized!! */
3968 message_dolog (buffer
, strlen (buffer
), 0, STRING_MULTIBYTE (dirname
));
3975 defsubr (&Sread_from_string
);
3977 defsubr (&Sintern_soft
);
3978 defsubr (&Sunintern
);
3979 defsubr (&Sget_load_suffixes
);
3981 defsubr (&Seval_buffer
);
3982 defsubr (&Seval_region
);
3983 defsubr (&Sread_char
);
3984 defsubr (&Sread_char_exclusive
);
3985 defsubr (&Sread_event
);
3986 defsubr (&Sget_file_char
);
3987 defsubr (&Smapatoms
);
3988 defsubr (&Slocate_file_internal
);
3990 DEFVAR_LISP ("obarray", &Vobarray
,
3991 doc
: /* Symbol table for use by `intern' and `read'.
3992 It is a vector whose length ought to be prime for best results.
3993 The vector's contents don't make sense if examined from Lisp programs;
3994 to find all the symbols in an obarray, use `mapatoms'. */);
3996 DEFVAR_LISP ("values", &Vvalues
,
3997 doc
: /* List of values of all expressions which were read, evaluated and printed.
3998 Order is reverse chronological. */);
4000 DEFVAR_LISP ("standard-input", &Vstandard_input
,
4001 doc
: /* Stream for read to get input from.
4002 See documentation of `read' for possible values. */);
4003 Vstandard_input
= Qt
;
4005 DEFVAR_LISP ("read-with-symbol-positions", &Vread_with_symbol_positions
,
4006 doc
: /* If non-nil, add position of read symbols to `read-symbol-positions-list'.
4008 If this variable is a buffer, then only forms read from that buffer
4009 will be added to `read-symbol-positions-list'.
4010 If this variable is t, then all read forms will be added.
4011 The effect of all other values other than nil are not currently
4012 defined, although they may be in the future.
4014 The positions are relative to the last call to `read' or
4015 `read-from-string'. It is probably a bad idea to set this variable at
4016 the toplevel; bind it instead. */);
4017 Vread_with_symbol_positions
= Qnil
;
4019 DEFVAR_LISP ("read-symbol-positions-list", &Vread_symbol_positions_list
,
4020 doc
: /* A list mapping read symbols to their positions.
4021 This variable is modified during calls to `read' or
4022 `read-from-string', but only when `read-with-symbol-positions' is
4025 Each element of the list looks like (SYMBOL . CHAR-POSITION), where
4026 CHAR-POSITION is an integer giving the offset of that occurrence of the
4027 symbol from the position where `read' or `read-from-string' started.
4029 Note that a symbol will appear multiple times in this list, if it was
4030 read multiple times. The list is in the same order as the symbols
4032 Vread_symbol_positions_list
= Qnil
;
4034 DEFVAR_LISP ("load-path", &Vload_path
,
4035 doc
: /* *List of directories to search for files to load.
4036 Each element is a string (directory name) or nil (try default directory).
4037 Initialized based on EMACSLOADPATH environment variable, if any,
4038 otherwise to default specified by file `epaths.h' when Emacs was built. */);
4040 DEFVAR_LISP ("load-suffixes", &Vload_suffixes
,
4041 doc
: /* List of suffixes for (compiled or source) Emacs Lisp files.
4042 This list should not include the empty string.
4043 `load' and related functions try to append these suffixes, in order,
4044 to the specified file name if a Lisp suffix is allowed or required. */);
4045 Vload_suffixes
= Fcons (build_string (".elc"),
4046 Fcons (build_string (".el"), Qnil
));
4047 DEFVAR_LISP ("load-file-rep-suffixes", &Vload_file_rep_suffixes
,
4048 doc
: /* List of suffixes that indicate representations of \
4050 This list should normally start with the empty string.
4052 Enabling Auto Compression mode appends the suffixes in
4053 `jka-compr-load-suffixes' to this list and disabling Auto Compression
4054 mode removes them again. `load' and related functions use this list to
4055 determine whether they should look for compressed versions of a file
4056 and, if so, which suffixes they should try to append to the file name
4057 in order to do so. However, if you want to customize which suffixes
4058 the loading functions recognize as compression suffixes, you should
4059 customize `jka-compr-load-suffixes' rather than the present variable. */);
4060 /* We don't use empty_string because it's not initialized yet. */
4061 Vload_file_rep_suffixes
= Fcons (build_string (""), Qnil
);
4063 DEFVAR_BOOL ("load-in-progress", &load_in_progress
,
4064 doc
: /* Non-nil iff inside of `load'. */);
4066 DEFVAR_LISP ("after-load-alist", &Vafter_load_alist
,
4067 doc
: /* An alist of expressions to be evalled when particular files are loaded.
4068 Each element looks like (REGEXP-OR-FEATURE FORMS...).
4070 REGEXP-OR-FEATURE is either a regular expression to match file names, or
4071 a symbol \(a feature name).
4073 When `load' is run and the file-name argument matches an element's
4074 REGEXP-OR-FEATURE, or when `provide' is run and provides the symbol
4075 REGEXP-OR-FEATURE, the FORMS in the element are executed.
4077 An error in FORMS does not undo the load, but does prevent execution of
4078 the rest of the FORMS. */);
4079 Vafter_load_alist
= Qnil
;
4081 DEFVAR_LISP ("load-history", &Vload_history
,
4082 doc
: /* Alist mapping file names to symbols and features.
4083 Each alist element is a list that starts with a file name,
4084 except for one element (optional) that starts with nil and describes
4085 definitions evaluated from buffers not visiting files.
4087 The file name is absolute and is the true file name (i.e. it doesn't
4088 contain symbolic links) of the loaded file.
4090 The remaining elements of each list are symbols defined as variables
4091 and cons cells of the form `(provide . FEATURE)', `(require . FEATURE)',
4092 `(defun . FUNCTION)', `(autoload . SYMBOL)', and `(t . SYMBOL)'.
4093 An element `(t . SYMBOL)' precedes an entry `(defun . FUNCTION)',
4094 and means that SYMBOL was an autoload before this file redefined it
4097 During preloading, the file name recorded is relative to the main Lisp
4098 directory. These file names are converted to absolute at startup. */);
4099 Vload_history
= Qnil
;
4101 DEFVAR_LISP ("load-file-name", &Vload_file_name
,
4102 doc
: /* Full name of file being loaded by `load'. */);
4103 Vload_file_name
= Qnil
;
4105 DEFVAR_LISP ("user-init-file", &Vuser_init_file
,
4106 doc
: /* File name, including directory, of user's initialization file.
4107 If the file loaded had extension `.elc', and the corresponding source file
4108 exists, this variable contains the name of source file, suitable for use
4109 by functions like `custom-save-all' which edit the init file. */);
4110 Vuser_init_file
= Qnil
;
4112 DEFVAR_LISP ("current-load-list", &Vcurrent_load_list
,
4113 doc
: /* Used for internal purposes by `load'. */);
4114 Vcurrent_load_list
= Qnil
;
4116 DEFVAR_LISP ("load-read-function", &Vload_read_function
,
4117 doc
: /* Function used by `load' and `eval-region' for reading expressions.
4118 The default is nil, which means use the function `read'. */);
4119 Vload_read_function
= Qnil
;
4121 DEFVAR_LISP ("load-source-file-function", &Vload_source_file_function
,
4122 doc
: /* Function called in `load' for loading an Emacs lisp source file.
4123 This function is for doing code conversion before reading the source file.
4124 If nil, loading is done without any code conversion.
4125 Arguments are FULLNAME, FILE, NOERROR, NOMESSAGE, where
4126 FULLNAME is the full name of FILE.
4127 See `load' for the meaning of the remaining arguments. */);
4128 Vload_source_file_function
= Qnil
;
4130 DEFVAR_BOOL ("load-force-doc-strings", &load_force_doc_strings
,
4131 doc
: /* Non-nil means `load' should force-load all dynamic doc strings.
4132 This is useful when the file being loaded is a temporary copy. */);
4133 load_force_doc_strings
= 0;
4135 DEFVAR_BOOL ("load-convert-to-unibyte", &load_convert_to_unibyte
,
4136 doc
: /* Non-nil means `read' converts strings to unibyte whenever possible.
4137 This is normally bound by `load' and `eval-buffer' to control `read',
4138 and is not meant for users to change. */);
4139 load_convert_to_unibyte
= 0;
4141 DEFVAR_LISP ("source-directory", &Vsource_directory
,
4142 doc
: /* Directory in which Emacs sources were found when Emacs was built.
4143 You cannot count on them to still be there! */);
4145 = Fexpand_file_name (build_string ("../"),
4146 Fcar (decode_env_path (0, PATH_DUMPLOADSEARCH
)));
4148 DEFVAR_LISP ("preloaded-file-list", &Vpreloaded_file_list
,
4149 doc
: /* List of files that were preloaded (when dumping Emacs). */);
4150 Vpreloaded_file_list
= Qnil
;
4152 DEFVAR_LISP ("byte-boolean-vars", &Vbyte_boolean_vars
,
4153 doc
: /* List of all DEFVAR_BOOL variables, used by the byte code optimizer. */);
4154 Vbyte_boolean_vars
= Qnil
;
4156 DEFVAR_BOOL ("load-dangerous-libraries", &load_dangerous_libraries
,
4157 doc
: /* Non-nil means load dangerous compiled Lisp files.
4158 Some versions of XEmacs use different byte codes than Emacs. These
4159 incompatible byte codes can make Emacs crash when it tries to execute
4161 load_dangerous_libraries
= 0;
4163 DEFVAR_LISP ("bytecomp-version-regexp", &Vbytecomp_version_regexp
,
4164 doc
: /* Regular expression matching safe to load compiled Lisp files.
4165 When Emacs loads a compiled Lisp file, it reads the first 512 bytes
4166 from the file, and matches them against this regular expression.
4167 When the regular expression matches, the file is considered to be safe
4168 to load. See also `load-dangerous-libraries'. */);
4169 Vbytecomp_version_regexp
4170 = build_string ("^;;;.\\(in Emacs version\\|bytecomp version FSF\\)");
4172 DEFVAR_LISP ("eval-buffer-list", &Veval_buffer_list
,
4173 doc
: /* List of buffers being read from by calls to `eval-buffer' and `eval-region'. */);
4174 Veval_buffer_list
= Qnil
;
4176 /* Vsource_directory was initialized in init_lread. */
4178 load_descriptor_list
= Qnil
;
4179 staticpro (&load_descriptor_list
);
4181 Qcurrent_load_list
= intern ("current-load-list");
4182 staticpro (&Qcurrent_load_list
);
4184 Qstandard_input
= intern ("standard-input");
4185 staticpro (&Qstandard_input
);
4187 Qread_char
= intern ("read-char");
4188 staticpro (&Qread_char
);
4190 Qget_file_char
= intern ("get-file-char");
4191 staticpro (&Qget_file_char
);
4193 Qbackquote
= intern ("`");
4194 staticpro (&Qbackquote
);
4195 Qcomma
= intern (",");
4196 staticpro (&Qcomma
);
4197 Qcomma_at
= intern (",@");
4198 staticpro (&Qcomma_at
);
4199 Qcomma_dot
= intern (",.");
4200 staticpro (&Qcomma_dot
);
4202 Qinhibit_file_name_operation
= intern ("inhibit-file-name-operation");
4203 staticpro (&Qinhibit_file_name_operation
);
4205 Qascii_character
= intern ("ascii-character");
4206 staticpro (&Qascii_character
);
4208 Qfunction
= intern ("function");
4209 staticpro (&Qfunction
);
4211 Qload
= intern ("load");
4214 Qload_file_name
= intern ("load-file-name");
4215 staticpro (&Qload_file_name
);
4217 Qeval_buffer_list
= intern ("eval-buffer-list");
4218 staticpro (&Qeval_buffer_list
);
4220 Qfile_truename
= intern ("file-truename");
4221 staticpro (&Qfile_truename
) ;
4223 Qdo_after_load_evaluation
= intern ("do-after-load-evaluation");
4224 staticpro (&Qdo_after_load_evaluation
) ;
4226 staticpro (&dump_path
);
4228 staticpro (&read_objects
);
4229 read_objects
= Qnil
;
4230 staticpro (&seen_list
);
4233 Vloads_in_progress
= Qnil
;
4234 staticpro (&Vloads_in_progress
);
4237 /* arch-tag: a0d02733-0f96-4844-a659-9fd53c4f414d
4238 (do not change this comment) */