1 /* Lisp parsing and input streams.
2 Copyright (C) 1985, 1986, 1987, 1988, 1989, 1993, 1994, 1995,
3 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
4 2005, 2006, 2007 Free Software Foundation, Inc.
6 This file is part of GNU Emacs.
8 GNU Emacs is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 3, or (at your option)
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs; see the file COPYING. If not, write to
20 the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
21 Boston, MA 02110-1301, USA. */
26 #include <sys/types.h>
31 #include "intervals.h"
37 #include "termhooks.h"
39 #include "blockinput.h"
42 #include <sys/inode.h>
47 #include <unistd.h> /* to get X_OK */
64 #endif /* HAVE_SETLOCALE */
74 #define file_offset off_t
75 #define file_tell ftello
77 #define file_offset long
78 #define file_tell ftell
85 Lisp_Object Qread_char
, Qget_file_char
, Qstandard_input
, Qcurrent_load_list
;
86 Lisp_Object Qvariable_documentation
, Vvalues
, Vstandard_input
, Vafter_load_alist
;
87 Lisp_Object Qascii_character
, Qload
, Qload_file_name
;
88 Lisp_Object Qbackquote
, Qcomma
, Qcomma_at
, Qcomma_dot
, Qfunction
;
89 Lisp_Object Qinhibit_file_name_operation
;
90 Lisp_Object Qeval_buffer_list
, Veval_buffer_list
;
91 Lisp_Object Qfile_truename
, Qdo_after_load_evaluation
; /* ACM 2006/5/16 */
93 extern Lisp_Object Qevent_symbol_element_mask
;
94 extern Lisp_Object Qfile_exists_p
;
96 /* non-zero if inside `load' */
99 /* Directory in which the sources were found. */
100 Lisp_Object Vsource_directory
;
102 /* Search path and suffixes for files to be loaded. */
103 Lisp_Object Vload_path
, Vload_suffixes
, Vload_file_rep_suffixes
;
105 /* File name of user's init file. */
106 Lisp_Object Vuser_init_file
;
108 /* This is the user-visible association list that maps features to
109 lists of defs in their load files. */
110 Lisp_Object Vload_history
;
112 /* This is used to build the load history. */
113 Lisp_Object Vcurrent_load_list
;
115 /* List of files that were preloaded. */
116 Lisp_Object Vpreloaded_file_list
;
118 /* Name of file actually being read by `load'. */
119 Lisp_Object Vload_file_name
;
121 /* Function to use for reading, in `load' and friends. */
122 Lisp_Object Vload_read_function
;
124 /* The association list of objects read with the #n=object form.
125 Each member of the list has the form (n . object), and is used to
126 look up the object for the corresponding #n# construct.
127 It must be set to nil before all top-level calls to read0. */
128 Lisp_Object read_objects
;
130 /* Nonzero means load should forcibly load all dynamic doc strings. */
131 static int load_force_doc_strings
;
133 /* Nonzero means read should convert strings to unibyte. */
134 static int load_convert_to_unibyte
;
136 /* Function to use for loading an Emacs Lisp source file (not
137 compiled) instead of readevalloop. */
138 Lisp_Object Vload_source_file_function
;
140 /* List of all DEFVAR_BOOL variables. Used by the byte optimizer. */
141 Lisp_Object Vbyte_boolean_vars
;
143 /* Whether or not to add a `read-positions' property to symbols
145 Lisp_Object Vread_with_symbol_positions
;
147 /* List of (SYMBOL . POSITION) accumulated so far. */
148 Lisp_Object Vread_symbol_positions_list
;
150 /* List of descriptors now open for Fload. */
151 static Lisp_Object load_descriptor_list
;
153 /* File for get_file_char to read from. Use by load. */
154 static FILE *instream
;
156 /* When nonzero, read conses in pure space */
157 static int read_pure
;
159 /* For use within read-from-string (this reader is non-reentrant!!) */
160 static int read_from_string_index
;
161 static int read_from_string_index_byte
;
162 static int read_from_string_limit
;
164 /* Number of bytes left to read in the buffer character
165 that `readchar' has already advanced over. */
166 static int readchar_backlog
;
167 /* Number of characters read in the current call to Fread or
168 Fread_from_string. */
169 static int readchar_count
;
171 /* This contains the last string skipped with #@. */
172 static char *saved_doc_string
;
173 /* Length of buffer allocated in saved_doc_string. */
174 static int saved_doc_string_size
;
175 /* Length of actual data in saved_doc_string. */
176 static int saved_doc_string_length
;
177 /* This is the file position that string came from. */
178 static file_offset saved_doc_string_position
;
180 /* This contains the previous string skipped with #@.
181 We copy it from saved_doc_string when a new string
182 is put in saved_doc_string. */
183 static char *prev_saved_doc_string
;
184 /* Length of buffer allocated in prev_saved_doc_string. */
185 static int prev_saved_doc_string_size
;
186 /* Length of actual data in prev_saved_doc_string. */
187 static int prev_saved_doc_string_length
;
188 /* This is the file position that string came from. */
189 static file_offset prev_saved_doc_string_position
;
191 /* Nonzero means inside a new-style backquote
192 with no surrounding parentheses.
193 Fread initializes this to zero, so we need not specbind it
194 or worry about what happens to it when there is an error. */
195 static int new_backquote_flag
;
197 /* A list of file names for files being loaded in Fload. Used to
198 check for recursive loads. */
200 static Lisp_Object Vloads_in_progress
;
202 /* Non-zero means load dangerous compiled Lisp files. */
204 int load_dangerous_libraries
;
206 /* A regular expression used to detect files compiled with Emacs. */
208 static Lisp_Object Vbytecomp_version_regexp
;
210 static void to_multibyte
P_ ((char **, char **, int *));
211 static void readevalloop
P_ ((Lisp_Object
, FILE*, Lisp_Object
,
212 Lisp_Object (*) (), int,
213 Lisp_Object
, Lisp_Object
,
214 Lisp_Object
, Lisp_Object
));
215 static Lisp_Object load_unwind
P_ ((Lisp_Object
));
216 static Lisp_Object load_descriptor_unwind
P_ ((Lisp_Object
));
218 static void invalid_syntax
P_ ((const char *, int)) NO_RETURN
;
219 static void end_of_file_error
P_ (()) NO_RETURN
;
222 /* Handle unreading and rereading of characters.
223 Write READCHAR to read a character,
224 UNREAD(c) to unread c to be read again.
226 The READCHAR and UNREAD macros are meant for reading/unreading a
227 byte code; they do not handle multibyte characters. The caller
228 should manage them if necessary.
230 [ Actually that seems to be a lie; READCHAR will definitely read
231 multibyte characters from buffer sources, at least. Is the
232 comment just out of date?
233 -- Colin Walters <walters@gnu.org>, 22 May 2002 16:36:50 -0400 ]
236 #define READCHAR readchar (readcharfun)
237 #define UNREAD(c) unreadchar (readcharfun, c)
240 readchar (readcharfun
)
241 Lisp_Object readcharfun
;
248 if (BUFFERP (readcharfun
))
250 register struct buffer
*inbuffer
= XBUFFER (readcharfun
);
252 int pt_byte
= BUF_PT_BYTE (inbuffer
);
253 int orig_pt_byte
= pt_byte
;
255 if (readchar_backlog
> 0)
256 /* We get the address of the byte just passed,
257 which is the last byte of the character.
258 The other bytes in this character are consecutive with it,
259 because the gap can't be in the middle of a character. */
260 return *(BUF_BYTE_ADDRESS (inbuffer
, BUF_PT_BYTE (inbuffer
) - 1)
261 - --readchar_backlog
);
263 if (pt_byte
>= BUF_ZV_BYTE (inbuffer
))
266 readchar_backlog
= -1;
268 if (! NILP (inbuffer
->enable_multibyte_characters
))
270 /* Fetch the character code from the buffer. */
271 unsigned char *p
= BUF_BYTE_ADDRESS (inbuffer
, pt_byte
);
272 BUF_INC_POS (inbuffer
, pt_byte
);
273 c
= STRING_CHAR (p
, pt_byte
- orig_pt_byte
);
277 c
= BUF_FETCH_BYTE (inbuffer
, pt_byte
);
280 SET_BUF_PT_BOTH (inbuffer
, BUF_PT (inbuffer
) + 1, pt_byte
);
284 if (MARKERP (readcharfun
))
286 register struct buffer
*inbuffer
= XMARKER (readcharfun
)->buffer
;
288 int bytepos
= marker_byte_position (readcharfun
);
289 int orig_bytepos
= bytepos
;
291 if (readchar_backlog
> 0)
292 /* We get the address of the byte just passed,
293 which is the last byte of the character.
294 The other bytes in this character are consecutive with it,
295 because the gap can't be in the middle of a character. */
296 return *(BUF_BYTE_ADDRESS (inbuffer
, XMARKER (readcharfun
)->bytepos
- 1)
297 - --readchar_backlog
);
299 if (bytepos
>= BUF_ZV_BYTE (inbuffer
))
302 readchar_backlog
= -1;
304 if (! NILP (inbuffer
->enable_multibyte_characters
))
306 /* Fetch the character code from the buffer. */
307 unsigned char *p
= BUF_BYTE_ADDRESS (inbuffer
, bytepos
);
308 BUF_INC_POS (inbuffer
, bytepos
);
309 c
= STRING_CHAR (p
, bytepos
- orig_bytepos
);
313 c
= BUF_FETCH_BYTE (inbuffer
, bytepos
);
317 XMARKER (readcharfun
)->bytepos
= bytepos
;
318 XMARKER (readcharfun
)->charpos
++;
323 if (EQ (readcharfun
, Qlambda
))
324 return read_bytecode_char (0);
326 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
)
345 if (STRINGP (readcharfun
))
347 if (read_from_string_index
>= read_from_string_limit
)
350 FETCH_STRING_CHAR_ADVANCE (c
, readcharfun
,
351 read_from_string_index
,
352 read_from_string_index_byte
);
357 tem
= call0 (readcharfun
);
364 /* Unread the character C in the way appropriate for the stream READCHARFUN.
365 If the stream is a user function, call it with the char as argument. */
368 unreadchar (readcharfun
, c
)
369 Lisp_Object readcharfun
;
374 /* Don't back up the pointer if we're unreading the end-of-input mark,
375 since readchar didn't advance it when we read it. */
377 else if (BUFFERP (readcharfun
))
379 struct buffer
*b
= XBUFFER (readcharfun
);
380 int bytepos
= BUF_PT_BYTE (b
);
382 if (readchar_backlog
>= 0)
387 if (! NILP (b
->enable_multibyte_characters
))
388 BUF_DEC_POS (b
, bytepos
);
392 BUF_PT_BYTE (b
) = bytepos
;
395 else if (MARKERP (readcharfun
))
397 struct buffer
*b
= XMARKER (readcharfun
)->buffer
;
398 int bytepos
= XMARKER (readcharfun
)->bytepos
;
400 if (readchar_backlog
>= 0)
404 XMARKER (readcharfun
)->charpos
--;
405 if (! NILP (b
->enable_multibyte_characters
))
406 BUF_DEC_POS (b
, bytepos
);
410 XMARKER (readcharfun
)->bytepos
= bytepos
;
413 else if (STRINGP (readcharfun
))
415 read_from_string_index
--;
416 read_from_string_index_byte
417 = string_char_to_byte (readcharfun
, read_from_string_index
);
419 else if (EQ (readcharfun
, Qlambda
))
420 read_bytecode_char (1);
421 else if (EQ (readcharfun
, Qget_file_char
))
424 ungetc (c
, instream
);
428 call1 (readcharfun
, make_number (c
));
431 static Lisp_Object read_internal_start
P_ ((Lisp_Object
, Lisp_Object
,
433 static Lisp_Object read0
P_ ((Lisp_Object
));
434 static Lisp_Object read1
P_ ((Lisp_Object
, int *, int));
436 static Lisp_Object read_list
P_ ((int, Lisp_Object
));
437 static Lisp_Object read_vector
P_ ((Lisp_Object
, int));
438 static int read_multibyte
P_ ((int, Lisp_Object
));
440 static Lisp_Object substitute_object_recurse
P_ ((Lisp_Object
, Lisp_Object
,
442 static void substitute_object_in_subtree
P_ ((Lisp_Object
,
444 static void substitute_in_interval
P_ ((INTERVAL
, Lisp_Object
));
447 /* Get a character from the tty. */
449 extern Lisp_Object
read_char ();
451 /* Read input events until we get one that's acceptable for our purposes.
453 If NO_SWITCH_FRAME is non-zero, switch-frame events are stashed
454 until we get a character we like, and then stuffed into
457 If ASCII_REQUIRED is non-zero, we check function key events to see
458 if the unmodified version of the symbol has a Qascii_character
459 property, and use that character, if present.
461 If ERROR_NONASCII is non-zero, we signal an error if the input we
462 get isn't an ASCII character with modifiers. If it's zero but
463 ASCII_REQUIRED is non-zero, we just re-read until we get an ASCII
466 If INPUT_METHOD is nonzero, we invoke the current input method
467 if the character warrants that.
469 If SECONDS is a number, we wait that many seconds for input, and
470 return Qnil if no input arrives within that time. */
473 read_filtered_event (no_switch_frame
, ascii_required
, error_nonascii
,
474 input_method
, seconds
)
475 int no_switch_frame
, ascii_required
, error_nonascii
, input_method
;
478 Lisp_Object val
, delayed_switch_frame
;
481 #ifdef HAVE_WINDOW_SYSTEM
482 if (display_hourglass_p
)
486 delayed_switch_frame
= Qnil
;
488 /* Compute timeout. */
489 if (NUMBERP (seconds
))
491 EMACS_TIME wait_time
;
493 double duration
= extract_float (seconds
);
495 sec
= (int) duration
;
496 usec
= (duration
- sec
) * 1000000;
497 EMACS_GET_TIME (end_time
);
498 EMACS_SET_SECS_USECS (wait_time
, sec
, usec
);
499 EMACS_ADD_TIME (end_time
, end_time
, wait_time
);
502 /* Read until we get an acceptable event. */
504 val
= read_char (0, 0, 0, (input_method
? Qnil
: Qt
), 0,
505 NUMBERP (seconds
) ? &end_time
: NULL
);
510 /* switch-frame events are put off until after the next ASCII
511 character. This is better than signaling an error just because
512 the last characters were typed to a separate minibuffer frame,
513 for example. Eventually, some code which can deal with
514 switch-frame events will read it and process it. */
516 && EVENT_HAS_PARAMETERS (val
)
517 && EQ (EVENT_HEAD_KIND (EVENT_HEAD (val
)), Qswitch_frame
))
519 delayed_switch_frame
= val
;
523 if (ascii_required
&& !(NUMBERP (seconds
) && NILP (val
)))
525 /* Convert certain symbols to their ASCII equivalents. */
528 Lisp_Object tem
, tem1
;
529 tem
= Fget (val
, Qevent_symbol_element_mask
);
532 tem1
= Fget (Fcar (tem
), Qascii_character
);
533 /* Merge this symbol's modifier bits
534 with the ASCII equivalent of its basic code. */
536 XSETFASTINT (val
, XINT (tem1
) | XINT (Fcar (Fcdr (tem
))));
540 /* If we don't have a character now, deal with it appropriately. */
545 Vunread_command_events
= Fcons (val
, Qnil
);
546 error ("Non-character input-event");
553 if (! NILP (delayed_switch_frame
))
554 unread_switch_frame
= delayed_switch_frame
;
558 #ifdef HAVE_WINDOW_SYSTEM
559 if (display_hourglass_p
)
568 DEFUN ("read-char", Fread_char
, Sread_char
, 0, 3, 0,
569 doc
: /* Read a character from the command input (keyboard or macro).
570 It is returned as a number.
571 If the user generates an event which is not a character (i.e. a mouse
572 click or function key event), `read-char' signals an error. As an
573 exception, switch-frame events are put off until non-ASCII events can
575 If you want to read non-character events, or ignore them, call
576 `read-event' or `read-char-exclusive' instead.
578 If the optional argument PROMPT is non-nil, display that as a prompt.
579 If the optional argument INHERIT-INPUT-METHOD is non-nil and some
580 input method is turned on in the current buffer, that input method
581 is used for reading a character.
582 If the optional argument SECONDS is non-nil, it should be a number
583 specifying the maximum number of seconds to wait for input. If no
584 input arrives in that time, return nil. SECONDS may be a
585 floating-point value. */)
586 (prompt
, inherit_input_method
, seconds
)
587 Lisp_Object prompt
, inherit_input_method
, seconds
;
590 message_with_string ("%s", prompt
, 0);
591 return read_filtered_event (1, 1, 1, ! NILP (inherit_input_method
), seconds
);
594 DEFUN ("read-event", Fread_event
, Sread_event
, 0, 3, 0,
595 doc
: /* Read an event object from the input stream.
596 If the optional argument PROMPT is non-nil, display that as a prompt.
597 If the optional argument INHERIT-INPUT-METHOD is non-nil and some
598 input method is turned on in the current buffer, that input method
599 is used for reading a character.
600 If the optional argument SECONDS is non-nil, it should be a number
601 specifying the maximum number of seconds to wait for input. If no
602 input arrives in that time, return nil. SECONDS may be a
603 floating-point value. */)
604 (prompt
, inherit_input_method
, seconds
)
605 Lisp_Object prompt
, inherit_input_method
, seconds
;
608 message_with_string ("%s", prompt
, 0);
609 return read_filtered_event (0, 0, 0, ! NILP (inherit_input_method
), seconds
);
612 DEFUN ("read-char-exclusive", Fread_char_exclusive
, Sread_char_exclusive
, 0, 3, 0,
613 doc
: /* Read a character from the command input (keyboard or macro).
614 It is returned as a number. Non-character events are ignored.
616 If the optional argument PROMPT is non-nil, display that as a prompt.
617 If the optional argument INHERIT-INPUT-METHOD is non-nil and some
618 input method is turned on in the current buffer, that input method
619 is used for reading a character.
620 If the optional argument SECONDS is non-nil, it should be a number
621 specifying the maximum number of seconds to wait for input. If no
622 input arrives in that time, return nil. SECONDS may be a
623 floating-point value. */)
624 (prompt
, inherit_input_method
, seconds
)
625 Lisp_Object prompt
, inherit_input_method
, seconds
;
628 message_with_string ("%s", prompt
, 0);
629 return read_filtered_event (1, 1, 0, ! NILP (inherit_input_method
), seconds
);
632 DEFUN ("get-file-char", Fget_file_char
, Sget_file_char
, 0, 0, 0,
633 doc
: /* Don't use this yourself. */)
636 register Lisp_Object val
;
638 XSETINT (val
, getc (instream
));
645 /* Value is non-zero if the file asswociated with file descriptor FD
646 is a compiled Lisp file that's safe to load. Only files compiled
647 with Emacs are safe to load. Files compiled with XEmacs can lead
648 to a crash in Fbyte_code because of an incompatible change in the
659 /* Read the first few bytes from the file, and look for a line
660 specifying the byte compiler version used. */
661 nbytes
= emacs_read (fd
, buf
, sizeof buf
- 1);
666 /* Skip to the next newline, skipping over the initial `ELC'
667 with NUL bytes following it. */
668 for (i
= 0; i
< nbytes
&& buf
[i
] != '\n'; ++i
)
672 && fast_c_string_match_ignore_case (Vbytecomp_version_regexp
,
677 lseek (fd
, 0, SEEK_SET
);
682 /* Callback for record_unwind_protect. Restore the old load list OLD,
683 after loading a file successfully. */
686 record_load_unwind (old
)
689 return Vloads_in_progress
= old
;
692 /* This handler function is used via internal_condition_case_1. */
695 load_error_handler (data
)
701 DEFUN ("get-load-suffixes", Fget_load_suffixes
, Sget_load_suffixes
, 0, 0, 0,
702 doc
: /* Return the suffixes that `load' should try if a suffix is \
704 This uses the variables `load-suffixes' and `load-file-rep-suffixes'. */)
707 Lisp_Object lst
= Qnil
, suffixes
= Vload_suffixes
, suffix
, ext
;
708 while (CONSP (suffixes
))
710 Lisp_Object exts
= Vload_file_rep_suffixes
;
711 suffix
= XCAR (suffixes
);
712 suffixes
= XCDR (suffixes
);
717 lst
= Fcons (concat2 (suffix
, ext
), lst
);
720 return Fnreverse (lst
);
723 DEFUN ("load", Fload
, Sload
, 1, 5, 0,
724 doc
: /* Execute a file of Lisp code named FILE.
725 First try FILE with `.elc' appended, then try with `.el',
726 then try FILE unmodified (the exact suffixes in the exact order are
727 determined by `load-suffixes'). Environment variable references in
728 FILE are replaced with their values by calling `substitute-in-file-name'.
729 This function searches the directories in `load-path'.
731 If optional second arg NOERROR is non-nil,
732 report no error if FILE doesn't exist.
733 Print messages at start and end of loading unless
734 optional third arg NOMESSAGE is non-nil.
735 If optional fourth arg NOSUFFIX is non-nil, don't try adding
736 suffixes `.elc' or `.el' to the specified name FILE.
737 If optional fifth arg MUST-SUFFIX is non-nil, insist on
738 the suffix `.elc' or `.el'; don't accept just FILE unless
739 it ends in one of those suffixes or includes a directory name.
741 If this function fails to find a file, it may look for different
742 representations of that file before trying another file.
743 It does so by adding the non-empty suffixes in `load-file-rep-suffixes'
744 to the file name. Emacs uses this feature mainly to find compressed
745 versions of files when Auto Compression mode is enabled.
747 The exact suffixes that this function tries out, in the exact order,
748 are given by the value of the variable `load-file-rep-suffixes' if
749 NOSUFFIX is non-nil and by the return value of the function
750 `get-load-suffixes' if MUST-SUFFIX is non-nil. If both NOSUFFIX and
751 MUST-SUFFIX are nil, this function first tries out the latter suffixes
754 Loading a file records its definitions, and its `provide' and
755 `require' calls, in an element of `load-history' whose
756 car is the file name loaded. See `load-history'.
758 Return t if the file exists and loads successfully. */)
759 (file
, noerror
, nomessage
, nosuffix
, must_suffix
)
760 Lisp_Object file
, noerror
, nomessage
, nosuffix
, must_suffix
;
762 register FILE *stream
;
763 register int fd
= -1;
764 int count
= SPECPDL_INDEX ();
766 struct gcpro gcpro1
, gcpro2
, gcpro3
;
767 Lisp_Object found
, efound
, hist_file_name
;
768 /* 1 means we printed the ".el is newer" message. */
770 /* 1 means we are loading a compiled file. */
782 /* If file name is magic, call the handler. */
783 /* This shouldn't be necessary any more now that `openp' handles it right.
784 handler = Ffind_file_name_handler (file, Qload);
786 return call5 (handler, Qload, file, noerror, nomessage, nosuffix); */
788 /* Do this after the handler to avoid
789 the need to gcpro noerror, nomessage and nosuffix.
790 (Below here, we care only whether they are nil or not.)
791 The presence of this call is the result of a historical accident:
792 it used to be in every file-operation and when it got removed
793 everywhere, it accidentally stayed here. Since then, enough people
794 supposedly have things like (load "$PROJECT/foo.el") in their .emacs
795 that it seemed risky to remove. */
796 if (! NILP (noerror
))
798 file
= internal_condition_case_1 (Fsubstitute_in_file_name
, file
,
799 Qt
, load_error_handler
);
804 file
= Fsubstitute_in_file_name (file
);
807 /* Avoid weird lossage with null string as arg,
808 since it would try to load a directory as a Lisp file */
809 if (SCHARS (file
) > 0)
811 int size
= SBYTES (file
);
814 GCPRO2 (file
, found
);
816 if (! NILP (must_suffix
))
818 /* Don't insist on adding a suffix if FILE already ends with one. */
820 && !strcmp (SDATA (file
) + size
- 3, ".el"))
823 && !strcmp (SDATA (file
) + size
- 4, ".elc"))
825 /* Don't insist on adding a suffix
826 if the argument includes a directory name. */
827 else if (! NILP (Ffile_name_directory (file
)))
831 fd
= openp (Vload_path
, file
,
832 (!NILP (nosuffix
) ? Qnil
833 : !NILP (must_suffix
) ? Fget_load_suffixes ()
834 : Fappend (2, (tmp
[0] = Fget_load_suffixes (),
835 tmp
[1] = Vload_file_rep_suffixes
,
844 xsignal2 (Qfile_error
, build_string ("Cannot open load file"), file
);
848 /* Tell startup.el whether or not we found the user's init file. */
849 if (EQ (Qt
, Vuser_init_file
))
850 Vuser_init_file
= found
;
852 /* If FD is -2, that means openp found a magic file. */
855 if (NILP (Fequal (found
, file
)))
856 /* If FOUND is a different file name from FILE,
857 find its handler even if we have already inhibited
858 the `load' operation on FILE. */
859 handler
= Ffind_file_name_handler (found
, Qt
);
861 handler
= Ffind_file_name_handler (found
, Qload
);
862 if (! NILP (handler
))
863 return call5 (handler
, Qload
, found
, noerror
, nomessage
, Qt
);
866 /* Check if we're stuck in a recursive load cycle.
868 2000-09-21: It's not possible to just check for the file loaded
869 being a member of Vloads_in_progress. This fails because of the
870 way the byte compiler currently works; `provide's are not
871 evaluted, see font-lock.el/jit-lock.el as an example. This
872 leads to a certain amount of ``normal'' recursion.
874 Also, just loading a file recursively is not always an error in
875 the general case; the second load may do something different. */
879 for (tem
= Vloads_in_progress
; CONSP (tem
); tem
= XCDR (tem
))
880 if (!NILP (Fequal (found
, XCAR (tem
))))
886 signal_error ("Recursive load", Fcons (found
, Vloads_in_progress
));
888 record_unwind_protect (record_load_unwind
, Vloads_in_progress
);
889 Vloads_in_progress
= Fcons (found
, Vloads_in_progress
);
892 /* Get the name for load-history. */
893 hist_file_name
= (! NILP (Vpurify_flag
)
894 ? Fconcat (2, (tmp
[0] = Ffile_name_directory (file
),
895 tmp
[1] = Ffile_name_nondirectory (found
),
899 if (!bcmp (SDATA (found
) + SBYTES (found
) - 4,
901 /* Load .elc files directly, but not when they are
902 remote and have no handler! */
909 GCPRO3 (file
, found
, hist_file_name
);
911 if (!safe_to_load_p (fd
))
914 if (!load_dangerous_libraries
)
918 error ("File `%s' was not compiled in Emacs",
921 else if (!NILP (nomessage
))
922 message_with_string ("File `%s' not compiled in Emacs", found
, 1);
927 efound
= ENCODE_FILE (found
);
932 stat ((char *)SDATA (efound
), &s1
);
933 SSET (efound
, SBYTES (efound
) - 1, 0);
934 result
= stat ((char *)SDATA (efound
), &s2
);
935 SSET (efound
, SBYTES (efound
) - 1, 'c');
937 if (result
>= 0 && (unsigned) s1
.st_mtime
< (unsigned) s2
.st_mtime
)
939 /* Make the progress messages mention that source is newer. */
942 /* If we won't print another message, mention this anyway. */
943 if (!NILP (nomessage
))
945 Lisp_Object msg_file
;
946 msg_file
= Fsubstring (found
, make_number (0), make_number (-1));
947 message_with_string ("Source file `%s' newer than byte-compiled file",
956 /* We are loading a source file (*.el). */
957 if (!NILP (Vload_source_file_function
))
963 val
= call4 (Vload_source_file_function
, found
, hist_file_name
,
964 NILP (noerror
) ? Qnil
: Qt
,
965 NILP (nomessage
) ? Qnil
: Qt
);
966 return unbind_to (count
, val
);
970 GCPRO3 (file
, found
, hist_file_name
);
974 efound
= ENCODE_FILE (found
);
975 stream
= fopen ((char *) SDATA (efound
), fmode
);
976 #else /* not WINDOWSNT */
977 stream
= fdopen (fd
, fmode
);
978 #endif /* not WINDOWSNT */
982 error ("Failure to create stdio stream for %s", SDATA (file
));
985 if (! NILP (Vpurify_flag
))
986 Vpreloaded_file_list
= Fcons (file
, Vpreloaded_file_list
);
988 if (NILP (nomessage
))
991 message_with_string ("Loading %s (compiled; note unsafe, not compiled in Emacs)...",
994 message_with_string ("Loading %s (source)...", file
, 1);
996 message_with_string ("Loading %s (compiled; note, source file is newer)...",
998 else /* The typical case; compiled file newer than source file. */
999 message_with_string ("Loading %s...", file
, 1);
1002 record_unwind_protect (load_unwind
, make_save_value (stream
, 0));
1003 record_unwind_protect (load_descriptor_unwind
, load_descriptor_list
);
1004 specbind (Qload_file_name
, found
);
1005 specbind (Qinhibit_file_name_operation
, Qnil
);
1006 load_descriptor_list
1007 = Fcons (make_number (fileno (stream
)), load_descriptor_list
);
1009 readevalloop (Qget_file_char
, stream
, hist_file_name
,
1010 Feval
, 0, Qnil
, Qnil
, Qnil
, Qnil
);
1011 unbind_to (count
, Qnil
);
1013 /* Run any eval-after-load forms for this file */
1014 if (NILP (Vpurify_flag
)
1015 && (!NILP (Ffboundp (Qdo_after_load_evaluation
))))
1016 call1 (Qdo_after_load_evaluation
, hist_file_name
) ;
1020 if (saved_doc_string
)
1021 free (saved_doc_string
);
1022 saved_doc_string
= 0;
1023 saved_doc_string_size
= 0;
1025 if (prev_saved_doc_string
)
1026 xfree (prev_saved_doc_string
);
1027 prev_saved_doc_string
= 0;
1028 prev_saved_doc_string_size
= 0;
1030 if (!noninteractive
&& NILP (nomessage
))
1033 message_with_string ("Loading %s (compiled; note unsafe, not compiled in Emacs)...done",
1036 message_with_string ("Loading %s (source)...done", file
, 1);
1038 message_with_string ("Loading %s (compiled; note, source file is newer)...done",
1040 else /* The typical case; compiled file newer than source file. */
1041 message_with_string ("Loading %s...done", file
, 1);
1044 if (!NILP (Fequal (build_string ("obsolete"),
1045 Ffile_name_nondirectory
1046 (Fdirectory_file_name (Ffile_name_directory (found
))))))
1047 message_with_string ("Package %s is obsolete", file
, 1);
1053 load_unwind (arg
) /* used as unwind-protect function in load */
1056 FILE *stream
= (FILE *) XSAVE_VALUE (arg
)->pointer
;
1063 if (--load_in_progress
< 0) load_in_progress
= 0;
1068 load_descriptor_unwind (oldlist
)
1069 Lisp_Object oldlist
;
1071 load_descriptor_list
= oldlist
;
1075 /* Close all descriptors in use for Floads.
1076 This is used when starting a subprocess. */
1083 for (tail
= load_descriptor_list
; !NILP (tail
); tail
= XCDR (tail
))
1084 emacs_close (XFASTINT (XCAR (tail
)));
1089 complete_filename_p (pathname
)
1090 Lisp_Object pathname
;
1092 register const unsigned char *s
= SDATA (pathname
);
1093 return (IS_DIRECTORY_SEP (s
[0])
1094 || (SCHARS (pathname
) > 2
1095 && IS_DEVICE_SEP (s
[1]) && IS_DIRECTORY_SEP (s
[2]))
1105 DEFUN ("locate-file-internal", Flocate_file_internal
, Slocate_file_internal
, 2, 4, 0,
1106 doc
: /* Search for FILENAME through PATH.
1107 Returns the file's name in absolute form, or nil if not found.
1108 If SUFFIXES is non-nil, it should be a list of suffixes to append to
1109 file name when searching.
1110 If non-nil, PREDICATE is used instead of `file-readable-p'.
1111 PREDICATE can also be an integer to pass to the access(2) function,
1112 in which case file-name-handlers are ignored. */)
1113 (filename
, path
, suffixes
, predicate
)
1114 Lisp_Object filename
, path
, suffixes
, predicate
;
1117 int fd
= openp (path
, filename
, suffixes
, &file
, predicate
);
1118 if (NILP (predicate
) && fd
> 0)
1124 /* Search for a file whose name is STR, looking in directories
1125 in the Lisp list PATH, and trying suffixes from SUFFIX.
1126 On success, returns a file descriptor. On failure, returns -1.
1128 SUFFIXES is a list of strings containing possible suffixes.
1129 The empty suffix is automatically added if the list is empty.
1131 PREDICATE non-nil means don't open the files,
1132 just look for one that satisfies the predicate. In this case,
1133 returns 1 on success. The predicate can be a lisp function or
1134 an integer to pass to `access' (in which case file-name-handlers
1137 If STOREPTR is nonzero, it points to a slot where the name of
1138 the file actually found should be stored as a Lisp string.
1139 nil is stored there on failure.
1141 If the file we find is remote, return -2
1142 but store the found remote file name in *STOREPTR. */
1145 openp (path
, str
, suffixes
, storeptr
, predicate
)
1146 Lisp_Object path
, str
;
1147 Lisp_Object suffixes
;
1148 Lisp_Object
*storeptr
;
1149 Lisp_Object predicate
;
1154 register char *fn
= buf
;
1157 Lisp_Object filename
;
1159 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
, gcpro5
, gcpro6
;
1160 Lisp_Object string
, tail
, encoded_fn
;
1161 int max_suffix_len
= 0;
1165 for (tail
= suffixes
; CONSP (tail
); tail
= XCDR (tail
))
1167 CHECK_STRING_CAR (tail
);
1168 max_suffix_len
= max (max_suffix_len
,
1169 SBYTES (XCAR (tail
)));
1172 string
= filename
= encoded_fn
= Qnil
;
1173 GCPRO6 (str
, string
, filename
, path
, suffixes
, encoded_fn
);
1178 if (complete_filename_p (str
))
1181 for (; CONSP (path
); path
= XCDR (path
))
1183 filename
= Fexpand_file_name (str
, XCAR (path
));
1184 if (!complete_filename_p (filename
))
1185 /* If there are non-absolute elts in PATH (eg ".") */
1186 /* Of course, this could conceivably lose if luser sets
1187 default-directory to be something non-absolute... */
1189 filename
= Fexpand_file_name (filename
, current_buffer
->directory
);
1190 if (!complete_filename_p (filename
))
1191 /* Give up on this path element! */
1195 /* Calculate maximum size of any filename made from
1196 this path element/specified file name and any possible suffix. */
1197 want_size
= max_suffix_len
+ SBYTES (filename
) + 1;
1198 if (fn_size
< want_size
)
1199 fn
= (char *) alloca (fn_size
= 100 + want_size
);
1201 /* Loop over suffixes. */
1202 for (tail
= NILP (suffixes
) ? Fcons (empty_unibyte_string
, Qnil
) : suffixes
;
1203 CONSP (tail
); tail
= XCDR (tail
))
1205 int lsuffix
= SBYTES (XCAR (tail
));
1206 Lisp_Object handler
;
1209 /* Concatenate path element/specified name with the suffix.
1210 If the directory starts with /:, remove that. */
1211 if (SCHARS (filename
) > 2
1212 && SREF (filename
, 0) == '/'
1213 && SREF (filename
, 1) == ':')
1215 strncpy (fn
, SDATA (filename
) + 2,
1216 SBYTES (filename
) - 2);
1217 fn
[SBYTES (filename
) - 2] = 0;
1221 strncpy (fn
, SDATA (filename
),
1223 fn
[SBYTES (filename
)] = 0;
1226 if (lsuffix
!= 0) /* Bug happens on CCI if lsuffix is 0. */
1227 strncat (fn
, SDATA (XCAR (tail
)), lsuffix
);
1229 /* Check that the file exists and is not a directory. */
1230 /* We used to only check for handlers on non-absolute file names:
1234 handler = Ffind_file_name_handler (filename, Qfile_exists_p);
1235 It's not clear why that was the case and it breaks things like
1236 (load "/bar.el") where the file is actually "/bar.el.gz". */
1237 string
= build_string (fn
);
1238 handler
= Ffind_file_name_handler (string
, Qfile_exists_p
);
1239 if ((!NILP (handler
) || !NILP (predicate
)) && !NATNUMP (predicate
))
1241 if (NILP (predicate
))
1242 exists
= !NILP (Ffile_readable_p (string
));
1244 exists
= !NILP (call1 (predicate
, string
));
1245 if (exists
&& !NILP (Ffile_directory_p (string
)))
1250 /* We succeeded; return this descriptor and filename. */
1261 encoded_fn
= ENCODE_FILE (string
);
1262 pfn
= SDATA (encoded_fn
);
1263 exists
= (stat (pfn
, &st
) >= 0
1264 && (st
.st_mode
& S_IFMT
) != S_IFDIR
);
1267 /* Check that we can access or open it. */
1268 if (NATNUMP (predicate
))
1269 fd
= (access (pfn
, XFASTINT (predicate
)) == 0) ? 1 : -1;
1271 fd
= emacs_open (pfn
, O_RDONLY
, 0);
1275 /* We succeeded; return this descriptor and filename. */
1293 /* Merge the list we've accumulated of globals from the current input source
1294 into the load_history variable. The details depend on whether
1295 the source has an associated file name or not.
1297 FILENAME is the file name that we are loading from.
1298 ENTIRE is 1 if loading that entire file, 0 if evaluating part of it. */
1301 build_load_history (filename
, entire
)
1302 Lisp_Object filename
;
1305 register Lisp_Object tail
, prev
, newelt
;
1306 register Lisp_Object tem
, tem2
;
1307 register int foundit
= 0;
1309 tail
= Vload_history
;
1312 while (CONSP (tail
))
1316 /* Find the feature's previous assoc list... */
1317 if (!NILP (Fequal (filename
, Fcar (tem
))))
1321 /* If we're loading the entire file, remove old data. */
1325 Vload_history
= XCDR (tail
);
1327 Fsetcdr (prev
, XCDR (tail
));
1330 /* Otherwise, cons on new symbols that are not already members. */
1333 tem2
= Vcurrent_load_list
;
1335 while (CONSP (tem2
))
1337 newelt
= XCAR (tem2
);
1339 if (NILP (Fmember (newelt
, tem
)))
1340 Fsetcar (tail
, Fcons (XCAR (tem
),
1341 Fcons (newelt
, XCDR (tem
))));
1354 /* If we're loading an entire file, cons the new assoc onto the
1355 front of load-history, the most-recently-loaded position. Also
1356 do this if we didn't find an existing member for the file. */
1357 if (entire
|| !foundit
)
1358 Vload_history
= Fcons (Fnreverse (Vcurrent_load_list
),
1363 unreadpure (junk
) /* Used as unwind-protect function in readevalloop */
1371 readevalloop_1 (old
)
1374 load_convert_to_unibyte
= ! NILP (old
);
1378 /* Signal an `end-of-file' error, if possible with file name
1382 end_of_file_error ()
1386 if (STRINGP (Vload_file_name
))
1387 xsignal1 (Qend_of_file
, Vload_file_name
);
1389 xsignal0 (Qend_of_file
);
1392 /* UNIBYTE specifies how to set load_convert_to_unibyte
1393 for this invocation.
1394 READFUN, if non-nil, is used instead of `read'.
1396 START, END specify region to read in current buffer (from eval-region).
1397 If the input is not from a buffer, they must be nil. */
1400 readevalloop (readcharfun
, stream
, sourcename
, evalfun
,
1401 printflag
, unibyte
, readfun
, start
, end
)
1402 Lisp_Object readcharfun
;
1404 Lisp_Object sourcename
;
1405 Lisp_Object (*evalfun
) ();
1407 Lisp_Object unibyte
, readfun
;
1408 Lisp_Object start
, end
;
1411 register Lisp_Object val
;
1412 int count
= SPECPDL_INDEX ();
1413 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1414 struct buffer
*b
= 0;
1415 int continue_reading_p
;
1416 /* Nonzero if reading an entire buffer. */
1417 int whole_buffer
= 0;
1418 /* 1 on the first time around. */
1421 if (MARKERP (readcharfun
))
1424 start
= readcharfun
;
1427 if (BUFFERP (readcharfun
))
1428 b
= XBUFFER (readcharfun
);
1429 else if (MARKERP (readcharfun
))
1430 b
= XMARKER (readcharfun
)->buffer
;
1432 /* We assume START is nil when input is not from a buffer. */
1433 if (! NILP (start
) && !b
)
1436 specbind (Qstandard_input
, readcharfun
); /* GCPROs readcharfun. */
1437 specbind (Qcurrent_load_list
, Qnil
);
1438 record_unwind_protect (readevalloop_1
, load_convert_to_unibyte
? Qt
: Qnil
);
1439 load_convert_to_unibyte
= !NILP (unibyte
);
1441 readchar_backlog
= -1;
1443 GCPRO4 (sourcename
, readfun
, start
, end
);
1445 /* Try to ensure sourcename is a truename, except whilst preloading. */
1446 if (NILP (Vpurify_flag
)
1447 && !NILP (sourcename
) && !NILP (Ffile_name_absolute_p (sourcename
))
1448 && !NILP (Ffboundp (Qfile_truename
)))
1449 sourcename
= call1 (Qfile_truename
, sourcename
) ;
1451 LOADHIST_ATTACH (sourcename
);
1453 continue_reading_p
= 1;
1454 while (continue_reading_p
)
1456 int count1
= SPECPDL_INDEX ();
1458 if (b
!= 0 && NILP (b
->name
))
1459 error ("Reading from killed buffer");
1463 /* Switch to the buffer we are reading from. */
1464 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
1465 set_buffer_internal (b
);
1467 /* Save point in it. */
1468 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
1469 /* Save ZV in it. */
1470 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
1471 /* Those get unbound after we read one expression. */
1473 /* Set point and ZV around stuff to be read. */
1476 Fnarrow_to_region (make_number (BEGV
), end
);
1478 /* Just for cleanliness, convert END to a marker
1479 if it is an integer. */
1481 end
= Fpoint_max_marker ();
1484 /* On the first cycle, we can easily test here
1485 whether we are reading the whole buffer. */
1486 if (b
&& first_sexp
)
1487 whole_buffer
= (PT
== BEG
&& ZV
== Z
);
1494 while ((c
= READCHAR
) != '\n' && c
!= -1);
1499 unbind_to (count1
, Qnil
);
1503 /* Ignore whitespace here, so we can detect eof. */
1504 if (c
== ' ' || c
== '\t' || c
== '\n' || c
== '\f' || c
== '\r'
1505 || c
== 0x8a0) /* NBSP */
1508 if (!NILP (Vpurify_flag
) && c
== '(')
1510 record_unwind_protect (unreadpure
, Qnil
);
1511 val
= read_list (-1, readcharfun
);
1516 read_objects
= Qnil
;
1517 if (!NILP (readfun
))
1519 val
= call1 (readfun
, readcharfun
);
1521 /* If READCHARFUN has set point to ZV, we should
1522 stop reading, even if the form read sets point
1523 to a different value when evaluated. */
1524 if (BUFFERP (readcharfun
))
1526 struct buffer
*b
= XBUFFER (readcharfun
);
1527 if (BUF_PT (b
) == BUF_ZV (b
))
1528 continue_reading_p
= 0;
1531 else if (! NILP (Vload_read_function
))
1532 val
= call1 (Vload_read_function
, readcharfun
);
1534 val
= read_internal_start (readcharfun
, Qnil
, Qnil
);
1537 if (!NILP (start
) && continue_reading_p
)
1538 start
= Fpoint_marker ();
1540 /* Restore saved point and BEGV. */
1541 unbind_to (count1
, Qnil
);
1543 /* Now eval what we just read. */
1544 val
= (*evalfun
) (val
);
1548 Vvalues
= Fcons (val
, Vvalues
);
1549 if (EQ (Vstandard_output
, Qt
))
1558 build_load_history (sourcename
,
1559 stream
|| whole_buffer
);
1563 unbind_to (count
, Qnil
);
1566 DEFUN ("eval-buffer", Feval_buffer
, Seval_buffer
, 0, 5, "",
1567 doc
: /* Execute the current buffer as Lisp code.
1568 Programs can pass two arguments, BUFFER and PRINTFLAG.
1569 BUFFER is the buffer to evaluate (nil means use current buffer).
1570 PRINTFLAG controls printing of output:
1571 A value of nil means discard it; anything else is stream for print.
1573 If the optional third argument FILENAME is non-nil,
1574 it specifies the file name to use for `load-history'.
1575 The optional fourth argument UNIBYTE specifies `load-convert-to-unibyte'
1576 for this invocation.
1578 The optional fifth argument DO-ALLOW-PRINT, if non-nil, specifies that
1579 `print' and related functions should work normally even if PRINTFLAG is nil.
1581 This function preserves the position of point. */)
1582 (buffer
, printflag
, filename
, unibyte
, do_allow_print
)
1583 Lisp_Object buffer
, printflag
, filename
, unibyte
, do_allow_print
;
1585 int count
= SPECPDL_INDEX ();
1586 Lisp_Object tem
, buf
;
1589 buf
= Fcurrent_buffer ();
1591 buf
= Fget_buffer (buffer
);
1593 error ("No such buffer");
1595 if (NILP (printflag
) && NILP (do_allow_print
))
1600 if (NILP (filename
))
1601 filename
= XBUFFER (buf
)->filename
;
1603 specbind (Qeval_buffer_list
, Fcons (buf
, Veval_buffer_list
));
1604 specbind (Qstandard_output
, tem
);
1605 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
1606 BUF_SET_PT (XBUFFER (buf
), BUF_BEGV (XBUFFER (buf
)));
1607 readevalloop (buf
, 0, filename
, Feval
,
1608 !NILP (printflag
), unibyte
, Qnil
, Qnil
, Qnil
);
1609 unbind_to (count
, Qnil
);
1614 DEFUN ("eval-region", Feval_region
, Seval_region
, 2, 4, "r",
1615 doc
: /* Execute the region as Lisp code.
1616 When called from programs, expects two arguments,
1617 giving starting and ending indices in the current buffer
1618 of the text to be executed.
1619 Programs can pass third argument PRINTFLAG which controls output:
1620 A value of nil means discard it; anything else is stream for printing it.
1621 Also the fourth argument READ-FUNCTION, if non-nil, is used
1622 instead of `read' to read each expression. It gets one argument
1623 which is the input stream for reading characters.
1625 This function does not move point. */)
1626 (start
, end
, printflag
, read_function
)
1627 Lisp_Object start
, end
, printflag
, read_function
;
1629 int count
= SPECPDL_INDEX ();
1630 Lisp_Object tem
, cbuf
;
1632 cbuf
= Fcurrent_buffer ();
1634 if (NILP (printflag
))
1638 specbind (Qstandard_output
, tem
);
1639 specbind (Qeval_buffer_list
, Fcons (cbuf
, Veval_buffer_list
));
1641 /* readevalloop calls functions which check the type of start and end. */
1642 readevalloop (cbuf
, 0, XBUFFER (cbuf
)->filename
, Feval
,
1643 !NILP (printflag
), Qnil
, read_function
,
1646 return unbind_to (count
, Qnil
);
1650 DEFUN ("read", Fread
, Sread
, 0, 1, 0,
1651 doc
: /* Read one Lisp expression as text from STREAM, return as Lisp object.
1652 If STREAM is nil, use the value of `standard-input' (which see).
1653 STREAM or the value of `standard-input' may be:
1654 a buffer (read from point and advance it)
1655 a marker (read from where it points and advance it)
1656 a function (call it with no arguments for each character,
1657 call it with a char as argument to push a char back)
1658 a string (takes text from string, starting at the beginning)
1659 t (read text line using minibuffer and use it, or read from
1660 standard input in batch mode). */)
1665 stream
= Vstandard_input
;
1666 if (EQ (stream
, Qt
))
1667 stream
= Qread_char
;
1668 if (EQ (stream
, Qread_char
))
1669 return Fread_minibuffer (build_string ("Lisp expression: "), Qnil
);
1671 return read_internal_start (stream
, Qnil
, Qnil
);
1674 DEFUN ("read-from-string", Fread_from_string
, Sread_from_string
, 1, 3, 0,
1675 doc
: /* Read one Lisp expression which is represented as text by STRING.
1676 Returns a cons: (OBJECT-READ . FINAL-STRING-INDEX).
1677 START and END optionally delimit a substring of STRING from which to read;
1678 they default to 0 and (length STRING) respectively. */)
1679 (string
, start
, end
)
1680 Lisp_Object string
, start
, end
;
1683 CHECK_STRING (string
);
1684 /* read_internal_start sets read_from_string_index. */
1685 ret
= read_internal_start (string
, start
, end
);
1686 return Fcons (ret
, make_number (read_from_string_index
));
1689 /* Function to set up the global context we need in toplevel read
1692 read_internal_start (stream
, start
, end
)
1694 Lisp_Object start
; /* Only used when stream is a string. */
1695 Lisp_Object end
; /* Only used when stream is a string. */
1699 readchar_backlog
= -1;
1701 new_backquote_flag
= 0;
1702 read_objects
= Qnil
;
1703 if (EQ (Vread_with_symbol_positions
, Qt
)
1704 || EQ (Vread_with_symbol_positions
, stream
))
1705 Vread_symbol_positions_list
= Qnil
;
1707 if (STRINGP (stream
))
1709 int startval
, endval
;
1711 endval
= SCHARS (stream
);
1715 endval
= XINT (end
);
1716 if (endval
< 0 || endval
> SCHARS (stream
))
1717 args_out_of_range (stream
, end
);
1724 CHECK_NUMBER (start
);
1725 startval
= XINT (start
);
1726 if (startval
< 0 || startval
> endval
)
1727 args_out_of_range (stream
, start
);
1729 read_from_string_index
= startval
;
1730 read_from_string_index_byte
= string_char_to_byte (stream
, startval
);
1731 read_from_string_limit
= endval
;
1734 retval
= read0 (stream
);
1735 if (EQ (Vread_with_symbol_positions
, Qt
)
1736 || EQ (Vread_with_symbol_positions
, stream
))
1737 Vread_symbol_positions_list
= Fnreverse (Vread_symbol_positions_list
);
1742 /* Signal Qinvalid_read_syntax error.
1743 S is error string of length N (if > 0) */
1746 invalid_syntax (s
, n
)
1752 xsignal1 (Qinvalid_read_syntax
, make_string (s
, n
));
1756 /* Use this for recursive reads, in contexts where internal tokens
1761 Lisp_Object readcharfun
;
1763 register Lisp_Object val
;
1766 val
= read1 (readcharfun
, &c
, 0);
1770 xsignal1 (Qinvalid_read_syntax
,
1771 Fmake_string (make_number (1), make_number (c
)));
1774 static int read_buffer_size
;
1775 static char *read_buffer
;
1777 /* Read multibyte form and return it as a character. C is a first
1778 byte of multibyte form, and rest of them are read from
1782 read_multibyte (c
, readcharfun
)
1784 Lisp_Object readcharfun
;
1786 /* We need the actual character code of this multibyte
1788 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
1796 while ((c
= READCHAR
) >= 0xA0
1797 && len
< MAX_MULTIBYTE_LENGTH
)
1803 if (UNIBYTE_STR_AS_MULTIBYTE_P (str
, len
, bytes
))
1804 return STRING_CHAR (str
, len
);
1805 /* The byte sequence is not valid as multibyte. Unread all bytes
1806 but the first one, and return the first byte. */
1812 /* Read a \-escape sequence, assuming we already read the `\'.
1813 If the escape sequence forces unibyte, store 1 into *BYTEREP.
1814 If the escape sequence forces multibyte, store 2 into *BYTEREP.
1815 Otherwise store 0 into *BYTEREP. */
1818 read_escape (readcharfun
, stringp
, byterep
)
1819 Lisp_Object readcharfun
;
1823 register int c
= READCHAR
;
1824 /* \u allows up to four hex digits, \U up to eight. Default to the
1825 behaviour for \u, and change this value in the case that \U is seen. */
1826 int unicode_hex_count
= 4;
1833 end_of_file_error ();
1863 error ("Invalid escape character syntax");
1866 c
= read_escape (readcharfun
, 0, byterep
);
1867 return c
| meta_modifier
;
1872 error ("Invalid escape character syntax");
1875 c
= read_escape (readcharfun
, 0, byterep
);
1876 return c
| shift_modifier
;
1881 error ("Invalid escape character syntax");
1884 c
= read_escape (readcharfun
, 0, byterep
);
1885 return c
| hyper_modifier
;
1890 error ("Invalid escape character syntax");
1893 c
= read_escape (readcharfun
, 0, byterep
);
1894 return c
| alt_modifier
;
1898 if (stringp
|| c
!= '-')
1905 c
= read_escape (readcharfun
, 0, byterep
);
1906 return c
| super_modifier
;
1911 error ("Invalid escape character syntax");
1915 c
= read_escape (readcharfun
, 0, byterep
);
1916 if ((c
& ~CHAR_MODIFIER_MASK
) == '?')
1917 return 0177 | (c
& CHAR_MODIFIER_MASK
);
1918 else if (! SINGLE_BYTE_CHAR_P ((c
& ~CHAR_MODIFIER_MASK
)))
1919 return c
| ctrl_modifier
;
1920 /* ASCII control chars are made from letters (both cases),
1921 as well as the non-letters within 0100...0137. */
1922 else if ((c
& 0137) >= 0101 && (c
& 0137) <= 0132)
1923 return (c
& (037 | ~0177));
1924 else if ((c
& 0177) >= 0100 && (c
& 0177) <= 0137)
1925 return (c
& (037 | ~0177));
1927 return c
| ctrl_modifier
;
1937 /* An octal escape, as in ANSI C. */
1939 register int i
= c
- '0';
1940 register int count
= 0;
1943 if ((c
= READCHAR
) >= '0' && c
<= '7')
1960 /* A hex escape, as in ANSI C. */
1966 if (c
>= '0' && c
<= '9')
1971 else if ((c
>= 'a' && c
<= 'f')
1972 || (c
>= 'A' && c
<= 'F'))
1975 if (c
>= 'a' && c
<= 'f')
1992 /* Post-Unicode-2.0: Up to eight hex chars. */
1993 unicode_hex_count
= 8;
1996 /* A Unicode escape. We only permit them in strings and characters,
1997 not arbitrarily in the source code, as in some other languages. */
2001 Lisp_Object lisp_char
;
2002 struct gcpro gcpro1
;
2004 while (++count
<= unicode_hex_count
)
2007 /* isdigit and isalpha may be locale-specific, which we don't
2009 if (c
>= '0' && c
<= '9') i
= (i
<< 4) + (c
- '0');
2010 else if (c
>= 'a' && c
<= 'f') i
= (i
<< 4) + (c
- 'a') + 10;
2011 else if (c
>= 'A' && c
<= 'F') i
= (i
<< 4) + (c
- 'A') + 10;
2014 error ("Non-hex digit used for Unicode escape");
2019 GCPRO1 (readcharfun
);
2020 lisp_char
= call2 (intern ("decode-char"), intern ("ucs"),
2024 if (NILP (lisp_char
))
2026 error ("Unsupported Unicode code point: U+%x", (unsigned)i
);
2029 return XFASTINT (lisp_char
);
2033 if (BASE_LEADING_CODE_P (c
))
2034 c
= read_multibyte (c
, readcharfun
);
2039 /* Read an integer in radix RADIX using READCHARFUN to read
2040 characters. RADIX must be in the interval [2..36]; if it isn't, a
2041 read error is signaled . Value is the integer read. Signals an
2042 error if encountering invalid read syntax or if RADIX is out of
2046 read_integer (readcharfun
, radix
)
2047 Lisp_Object readcharfun
;
2050 int ndigits
= 0, invalid_p
, c
, sign
= 0;
2051 EMACS_INT number
= 0;
2053 if (radix
< 2 || radix
> 36)
2057 number
= ndigits
= invalid_p
= 0;
2073 if (c
>= '0' && c
<= '9')
2075 else if (c
>= 'a' && c
<= 'z')
2076 digit
= c
- 'a' + 10;
2077 else if (c
>= 'A' && c
<= 'Z')
2078 digit
= c
- 'A' + 10;
2085 if (digit
< 0 || digit
>= radix
)
2088 number
= radix
* number
+ digit
;
2094 if (ndigits
== 0 || invalid_p
)
2097 sprintf (buf
, "integer, radix %d", radix
);
2098 invalid_syntax (buf
, 0);
2101 return make_number (sign
* number
);
2105 /* Convert unibyte text in read_buffer to multibyte.
2107 Initially, *P is a pointer after the end of the unibyte text, and
2108 the pointer *END points after the end of read_buffer.
2110 If read_buffer doesn't have enough room to hold the result
2111 of the conversion, reallocate it and adjust *P and *END.
2113 At the end, make *P point after the result of the conversion, and
2114 return in *NCHARS the number of characters in the converted
2118 to_multibyte (p
, end
, nchars
)
2124 parse_str_as_multibyte (read_buffer
, *p
- read_buffer
, &nbytes
, nchars
);
2125 if (read_buffer_size
< 2 * nbytes
)
2127 int offset
= *p
- read_buffer
;
2128 read_buffer_size
= 2 * max (read_buffer_size
, nbytes
);
2129 read_buffer
= (char *) xrealloc (read_buffer
, read_buffer_size
);
2130 *p
= read_buffer
+ offset
;
2131 *end
= read_buffer
+ read_buffer_size
;
2134 if (nbytes
!= *nchars
)
2135 nbytes
= str_as_multibyte (read_buffer
, read_buffer_size
,
2136 *p
- read_buffer
, nchars
);
2138 *p
= read_buffer
+ nbytes
;
2142 /* If the next token is ')' or ']' or '.', we store that character
2143 in *PCH and the return value is not interesting. Else, we store
2144 zero in *PCH and we read and return one lisp object.
2146 FIRST_IN_LIST is nonzero if this is the first element of a list. */
2149 read1 (readcharfun
, pch
, first_in_list
)
2150 register Lisp_Object readcharfun
;
2155 int uninterned_symbol
= 0;
2163 end_of_file_error ();
2168 return read_list (0, readcharfun
);
2171 return read_vector (readcharfun
, 0);
2188 tmp
= read_vector (readcharfun
, 0);
2189 if (XVECTOR (tmp
)->size
< CHAR_TABLE_STANDARD_SLOTS
2190 || XVECTOR (tmp
)->size
> CHAR_TABLE_STANDARD_SLOTS
+ 10)
2191 error ("Invalid size char-table");
2192 XSETCHAR_TABLE (tmp
, XCHAR_TABLE (tmp
));
2193 XCHAR_TABLE (tmp
)->top
= Qt
;
2202 tmp
= read_vector (readcharfun
, 0);
2203 if (XVECTOR (tmp
)->size
!= SUB_CHAR_TABLE_STANDARD_SLOTS
)
2204 error ("Invalid size char-table");
2205 XSETCHAR_TABLE (tmp
, XCHAR_TABLE (tmp
));
2206 XCHAR_TABLE (tmp
)->top
= Qnil
;
2209 invalid_syntax ("#^^", 3);
2211 invalid_syntax ("#^", 2);
2216 length
= read1 (readcharfun
, pch
, first_in_list
);
2220 Lisp_Object tmp
, val
;
2222 = ((XFASTINT (length
) + BOOL_VECTOR_BITS_PER_CHAR
- 1)
2223 / BOOL_VECTOR_BITS_PER_CHAR
);
2226 tmp
= read1 (readcharfun
, pch
, first_in_list
);
2227 if (size_in_chars
!= SCHARS (tmp
)
2228 /* We used to print 1 char too many
2229 when the number of bits was a multiple of 8.
2230 Accept such input in case it came from an old version. */
2231 && ! (XFASTINT (length
)
2232 == (SCHARS (tmp
) - 1) * BOOL_VECTOR_BITS_PER_CHAR
))
2233 invalid_syntax ("#&...", 5);
2235 val
= Fmake_bool_vector (length
, Qnil
);
2236 bcopy (SDATA (tmp
), XBOOL_VECTOR (val
)->data
,
2238 /* Clear the extraneous bits in the last byte. */
2239 if (XINT (length
) != size_in_chars
* BOOL_VECTOR_BITS_PER_CHAR
)
2240 XBOOL_VECTOR (val
)->data
[size_in_chars
- 1]
2241 &= (1 << (XINT (length
) % BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2244 invalid_syntax ("#&...", 5);
2248 /* Accept compiled functions at read-time so that we don't have to
2249 build them using function calls. */
2251 tmp
= read_vector (readcharfun
, 1);
2252 return Fmake_byte_code (XVECTOR (tmp
)->size
,
2253 XVECTOR (tmp
)->contents
);
2258 struct gcpro gcpro1
;
2261 /* Read the string itself. */
2262 tmp
= read1 (readcharfun
, &ch
, 0);
2263 if (ch
!= 0 || !STRINGP (tmp
))
2264 invalid_syntax ("#", 1);
2266 /* Read the intervals and their properties. */
2269 Lisp_Object beg
, end
, plist
;
2271 beg
= read1 (readcharfun
, &ch
, 0);
2276 end
= read1 (readcharfun
, &ch
, 0);
2278 plist
= read1 (readcharfun
, &ch
, 0);
2280 invalid_syntax ("Invalid string property list", 0);
2281 Fset_text_properties (beg
, end
, plist
, tmp
);
2287 /* #@NUMBER is used to skip NUMBER following characters.
2288 That's used in .elc files to skip over doc strings
2289 and function definitions. */
2294 /* Read a decimal integer. */
2295 while ((c
= READCHAR
) >= 0
2296 && c
>= '0' && c
<= '9')
2304 if (load_force_doc_strings
&& EQ (readcharfun
, Qget_file_char
))
2306 /* If we are supposed to force doc strings into core right now,
2307 record the last string that we skipped,
2308 and record where in the file it comes from. */
2310 /* But first exchange saved_doc_string
2311 with prev_saved_doc_string, so we save two strings. */
2313 char *temp
= saved_doc_string
;
2314 int temp_size
= saved_doc_string_size
;
2315 file_offset temp_pos
= saved_doc_string_position
;
2316 int temp_len
= saved_doc_string_length
;
2318 saved_doc_string
= prev_saved_doc_string
;
2319 saved_doc_string_size
= prev_saved_doc_string_size
;
2320 saved_doc_string_position
= prev_saved_doc_string_position
;
2321 saved_doc_string_length
= prev_saved_doc_string_length
;
2323 prev_saved_doc_string
= temp
;
2324 prev_saved_doc_string_size
= temp_size
;
2325 prev_saved_doc_string_position
= temp_pos
;
2326 prev_saved_doc_string_length
= temp_len
;
2329 if (saved_doc_string_size
== 0)
2331 saved_doc_string_size
= nskip
+ 100;
2332 saved_doc_string
= (char *) xmalloc (saved_doc_string_size
);
2334 if (nskip
> saved_doc_string_size
)
2336 saved_doc_string_size
= nskip
+ 100;
2337 saved_doc_string
= (char *) xrealloc (saved_doc_string
,
2338 saved_doc_string_size
);
2341 saved_doc_string_position
= file_tell (instream
);
2343 /* Copy that many characters into saved_doc_string. */
2344 for (i
= 0; i
< nskip
&& c
>= 0; i
++)
2345 saved_doc_string
[i
] = c
= READCHAR
;
2347 saved_doc_string_length
= i
;
2351 /* Skip that many characters. */
2352 for (i
= 0; i
< nskip
&& c
>= 0; i
++)
2360 /* #! appears at the beginning of an executable file.
2361 Skip the first line. */
2362 while (c
!= '\n' && c
>= 0)
2367 return Vload_file_name
;
2369 return Fcons (Qfunction
, Fcons (read0 (readcharfun
), Qnil
));
2370 /* #:foo is the uninterned symbol named foo. */
2373 uninterned_symbol
= 1;
2377 /* Reader forms that can reuse previously read objects. */
2378 if (c
>= '0' && c
<= '9')
2383 /* Read a non-negative integer. */
2384 while (c
>= '0' && c
<= '9')
2390 /* #n=object returns object, but associates it with n for #n#. */
2393 /* Make a placeholder for #n# to use temporarily */
2394 Lisp_Object placeholder
;
2397 placeholder
= Fcons(Qnil
, Qnil
);
2398 cell
= Fcons (make_number (n
), placeholder
);
2399 read_objects
= Fcons (cell
, read_objects
);
2401 /* Read the object itself. */
2402 tem
= read0 (readcharfun
);
2404 /* Now put it everywhere the placeholder was... */
2405 substitute_object_in_subtree (tem
, placeholder
);
2407 /* ...and #n# will use the real value from now on. */
2408 Fsetcdr (cell
, tem
);
2412 /* #n# returns a previously read object. */
2415 tem
= Fassq (make_number (n
), read_objects
);
2418 /* Fall through to error message. */
2420 else if (c
== 'r' || c
== 'R')
2421 return read_integer (readcharfun
, n
);
2423 /* Fall through to error message. */
2425 else if (c
== 'x' || c
== 'X')
2426 return read_integer (readcharfun
, 16);
2427 else if (c
== 'o' || c
== 'O')
2428 return read_integer (readcharfun
, 8);
2429 else if (c
== 'b' || c
== 'B')
2430 return read_integer (readcharfun
, 2);
2433 invalid_syntax ("#", 1);
2436 while ((c
= READCHAR
) >= 0 && c
!= '\n');
2441 return Fcons (Qquote
, Fcons (read0 (readcharfun
), Qnil
));
2451 new_backquote_flag
++;
2452 value
= read0 (readcharfun
);
2453 new_backquote_flag
--;
2455 return Fcons (Qbackquote
, Fcons (value
, Qnil
));
2459 if (new_backquote_flag
)
2461 Lisp_Object comma_type
= Qnil
;
2466 comma_type
= Qcomma_at
;
2468 comma_type
= Qcomma_dot
;
2471 if (ch
>= 0) UNREAD (ch
);
2472 comma_type
= Qcomma
;
2475 new_backquote_flag
--;
2476 value
= read0 (readcharfun
);
2477 new_backquote_flag
++;
2478 return Fcons (comma_type
, Fcons (value
, Qnil
));
2491 end_of_file_error ();
2493 /* Accept `single space' syntax like (list ? x) where the
2494 whitespace character is SPC or TAB.
2495 Other literal whitespace like NL, CR, and FF are not accepted,
2496 as there are well-established escape sequences for these. */
2497 if (c
== ' ' || c
== '\t')
2498 return make_number (c
);
2501 c
= read_escape (readcharfun
, 0, &discard
);
2502 else if (BASE_LEADING_CODE_P (c
))
2503 c
= read_multibyte (c
, readcharfun
);
2505 next_char
= READCHAR
;
2506 if (next_char
== '.')
2508 /* Only a dotted-pair dot is valid after a char constant. */
2509 int next_next_char
= READCHAR
;
2510 UNREAD (next_next_char
);
2512 ok
= (next_next_char
<= 040
2513 || (next_next_char
< 0200
2514 && (index ("\"';([#?", next_next_char
)
2515 || (!first_in_list
&& next_next_char
== '`')
2516 || (new_backquote_flag
&& next_next_char
== ','))));
2520 ok
= (next_char
<= 040
2521 || (next_char
< 0200
2522 && (index ("\"';()[]#?", next_char
)
2523 || (!first_in_list
&& next_char
== '`')
2524 || (new_backquote_flag
&& next_char
== ','))));
2528 return make_number (c
);
2530 invalid_syntax ("?", 1);
2535 char *p
= read_buffer
;
2536 char *end
= read_buffer
+ read_buffer_size
;
2538 /* 1 if we saw an escape sequence specifying
2539 a multibyte character, or a multibyte character. */
2540 int force_multibyte
= 0;
2541 /* 1 if we saw an escape sequence specifying
2542 a single-byte character. */
2543 int force_singlebyte
= 0;
2544 /* 1 if read_buffer contains multibyte text now. */
2545 int is_multibyte
= 0;
2549 while ((c
= READCHAR
) >= 0
2552 if (end
- p
< MAX_MULTIBYTE_LENGTH
)
2554 int offset
= p
- read_buffer
;
2555 read_buffer
= (char *) xrealloc (read_buffer
,
2556 read_buffer_size
*= 2);
2557 p
= read_buffer
+ offset
;
2558 end
= read_buffer
+ read_buffer_size
;
2565 c
= read_escape (readcharfun
, 1, &byterep
);
2567 /* C is -1 if \ newline has just been seen */
2570 if (p
== read_buffer
)
2576 force_singlebyte
= 1;
2577 else if (byterep
== 2)
2578 force_multibyte
= 1;
2581 /* A character that must be multibyte forces multibyte. */
2582 if (! SINGLE_BYTE_CHAR_P (c
& ~CHAR_MODIFIER_MASK
))
2583 force_multibyte
= 1;
2585 /* If we just discovered the need to be multibyte,
2586 convert the text accumulated thus far. */
2587 if (force_multibyte
&& ! is_multibyte
)
2590 to_multibyte (&p
, &end
, &nchars
);
2593 /* Allow `\C- ' and `\C-?'. */
2594 if (c
== (CHAR_CTL
| ' '))
2596 else if (c
== (CHAR_CTL
| '?'))
2601 /* Shift modifier is valid only with [A-Za-z]. */
2602 if ((c
& 0377) >= 'A' && (c
& 0377) <= 'Z')
2604 else if ((c
& 0377) >= 'a' && (c
& 0377) <= 'z')
2605 c
= (c
& ~CHAR_SHIFT
) - ('a' - 'A');
2609 /* Move the meta bit to the right place for a string. */
2610 c
= (c
& ~CHAR_META
) | 0x80;
2611 if (c
& CHAR_MODIFIER_MASK
)
2612 error ("Invalid modifier in string");
2615 p
+= CHAR_STRING (c
, p
);
2623 end_of_file_error ();
2625 /* If purifying, and string starts with \ newline,
2626 return zero instead. This is for doc strings
2627 that we are really going to find in etc/DOC.nn.nn */
2628 if (!NILP (Vpurify_flag
) && NILP (Vdoc_file_name
) && cancel
)
2629 return make_number (0);
2631 if (is_multibyte
|| force_singlebyte
)
2633 else if (load_convert_to_unibyte
)
2636 to_multibyte (&p
, &end
, &nchars
);
2637 if (p
- read_buffer
!= nchars
)
2639 string
= make_multibyte_string (read_buffer
, nchars
,
2641 return Fstring_make_unibyte (string
);
2643 /* We can make a unibyte string directly. */
2646 else if (EQ (readcharfun
, Qget_file_char
)
2647 || EQ (readcharfun
, Qlambda
))
2649 /* Nowadays, reading directly from a file is used only for
2650 compiled Emacs Lisp files, and those always use the
2651 Emacs internal encoding. Meanwhile, Qlambda is used
2652 for reading dynamic byte code (compiled with
2653 byte-compile-dynamic = t). So make the string multibyte
2654 if the string contains any multibyte sequences.
2655 (to_multibyte is a no-op if not.) */
2656 to_multibyte (&p
, &end
, &nchars
);
2657 is_multibyte
= (p
- read_buffer
) != nchars
;
2660 /* In all other cases, if we read these bytes as
2661 separate characters, treat them as separate characters now. */
2664 /* We want readchar_count to be the number of characters, not
2665 bytes. Hence we adjust for multibyte characters in the
2666 string. ... But it doesn't seem to be necessary, because
2667 READCHAR *does* read multibyte characters from buffers. */
2668 /* readchar_count -= (p - read_buffer) - nchars; */
2670 return make_pure_string (read_buffer
, nchars
, p
- read_buffer
,
2672 return make_specified_string (read_buffer
, nchars
, p
- read_buffer
,
2678 int next_char
= READCHAR
;
2681 if (next_char
<= 040
2682 || (next_char
< 0200
2683 && (index ("\"';([#?", next_char
)
2684 || (!first_in_list
&& next_char
== '`')
2685 || (new_backquote_flag
&& next_char
== ','))))
2691 /* Otherwise, we fall through! Note that the atom-reading loop
2692 below will now loop at least once, assuring that we will not
2693 try to UNREAD two characters in a row. */
2697 if (c
<= 040) goto retry
;
2698 if (c
== 0x8a0) /* NBSP */
2701 char *p
= read_buffer
;
2705 char *end
= read_buffer
+ read_buffer_size
;
2708 && c
!= 0x8a0 /* NBSP */
2710 || (!index ("\"';()[]#", c
)
2711 && !(!first_in_list
&& c
== '`')
2712 && !(new_backquote_flag
&& c
== ','))))
2714 if (end
- p
< MAX_MULTIBYTE_LENGTH
)
2716 int offset
= p
- read_buffer
;
2717 read_buffer
= (char *) xrealloc (read_buffer
,
2718 read_buffer_size
*= 2);
2719 p
= read_buffer
+ offset
;
2720 end
= read_buffer
+ read_buffer_size
;
2727 end_of_file_error ();
2731 if (! SINGLE_BYTE_CHAR_P (c
))
2732 p
+= CHAR_STRING (c
, p
);
2741 int offset
= p
- read_buffer
;
2742 read_buffer
= (char *) xrealloc (read_buffer
,
2743 read_buffer_size
*= 2);
2744 p
= read_buffer
+ offset
;
2745 end
= read_buffer
+ read_buffer_size
;
2752 if (!quoted
&& !uninterned_symbol
)
2755 register Lisp_Object val
;
2757 if (*p1
== '+' || *p1
== '-') p1
++;
2758 /* Is it an integer? */
2761 while (p1
!= p
&& (c
= *p1
) >= '0' && c
<= '9') p1
++;
2762 /* Integers can have trailing decimal points. */
2763 if (p1
> read_buffer
&& p1
< p
&& *p1
== '.') p1
++;
2765 /* It is an integer. */
2769 if (sizeof (int) == sizeof (EMACS_INT
))
2770 XSETINT (val
, atoi (read_buffer
));
2771 else if (sizeof (long) == sizeof (EMACS_INT
))
2772 XSETINT (val
, atol (read_buffer
));
2778 if (isfloat_string (read_buffer
))
2780 /* Compute NaN and infinities using 0.0 in a variable,
2781 to cope with compilers that think they are smarter
2787 /* Negate the value ourselves. This treats 0, NaNs,
2788 and infinity properly on IEEE floating point hosts,
2789 and works around a common bug where atof ("-0.0")
2791 int negative
= read_buffer
[0] == '-';
2793 /* The only way p[-1] can be 'F' or 'N', after isfloat_string
2794 returns 1, is if the input ends in e+INF or e+NaN. */
2801 value
= zero
/ zero
;
2803 /* If that made a "negative" NaN, negate it. */
2807 union { double d
; char c
[sizeof (double)]; } u_data
, u_minus_zero
;
2810 u_minus_zero
.d
= - 0.0;
2811 for (i
= 0; i
< sizeof (double); i
++)
2812 if (u_data
.c
[i
] & u_minus_zero
.c
[i
])
2818 /* Now VALUE is a positive NaN. */
2821 value
= atof (read_buffer
+ negative
);
2825 return make_float (negative
? - value
: value
);
2829 Lisp_Object result
= uninterned_symbol
? make_symbol (read_buffer
)
2830 : intern (read_buffer
);
2831 if (EQ (Vread_with_symbol_positions
, Qt
)
2832 || EQ (Vread_with_symbol_positions
, readcharfun
))
2833 Vread_symbol_positions_list
=
2834 /* Kind of a hack; this will probably fail if characters
2835 in the symbol name were escaped. Not really a big
2837 Fcons (Fcons (result
,
2838 make_number (readchar_count
2839 - XFASTINT (Flength (Fsymbol_name (result
))))),
2840 Vread_symbol_positions_list
);
2848 /* List of nodes we've seen during substitute_object_in_subtree. */
2849 static Lisp_Object seen_list
;
2852 substitute_object_in_subtree (object
, placeholder
)
2854 Lisp_Object placeholder
;
2856 Lisp_Object check_object
;
2858 /* We haven't seen any objects when we start. */
2861 /* Make all the substitutions. */
2863 = substitute_object_recurse (object
, placeholder
, object
);
2865 /* Clear seen_list because we're done with it. */
2868 /* The returned object here is expected to always eq the
2870 if (!EQ (check_object
, object
))
2871 error ("Unexpected mutation error in reader");
2874 /* Feval doesn't get called from here, so no gc protection is needed. */
2875 #define SUBSTITUTE(get_val, set_val) \
2877 Lisp_Object old_value = get_val; \
2878 Lisp_Object true_value \
2879 = substitute_object_recurse (object, placeholder,\
2882 if (!EQ (old_value, true_value)) \
2889 substitute_object_recurse (object
, placeholder
, subtree
)
2891 Lisp_Object placeholder
;
2892 Lisp_Object subtree
;
2894 /* If we find the placeholder, return the target object. */
2895 if (EQ (placeholder
, subtree
))
2898 /* If we've been to this node before, don't explore it again. */
2899 if (!EQ (Qnil
, Fmemq (subtree
, seen_list
)))
2902 /* If this node can be the entry point to a cycle, remember that
2903 we've seen it. It can only be such an entry point if it was made
2904 by #n=, which means that we can find it as a value in
2906 if (!EQ (Qnil
, Frassq (subtree
, read_objects
)))
2907 seen_list
= Fcons (subtree
, seen_list
);
2909 /* Recurse according to subtree's type.
2910 Every branch must return a Lisp_Object. */
2911 switch (XTYPE (subtree
))
2913 case Lisp_Vectorlike
:
2916 int length
= XINT (Flength(subtree
));
2917 for (i
= 0; i
< length
; i
++)
2919 Lisp_Object idx
= make_number (i
);
2920 SUBSTITUTE (Faref (subtree
, idx
),
2921 Faset (subtree
, idx
, true_value
));
2928 SUBSTITUTE (Fcar_safe (subtree
),
2929 Fsetcar (subtree
, true_value
));
2930 SUBSTITUTE (Fcdr_safe (subtree
),
2931 Fsetcdr (subtree
, true_value
));
2937 /* Check for text properties in each interval.
2938 substitute_in_interval contains part of the logic. */
2940 INTERVAL root_interval
= STRING_INTERVALS (subtree
);
2941 Lisp_Object arg
= Fcons (object
, placeholder
);
2943 traverse_intervals_noorder (root_interval
,
2944 &substitute_in_interval
, arg
);
2949 /* Other types don't recurse any further. */
2955 /* Helper function for substitute_object_recurse. */
2957 substitute_in_interval (interval
, arg
)
2961 Lisp_Object object
= Fcar (arg
);
2962 Lisp_Object placeholder
= Fcdr (arg
);
2964 SUBSTITUTE(interval
->plist
, interval
->plist
= true_value
);
2983 if (*cp
== '+' || *cp
== '-')
2986 if (*cp
>= '0' && *cp
<= '9')
2989 while (*cp
>= '0' && *cp
<= '9')
2997 if (*cp
>= '0' && *cp
<= '9')
3000 while (*cp
>= '0' && *cp
<= '9')
3003 if (*cp
== 'e' || *cp
== 'E')
3007 if (*cp
== '+' || *cp
== '-')
3011 if (*cp
>= '0' && *cp
<= '9')
3014 while (*cp
>= '0' && *cp
<= '9')
3017 else if (cp
== start
)
3019 else if (cp
[-1] == '+' && cp
[0] == 'I' && cp
[1] == 'N' && cp
[2] == 'F')
3024 else if (cp
[-1] == '+' && cp
[0] == 'N' && cp
[1] == 'a' && cp
[2] == 'N')
3030 return (((*cp
== 0) || (*cp
== ' ') || (*cp
== '\t') || (*cp
== '\n') || (*cp
== '\r') || (*cp
== '\f'))
3031 && (state
== (LEAD_INT
|DOT_CHAR
|TRAIL_INT
)
3032 || state
== (DOT_CHAR
|TRAIL_INT
)
3033 || state
== (LEAD_INT
|E_CHAR
|EXP_INT
)
3034 || state
== (LEAD_INT
|DOT_CHAR
|TRAIL_INT
|E_CHAR
|EXP_INT
)
3035 || state
== (DOT_CHAR
|TRAIL_INT
|E_CHAR
|EXP_INT
)));
3040 read_vector (readcharfun
, bytecodeflag
)
3041 Lisp_Object readcharfun
;
3046 register Lisp_Object
*ptr
;
3047 register Lisp_Object tem
, item
, vector
;
3048 register struct Lisp_Cons
*otem
;
3051 tem
= read_list (1, readcharfun
);
3052 len
= Flength (tem
);
3053 vector
= (read_pure
? make_pure_vector (XINT (len
)) : Fmake_vector (len
, Qnil
));
3055 size
= XVECTOR (vector
)->size
;
3056 ptr
= XVECTOR (vector
)->contents
;
3057 for (i
= 0; i
< size
; i
++)
3060 /* If `load-force-doc-strings' is t when reading a lazily-loaded
3061 bytecode object, the docstring containing the bytecode and
3062 constants values must be treated as unibyte and passed to
3063 Fread, to get the actual bytecode string and constants vector. */
3064 if (bytecodeflag
&& load_force_doc_strings
)
3066 if (i
== COMPILED_BYTECODE
)
3068 if (!STRINGP (item
))
3069 error ("Invalid byte code");
3071 /* Delay handling the bytecode slot until we know whether
3072 it is lazily-loaded (we can tell by whether the
3073 constants slot is nil). */
3074 ptr
[COMPILED_CONSTANTS
] = item
;
3077 else if (i
== COMPILED_CONSTANTS
)
3079 Lisp_Object bytestr
= ptr
[COMPILED_CONSTANTS
];
3083 /* Coerce string to unibyte (like string-as-unibyte,
3084 but without generating extra garbage and
3085 guaranteeing no change in the contents). */
3086 STRING_SET_CHARS (bytestr
, SBYTES (bytestr
));
3087 STRING_SET_UNIBYTE (bytestr
);
3089 item
= Fread (bytestr
);
3091 error ("Invalid byte code");
3093 otem
= XCONS (item
);
3094 bytestr
= XCAR (item
);
3099 /* Now handle the bytecode slot. */
3100 ptr
[COMPILED_BYTECODE
] = read_pure
? Fpurecopy (bytestr
) : bytestr
;
3103 ptr
[i
] = read_pure
? Fpurecopy (item
) : item
;
3111 /* FLAG = 1 means check for ] to terminate rather than ) and .
3112 FLAG = -1 means check for starting with defun
3113 and make structure pure. */
3116 read_list (flag
, readcharfun
)
3118 register Lisp_Object readcharfun
;
3120 /* -1 means check next element for defun,
3121 0 means don't check,
3122 1 means already checked and found defun. */
3123 int defunflag
= flag
< 0 ? -1 : 0;
3124 Lisp_Object val
, tail
;
3125 register Lisp_Object elt
, tem
;
3126 struct gcpro gcpro1
, gcpro2
;
3127 /* 0 is the normal case.
3128 1 means this list is a doc reference; replace it with the number 0.
3129 2 means this list is a doc reference; replace it with the doc string. */
3130 int doc_reference
= 0;
3132 /* Initialize this to 1 if we are reading a list. */
3133 int first_in_list
= flag
<= 0;
3142 elt
= read1 (readcharfun
, &ch
, first_in_list
);
3147 /* While building, if the list starts with #$, treat it specially. */
3148 if (EQ (elt
, Vload_file_name
)
3150 && !NILP (Vpurify_flag
))
3152 if (NILP (Vdoc_file_name
))
3153 /* We have not yet called Snarf-documentation, so assume
3154 this file is described in the DOC-MM.NN file
3155 and Snarf-documentation will fill in the right value later.
3156 For now, replace the whole list with 0. */
3159 /* We have already called Snarf-documentation, so make a relative
3160 file name for this file, so it can be found properly
3161 in the installed Lisp directory.
3162 We don't use Fexpand_file_name because that would make
3163 the directory absolute now. */
3164 elt
= concat2 (build_string ("../lisp/"),
3165 Ffile_name_nondirectory (elt
));
3167 else if (EQ (elt
, Vload_file_name
)
3169 && load_force_doc_strings
)
3178 invalid_syntax (") or . in a vector", 18);
3186 XSETCDR (tail
, read0 (readcharfun
));
3188 val
= read0 (readcharfun
);
3189 read1 (readcharfun
, &ch
, 0);
3193 if (doc_reference
== 1)
3194 return make_number (0);
3195 if (doc_reference
== 2)
3197 /* Get a doc string from the file we are loading.
3198 If it's in saved_doc_string, get it from there. */
3199 int pos
= XINT (XCDR (val
));
3200 /* Position is negative for user variables. */
3201 if (pos
< 0) pos
= -pos
;
3202 if (pos
>= saved_doc_string_position
3203 && pos
< (saved_doc_string_position
3204 + saved_doc_string_length
))
3206 int start
= pos
- saved_doc_string_position
;
3209 /* Process quoting with ^A,
3210 and find the end of the string,
3211 which is marked with ^_ (037). */
3212 for (from
= start
, to
= start
;
3213 saved_doc_string
[from
] != 037;)
3215 int c
= saved_doc_string
[from
++];
3218 c
= saved_doc_string
[from
++];
3220 saved_doc_string
[to
++] = c
;
3222 saved_doc_string
[to
++] = 0;
3224 saved_doc_string
[to
++] = 037;
3227 saved_doc_string
[to
++] = c
;
3230 return make_string (saved_doc_string
+ start
,
3233 /* Look in prev_saved_doc_string the same way. */
3234 else if (pos
>= prev_saved_doc_string_position
3235 && pos
< (prev_saved_doc_string_position
3236 + prev_saved_doc_string_length
))
3238 int start
= pos
- prev_saved_doc_string_position
;
3241 /* Process quoting with ^A,
3242 and find the end of the string,
3243 which is marked with ^_ (037). */
3244 for (from
= start
, to
= start
;
3245 prev_saved_doc_string
[from
] != 037;)
3247 int c
= prev_saved_doc_string
[from
++];
3250 c
= prev_saved_doc_string
[from
++];
3252 prev_saved_doc_string
[to
++] = c
;
3254 prev_saved_doc_string
[to
++] = 0;
3256 prev_saved_doc_string
[to
++] = 037;
3259 prev_saved_doc_string
[to
++] = c
;
3262 return make_string (prev_saved_doc_string
+ start
,
3266 return get_doc_string (val
, 0, 0);
3271 invalid_syntax (". in wrong context", 18);
3273 invalid_syntax ("] in a list", 11);
3275 tem
= (read_pure
&& flag
<= 0
3276 ? pure_cons (elt
, Qnil
)
3277 : Fcons (elt
, Qnil
));
3279 XSETCDR (tail
, tem
);
3284 defunflag
= EQ (elt
, Qdefun
);
3285 else if (defunflag
> 0)
3290 Lisp_Object Vobarray
;
3291 Lisp_Object initial_obarray
;
3293 /* oblookup stores the bucket number here, for the sake of Funintern. */
3295 int oblookup_last_bucket_number
;
3297 static int hash_string ();
3299 /* Get an error if OBARRAY is not an obarray.
3300 If it is one, return it. */
3303 check_obarray (obarray
)
3304 Lisp_Object obarray
;
3306 if (!VECTORP (obarray
) || XVECTOR (obarray
)->size
== 0)
3308 /* If Vobarray is now invalid, force it to be valid. */
3309 if (EQ (Vobarray
, obarray
)) Vobarray
= initial_obarray
;
3310 wrong_type_argument (Qvectorp
, obarray
);
3315 /* Intern the C string STR: return a symbol with that name,
3316 interned in the current obarray. */
3323 int len
= strlen (str
);
3324 Lisp_Object obarray
;
3327 if (!VECTORP (obarray
) || XVECTOR (obarray
)->size
== 0)
3328 obarray
= check_obarray (obarray
);
3329 tem
= oblookup (obarray
, str
, len
, len
);
3332 return Fintern (make_string (str
, len
), obarray
);
3335 /* Create an uninterned symbol with name STR. */
3341 int len
= strlen (str
);
3343 return Fmake_symbol ((!NILP (Vpurify_flag
)
3344 ? make_pure_string (str
, len
, len
, 0)
3345 : make_string (str
, len
)));
3348 DEFUN ("intern", Fintern
, Sintern
, 1, 2, 0,
3349 doc
: /* Return the canonical symbol whose name is STRING.
3350 If there is none, one is created by this function and returned.
3351 A second optional argument specifies the obarray to use;
3352 it defaults to the value of `obarray'. */)
3354 Lisp_Object string
, obarray
;
3356 register Lisp_Object tem
, sym
, *ptr
;
3358 if (NILP (obarray
)) obarray
= Vobarray
;
3359 obarray
= check_obarray (obarray
);
3361 CHECK_STRING (string
);
3363 tem
= oblookup (obarray
, SDATA (string
),
3366 if (!INTEGERP (tem
))
3369 if (!NILP (Vpurify_flag
))
3370 string
= Fpurecopy (string
);
3371 sym
= Fmake_symbol (string
);
3373 if (EQ (obarray
, initial_obarray
))
3374 XSYMBOL (sym
)->interned
= SYMBOL_INTERNED_IN_INITIAL_OBARRAY
;
3376 XSYMBOL (sym
)->interned
= SYMBOL_INTERNED
;
3378 if ((SREF (string
, 0) == ':')
3379 && EQ (obarray
, initial_obarray
))
3381 XSYMBOL (sym
)->constant
= 1;
3382 XSYMBOL (sym
)->value
= sym
;
3385 ptr
= &XVECTOR (obarray
)->contents
[XINT (tem
)];
3387 XSYMBOL (sym
)->next
= XSYMBOL (*ptr
);
3389 XSYMBOL (sym
)->next
= 0;
3394 DEFUN ("intern-soft", Fintern_soft
, Sintern_soft
, 1, 2, 0,
3395 doc
: /* Return the canonical symbol named NAME, or nil if none exists.
3396 NAME may be a string or a symbol. If it is a symbol, that exact
3397 symbol is searched for.
3398 A second optional argument specifies the obarray to use;
3399 it defaults to the value of `obarray'. */)
3401 Lisp_Object name
, obarray
;
3403 register Lisp_Object tem
, string
;
3405 if (NILP (obarray
)) obarray
= Vobarray
;
3406 obarray
= check_obarray (obarray
);
3408 if (!SYMBOLP (name
))
3410 CHECK_STRING (name
);
3414 string
= SYMBOL_NAME (name
);
3416 tem
= oblookup (obarray
, SDATA (string
), SCHARS (string
), SBYTES (string
));
3417 if (INTEGERP (tem
) || (SYMBOLP (name
) && !EQ (name
, tem
)))
3423 DEFUN ("unintern", Funintern
, Sunintern
, 1, 2, 0,
3424 doc
: /* Delete the symbol named NAME, if any, from OBARRAY.
3425 The value is t if a symbol was found and deleted, nil otherwise.
3426 NAME may be a string or a symbol. If it is a symbol, that symbol
3427 is deleted, if it belongs to OBARRAY--no other symbol is deleted.
3428 OBARRAY defaults to the value of the variable `obarray'. */)
3430 Lisp_Object name
, obarray
;
3432 register Lisp_Object string
, tem
;
3435 if (NILP (obarray
)) obarray
= Vobarray
;
3436 obarray
= check_obarray (obarray
);
3439 string
= SYMBOL_NAME (name
);
3442 CHECK_STRING (name
);
3446 tem
= oblookup (obarray
, SDATA (string
),
3451 /* If arg was a symbol, don't delete anything but that symbol itself. */
3452 if (SYMBOLP (name
) && !EQ (name
, tem
))
3455 XSYMBOL (tem
)->interned
= SYMBOL_UNINTERNED
;
3456 XSYMBOL (tem
)->constant
= 0;
3457 XSYMBOL (tem
)->indirect_variable
= 0;
3459 hash
= oblookup_last_bucket_number
;
3461 if (EQ (XVECTOR (obarray
)->contents
[hash
], tem
))
3463 if (XSYMBOL (tem
)->next
)
3464 XSETSYMBOL (XVECTOR (obarray
)->contents
[hash
], XSYMBOL (tem
)->next
);
3466 XSETINT (XVECTOR (obarray
)->contents
[hash
], 0);
3470 Lisp_Object tail
, following
;
3472 for (tail
= XVECTOR (obarray
)->contents
[hash
];
3473 XSYMBOL (tail
)->next
;
3476 XSETSYMBOL (following
, XSYMBOL (tail
)->next
);
3477 if (EQ (following
, tem
))
3479 XSYMBOL (tail
)->next
= XSYMBOL (following
)->next
;
3488 /* Return the symbol in OBARRAY whose names matches the string
3489 of SIZE characters (SIZE_BYTE bytes) at PTR.
3490 If there is no such symbol in OBARRAY, return nil.
3492 Also store the bucket number in oblookup_last_bucket_number. */
3495 oblookup (obarray
, ptr
, size
, size_byte
)
3496 Lisp_Object obarray
;
3497 register const char *ptr
;
3498 int size
, size_byte
;
3502 register Lisp_Object tail
;
3503 Lisp_Object bucket
, tem
;
3505 if (!VECTORP (obarray
)
3506 || (obsize
= XVECTOR (obarray
)->size
) == 0)
3508 obarray
= check_obarray (obarray
);
3509 obsize
= XVECTOR (obarray
)->size
;
3511 /* This is sometimes needed in the middle of GC. */
3512 obsize
&= ~ARRAY_MARK_FLAG
;
3513 /* Combining next two lines breaks VMS C 2.3. */
3514 hash
= hash_string (ptr
, size_byte
);
3516 bucket
= XVECTOR (obarray
)->contents
[hash
];
3517 oblookup_last_bucket_number
= hash
;
3518 if (EQ (bucket
, make_number (0)))
3520 else if (!SYMBOLP (bucket
))
3521 error ("Bad data in guts of obarray"); /* Like CADR error message */
3523 for (tail
= bucket
; ; XSETSYMBOL (tail
, XSYMBOL (tail
)->next
))
3525 if (SBYTES (SYMBOL_NAME (tail
)) == size_byte
3526 && SCHARS (SYMBOL_NAME (tail
)) == size
3527 && !bcmp (SDATA (SYMBOL_NAME (tail
)), ptr
, size_byte
))
3529 else if (XSYMBOL (tail
)->next
== 0)
3532 XSETINT (tem
, hash
);
3537 hash_string (ptr
, len
)
3538 const unsigned char *ptr
;
3541 register const unsigned char *p
= ptr
;
3542 register const unsigned char *end
= p
+ len
;
3543 register unsigned char c
;
3544 register int hash
= 0;
3549 if (c
>= 0140) c
-= 40;
3550 hash
= ((hash
<<3) + (hash
>>28) + c
);
3552 return hash
& 07777777777;
3556 map_obarray (obarray
, fn
, arg
)
3557 Lisp_Object obarray
;
3558 void (*fn
) P_ ((Lisp_Object
, Lisp_Object
));
3562 register Lisp_Object tail
;
3563 CHECK_VECTOR (obarray
);
3564 for (i
= XVECTOR (obarray
)->size
- 1; i
>= 0; i
--)
3566 tail
= XVECTOR (obarray
)->contents
[i
];
3571 if (XSYMBOL (tail
)->next
== 0)
3573 XSETSYMBOL (tail
, XSYMBOL (tail
)->next
);
3579 mapatoms_1 (sym
, function
)
3580 Lisp_Object sym
, function
;
3582 call1 (function
, sym
);
3585 DEFUN ("mapatoms", Fmapatoms
, Smapatoms
, 1, 2, 0,
3586 doc
: /* Call FUNCTION on every symbol in OBARRAY.
3587 OBARRAY defaults to the value of `obarray'. */)
3589 Lisp_Object function
, obarray
;
3591 if (NILP (obarray
)) obarray
= Vobarray
;
3592 obarray
= check_obarray (obarray
);
3594 map_obarray (obarray
, mapatoms_1
, function
);
3598 #define OBARRAY_SIZE 1511
3603 Lisp_Object oblength
;
3607 XSETFASTINT (oblength
, OBARRAY_SIZE
);
3609 Qnil
= Fmake_symbol (make_pure_string ("nil", 3, 3, 0));
3610 Vobarray
= Fmake_vector (oblength
, make_number (0));
3611 initial_obarray
= Vobarray
;
3612 staticpro (&initial_obarray
);
3613 /* Intern nil in the obarray */
3614 XSYMBOL (Qnil
)->interned
= SYMBOL_INTERNED_IN_INITIAL_OBARRAY
;
3615 XSYMBOL (Qnil
)->constant
= 1;
3617 /* These locals are to kludge around a pyramid compiler bug. */
3618 hash
= hash_string ("nil", 3);
3619 /* Separate statement here to avoid VAXC bug. */
3620 hash
%= OBARRAY_SIZE
;
3621 tem
= &XVECTOR (Vobarray
)->contents
[hash
];
3624 Qunbound
= Fmake_symbol (make_pure_string ("unbound", 7, 7, 0));
3625 XSYMBOL (Qnil
)->function
= Qunbound
;
3626 XSYMBOL (Qunbound
)->value
= Qunbound
;
3627 XSYMBOL (Qunbound
)->function
= Qunbound
;
3630 XSYMBOL (Qnil
)->value
= Qnil
;
3631 XSYMBOL (Qnil
)->plist
= Qnil
;
3632 XSYMBOL (Qt
)->value
= Qt
;
3633 XSYMBOL (Qt
)->constant
= 1;
3635 /* Qt is correct even if CANNOT_DUMP. loadup.el will set to nil at end. */
3638 Qvariable_documentation
= intern ("variable-documentation");
3639 staticpro (&Qvariable_documentation
);
3641 read_buffer_size
= 100 + MAX_MULTIBYTE_LENGTH
;
3642 read_buffer
= (char *) xmalloc (read_buffer_size
);
3647 struct Lisp_Subr
*sname
;
3650 sym
= intern (sname
->symbol_name
);
3651 XSETSUBR (XSYMBOL (sym
)->function
, sname
);
3654 #ifdef NOTDEF /* use fset in subr.el now */
3656 defalias (sname
, string
)
3657 struct Lisp_Subr
*sname
;
3661 sym
= intern (string
);
3662 XSETSUBR (XSYMBOL (sym
)->function
, sname
);
3666 /* Define an "integer variable"; a symbol whose value is forwarded
3667 to a C variable of type int. Sample call: */
3668 /* DEFVAR_INT ("indent-tabs-mode", &indent_tabs_mode, "Documentation"); */
3670 defvar_int (namestring
, address
)
3674 Lisp_Object sym
, val
;
3675 sym
= intern (namestring
);
3676 val
= allocate_misc ();
3677 XMISCTYPE (val
) = Lisp_Misc_Intfwd
;
3678 XINTFWD (val
)->intvar
= address
;
3679 SET_SYMBOL_VALUE (sym
, val
);
3682 /* Similar but define a variable whose value is t if address contains 1,
3683 nil if address contains 0 */
3685 defvar_bool (namestring
, address
)
3689 Lisp_Object sym
, val
;
3690 sym
= intern (namestring
);
3691 val
= allocate_misc ();
3692 XMISCTYPE (val
) = Lisp_Misc_Boolfwd
;
3693 XBOOLFWD (val
)->boolvar
= address
;
3694 SET_SYMBOL_VALUE (sym
, val
);
3695 Vbyte_boolean_vars
= Fcons (sym
, Vbyte_boolean_vars
);
3698 /* Similar but define a variable whose value is the Lisp Object stored
3699 at address. Two versions: with and without gc-marking of the C
3700 variable. The nopro version is used when that variable will be
3701 gc-marked for some other reason, since marking the same slot twice
3702 can cause trouble with strings. */
3704 defvar_lisp_nopro (namestring
, address
)
3706 Lisp_Object
*address
;
3708 Lisp_Object sym
, val
;
3709 sym
= intern (namestring
);
3710 val
= allocate_misc ();
3711 XMISCTYPE (val
) = Lisp_Misc_Objfwd
;
3712 XOBJFWD (val
)->objvar
= address
;
3713 SET_SYMBOL_VALUE (sym
, val
);
3717 defvar_lisp (namestring
, address
)
3719 Lisp_Object
*address
;
3721 defvar_lisp_nopro (namestring
, address
);
3722 staticpro (address
);
3725 /* Similar but define a variable whose value is the Lisp Object stored in
3726 the current buffer. address is the address of the slot in the buffer
3727 that is current now. */
3730 defvar_per_buffer (namestring
, address
, type
, doc
)
3732 Lisp_Object
*address
;
3736 Lisp_Object sym
, val
;
3739 sym
= intern (namestring
);
3740 val
= allocate_misc ();
3741 offset
= (char *)address
- (char *)current_buffer
;
3743 XMISCTYPE (val
) = Lisp_Misc_Buffer_Objfwd
;
3744 XBUFFER_OBJFWD (val
)->offset
= offset
;
3745 SET_SYMBOL_VALUE (sym
, val
);
3746 PER_BUFFER_SYMBOL (offset
) = sym
;
3747 PER_BUFFER_TYPE (offset
) = type
;
3749 if (PER_BUFFER_IDX (offset
) == 0)
3750 /* Did a DEFVAR_PER_BUFFER without initializing the corresponding
3751 slot of buffer_local_flags */
3756 /* Similar but define a variable whose value is the Lisp Object stored
3757 at a particular offset in the current kboard object. */
3760 defvar_kboard (namestring
, offset
)
3764 Lisp_Object sym
, val
;
3765 sym
= intern (namestring
);
3766 val
= allocate_misc ();
3767 XMISCTYPE (val
) = Lisp_Misc_Kboard_Objfwd
;
3768 XKBOARD_OBJFWD (val
)->offset
= offset
;
3769 SET_SYMBOL_VALUE (sym
, val
);
3772 /* Record the value of load-path used at the start of dumping
3773 so we can see if the site changed it later during dumping. */
3774 static Lisp_Object dump_path
;
3780 int turn_off_warning
= 0;
3782 /* Compute the default load-path. */
3784 normal
= PATH_LOADSEARCH
;
3785 Vload_path
= decode_env_path (0, normal
);
3787 if (NILP (Vpurify_flag
))
3788 normal
= PATH_LOADSEARCH
;
3790 normal
= PATH_DUMPLOADSEARCH
;
3792 /* In a dumped Emacs, we normally have to reset the value of
3793 Vload_path from PATH_LOADSEARCH, since the value that was dumped
3794 uses ../lisp, instead of the path of the installed elisp
3795 libraries. However, if it appears that Vload_path was changed
3796 from the default before dumping, don't override that value. */
3799 if (! NILP (Fequal (dump_path
, Vload_path
)))
3801 Vload_path
= decode_env_path (0, normal
);
3802 if (!NILP (Vinstallation_directory
))
3804 Lisp_Object tem
, tem1
, sitelisp
;
3806 /* Remove site-lisp dirs from path temporarily and store
3807 them in sitelisp, then conc them on at the end so
3808 they're always first in path. */
3812 tem
= Fcar (Vload_path
);
3813 tem1
= Fstring_match (build_string ("site-lisp"),
3817 Vload_path
= Fcdr (Vload_path
);
3818 sitelisp
= Fcons (tem
, sitelisp
);
3824 /* Add to the path the lisp subdir of the
3825 installation dir, if it exists. */
3826 tem
= Fexpand_file_name (build_string ("lisp"),
3827 Vinstallation_directory
);
3828 tem1
= Ffile_exists_p (tem
);
3831 if (NILP (Fmember (tem
, Vload_path
)))
3833 turn_off_warning
= 1;
3834 Vload_path
= Fcons (tem
, Vload_path
);
3838 /* That dir doesn't exist, so add the build-time
3839 Lisp dirs instead. */
3840 Vload_path
= nconc2 (Vload_path
, dump_path
);
3842 /* Add leim under the installation dir, if it exists. */
3843 tem
= Fexpand_file_name (build_string ("leim"),
3844 Vinstallation_directory
);
3845 tem1
= Ffile_exists_p (tem
);
3848 if (NILP (Fmember (tem
, Vload_path
)))
3849 Vload_path
= Fcons (tem
, Vload_path
);
3852 /* Add site-list under the installation dir, if it exists. */
3853 tem
= Fexpand_file_name (build_string ("site-lisp"),
3854 Vinstallation_directory
);
3855 tem1
= Ffile_exists_p (tem
);
3858 if (NILP (Fmember (tem
, Vload_path
)))
3859 Vload_path
= Fcons (tem
, Vload_path
);
3862 /* If Emacs was not built in the source directory,
3863 and it is run from where it was built, add to load-path
3864 the lisp, leim and site-lisp dirs under that directory. */
3866 if (NILP (Fequal (Vinstallation_directory
, Vsource_directory
)))
3870 tem
= Fexpand_file_name (build_string ("src/Makefile"),
3871 Vinstallation_directory
);
3872 tem1
= Ffile_exists_p (tem
);
3874 /* Don't be fooled if they moved the entire source tree
3875 AFTER dumping Emacs. If the build directory is indeed
3876 different from the source dir, src/Makefile.in and
3877 src/Makefile will not be found together. */
3878 tem
= Fexpand_file_name (build_string ("src/Makefile.in"),
3879 Vinstallation_directory
);
3880 tem2
= Ffile_exists_p (tem
);
3881 if (!NILP (tem1
) && NILP (tem2
))
3883 tem
= Fexpand_file_name (build_string ("lisp"),
3886 if (NILP (Fmember (tem
, Vload_path
)))
3887 Vload_path
= Fcons (tem
, Vload_path
);
3889 tem
= Fexpand_file_name (build_string ("leim"),
3892 if (NILP (Fmember (tem
, Vload_path
)))
3893 Vload_path
= Fcons (tem
, Vload_path
);
3895 tem
= Fexpand_file_name (build_string ("site-lisp"),
3898 if (NILP (Fmember (tem
, Vload_path
)))
3899 Vload_path
= Fcons (tem
, Vload_path
);
3902 if (!NILP (sitelisp
))
3903 Vload_path
= nconc2 (Fnreverse (sitelisp
), Vload_path
);
3909 /* NORMAL refers to the lisp dir in the source directory. */
3910 /* We used to add ../lisp at the front here, but
3911 that caused trouble because it was copied from dump_path
3912 into Vload_path, aboe, when Vinstallation_directory was non-nil.
3913 It should be unnecessary. */
3914 Vload_path
= decode_env_path (0, normal
);
3915 dump_path
= Vload_path
;
3919 #if (!(defined(WINDOWSNT) || (defined(HAVE_CARBON))))
3920 /* When Emacs is invoked over network shares on NT, PATH_LOADSEARCH is
3921 almost never correct, thereby causing a warning to be printed out that
3922 confuses users. Since PATH_LOADSEARCH is always overridden by the
3923 EMACSLOADPATH environment variable below, disable the warning on NT.
3924 Also, when using the "self-contained" option for Carbon Emacs for MacOSX,
3925 the "standard" paths may not exist and would be overridden by
3926 EMACSLOADPATH as on NT. Since this depends on how the executable
3927 was build and packaged, turn off the warnings in general */
3929 /* Warn if dirs in the *standard* path don't exist. */
3930 if (!turn_off_warning
)
3932 Lisp_Object path_tail
;
3934 for (path_tail
= Vload_path
;
3936 path_tail
= XCDR (path_tail
))
3938 Lisp_Object dirfile
;
3939 dirfile
= Fcar (path_tail
);
3940 if (STRINGP (dirfile
))
3942 dirfile
= Fdirectory_file_name (dirfile
);
3943 if (access (SDATA (dirfile
), 0) < 0)
3944 dir_warning ("Warning: Lisp directory `%s' does not exist.\n",
3949 #endif /* !(WINDOWSNT || HAVE_CARBON) */
3951 /* If the EMACSLOADPATH environment variable is set, use its value.
3952 This doesn't apply if we're dumping. */
3954 if (NILP (Vpurify_flag
)
3955 && egetenv ("EMACSLOADPATH"))
3957 Vload_path
= decode_env_path ("EMACSLOADPATH", normal
);
3961 load_in_progress
= 0;
3962 Vload_file_name
= Qnil
;
3964 load_descriptor_list
= Qnil
;
3966 Vstandard_input
= Qt
;
3967 Vloads_in_progress
= Qnil
;
3970 /* Print a warning, using format string FORMAT, that directory DIRNAME
3971 does not exist. Print it on stderr and put it in *Message*. */
3974 dir_warning (format
, dirname
)
3976 Lisp_Object dirname
;
3979 = (char *) alloca (SCHARS (dirname
) + strlen (format
) + 5);
3981 fprintf (stderr
, format
, SDATA (dirname
));
3982 sprintf (buffer
, format
, SDATA (dirname
));
3983 /* Don't log the warning before we've initialized!! */
3985 message_dolog (buffer
, strlen (buffer
), 0, STRING_MULTIBYTE (dirname
));
3992 defsubr (&Sread_from_string
);
3994 defsubr (&Sintern_soft
);
3995 defsubr (&Sunintern
);
3996 defsubr (&Sget_load_suffixes
);
3998 defsubr (&Seval_buffer
);
3999 defsubr (&Seval_region
);
4000 defsubr (&Sread_char
);
4001 defsubr (&Sread_char_exclusive
);
4002 defsubr (&Sread_event
);
4003 defsubr (&Sget_file_char
);
4004 defsubr (&Smapatoms
);
4005 defsubr (&Slocate_file_internal
);
4007 DEFVAR_LISP ("obarray", &Vobarray
,
4008 doc
: /* Symbol table for use by `intern' and `read'.
4009 It is a vector whose length ought to be prime for best results.
4010 The vector's contents don't make sense if examined from Lisp programs;
4011 to find all the symbols in an obarray, use `mapatoms'. */);
4013 DEFVAR_LISP ("values", &Vvalues
,
4014 doc
: /* List of values of all expressions which were read, evaluated and printed.
4015 Order is reverse chronological. */);
4017 DEFVAR_LISP ("standard-input", &Vstandard_input
,
4018 doc
: /* Stream for read to get input from.
4019 See documentation of `read' for possible values. */);
4020 Vstandard_input
= Qt
;
4022 DEFVAR_LISP ("read-with-symbol-positions", &Vread_with_symbol_positions
,
4023 doc
: /* If non-nil, add position of read symbols to `read-symbol-positions-list'.
4025 If this variable is a buffer, then only forms read from that buffer
4026 will be added to `read-symbol-positions-list'.
4027 If this variable is t, then all read forms will be added.
4028 The effect of all other values other than nil are not currently
4029 defined, although they may be in the future.
4031 The positions are relative to the last call to `read' or
4032 `read-from-string'. It is probably a bad idea to set this variable at
4033 the toplevel; bind it instead. */);
4034 Vread_with_symbol_positions
= Qnil
;
4036 DEFVAR_LISP ("read-symbol-positions-list", &Vread_symbol_positions_list
,
4037 doc
: /* A list mapping read symbols to their positions.
4038 This variable is modified during calls to `read' or
4039 `read-from-string', but only when `read-with-symbol-positions' is
4042 Each element of the list looks like (SYMBOL . CHAR-POSITION), where
4043 CHAR-POSITION is an integer giving the offset of that occurrence of the
4044 symbol from the position where `read' or `read-from-string' started.
4046 Note that a symbol will appear multiple times in this list, if it was
4047 read multiple times. The list is in the same order as the symbols
4049 Vread_symbol_positions_list
= Qnil
;
4051 DEFVAR_LISP ("load-path", &Vload_path
,
4052 doc
: /* *List of directories to search for files to load.
4053 Each element is a string (directory name) or nil (try default directory).
4054 Initialized based on EMACSLOADPATH environment variable, if any,
4055 otherwise to default specified by file `epaths.h' when Emacs was built. */);
4057 DEFVAR_LISP ("load-suffixes", &Vload_suffixes
,
4058 doc
: /* List of suffixes for (compiled or source) Emacs Lisp files.
4059 This list should not include the empty string.
4060 `load' and related functions try to append these suffixes, in order,
4061 to the specified file name if a Lisp suffix is allowed or required. */);
4062 Vload_suffixes
= Fcons (build_string (".elc"),
4063 Fcons (build_string (".el"), Qnil
));
4064 DEFVAR_LISP ("load-file-rep-suffixes", &Vload_file_rep_suffixes
,
4065 doc
: /* List of suffixes that indicate representations of \
4067 This list should normally start with the empty string.
4069 Enabling Auto Compression mode appends the suffixes in
4070 `jka-compr-load-suffixes' to this list and disabling Auto Compression
4071 mode removes them again. `load' and related functions use this list to
4072 determine whether they should look for compressed versions of a file
4073 and, if so, which suffixes they should try to append to the file name
4074 in order to do so. However, if you want to customize which suffixes
4075 the loading functions recognize as compression suffixes, you should
4076 customize `jka-compr-load-suffixes' rather than the present variable. */);
4077 Vload_file_rep_suffixes
= Fcons (empty_unibyte_string
, Qnil
);
4079 DEFVAR_BOOL ("load-in-progress", &load_in_progress
,
4080 doc
: /* Non-nil if inside of `load'. */);
4082 DEFVAR_LISP ("after-load-alist", &Vafter_load_alist
,
4083 doc
: /* An alist of expressions to be evalled when particular files are loaded.
4084 Each element looks like (REGEXP-OR-FEATURE FORMS...).
4086 REGEXP-OR-FEATURE is either a regular expression to match file names, or
4087 a symbol \(a feature name).
4089 When `load' is run and the file-name argument matches an element's
4090 REGEXP-OR-FEATURE, or when `provide' is run and provides the symbol
4091 REGEXP-OR-FEATURE, the FORMS in the element are executed.
4093 An error in FORMS does not undo the load, but does prevent execution of
4094 the rest of the FORMS. */);
4095 Vafter_load_alist
= Qnil
;
4097 DEFVAR_LISP ("load-history", &Vload_history
,
4098 doc
: /* Alist mapping file names to symbols and features.
4099 Each alist element is a list that starts with a file name,
4100 except for one element (optional) that starts with nil and describes
4101 definitions evaluated from buffers not visiting files.
4103 The file name is absolute and is the true file name (i.e. it doesn't
4104 contain symbolic links) of the loaded file.
4106 The remaining elements of each list are symbols defined as variables
4107 and cons cells of the form `(provide . FEATURE)', `(require . FEATURE)',
4108 `(defun . FUNCTION)', `(autoload . SYMBOL)', `(defface . SYMBOL)'
4109 and `(t . SYMBOL)'. An element `(t . SYMBOL)' precedes an entry
4110 `(defun . FUNCTION)', and means that SYMBOL was an autoload before
4111 this file redefined it as a function.
4113 During preloading, the file name recorded is relative to the main Lisp
4114 directory. These file names are converted to absolute at startup. */);
4115 Vload_history
= Qnil
;
4117 DEFVAR_LISP ("load-file-name", &Vload_file_name
,
4118 doc
: /* Full name of file being loaded by `load'. */);
4119 Vload_file_name
= Qnil
;
4121 DEFVAR_LISP ("user-init-file", &Vuser_init_file
,
4122 doc
: /* File name, including directory, of user's initialization file.
4123 If the file loaded had extension `.elc', and the corresponding source file
4124 exists, this variable contains the name of source file, suitable for use
4125 by functions like `custom-save-all' which edit the init file.
4126 While Emacs loads and evaluates the init file, value is the real name
4127 of the file, regardless of whether or not it has the `.elc' extension. */);
4128 Vuser_init_file
= Qnil
;
4130 DEFVAR_LISP ("current-load-list", &Vcurrent_load_list
,
4131 doc
: /* Used for internal purposes by `load'. */);
4132 Vcurrent_load_list
= Qnil
;
4134 DEFVAR_LISP ("load-read-function", &Vload_read_function
,
4135 doc
: /* Function used by `load' and `eval-region' for reading expressions.
4136 The default is nil, which means use the function `read'. */);
4137 Vload_read_function
= Qnil
;
4139 DEFVAR_LISP ("load-source-file-function", &Vload_source_file_function
,
4140 doc
: /* Function called in `load' for loading an Emacs Lisp source file.
4141 This function is for doing code conversion before reading the source file.
4142 If nil, loading is done without any code conversion.
4143 Arguments are FULLNAME, FILE, NOERROR, NOMESSAGE, where
4144 FULLNAME is the full name of FILE.
4145 See `load' for the meaning of the remaining arguments. */);
4146 Vload_source_file_function
= Qnil
;
4148 DEFVAR_BOOL ("load-force-doc-strings", &load_force_doc_strings
,
4149 doc
: /* Non-nil means `load' should force-load all dynamic doc strings.
4150 This is useful when the file being loaded is a temporary copy. */);
4151 load_force_doc_strings
= 0;
4153 DEFVAR_BOOL ("load-convert-to-unibyte", &load_convert_to_unibyte
,
4154 doc
: /* Non-nil means `read' converts strings to unibyte whenever possible.
4155 This is normally bound by `load' and `eval-buffer' to control `read',
4156 and is not meant for users to change. */);
4157 load_convert_to_unibyte
= 0;
4159 DEFVAR_LISP ("source-directory", &Vsource_directory
,
4160 doc
: /* Directory in which Emacs sources were found when Emacs was built.
4161 You cannot count on them to still be there! */);
4163 = Fexpand_file_name (build_string ("../"),
4164 Fcar (decode_env_path (0, PATH_DUMPLOADSEARCH
)));
4166 DEFVAR_LISP ("preloaded-file-list", &Vpreloaded_file_list
,
4167 doc
: /* List of files that were preloaded (when dumping Emacs). */);
4168 Vpreloaded_file_list
= Qnil
;
4170 DEFVAR_LISP ("byte-boolean-vars", &Vbyte_boolean_vars
,
4171 doc
: /* List of all DEFVAR_BOOL variables, used by the byte code optimizer. */);
4172 Vbyte_boolean_vars
= Qnil
;
4174 DEFVAR_BOOL ("load-dangerous-libraries", &load_dangerous_libraries
,
4175 doc
: /* Non-nil means load dangerous compiled Lisp files.
4176 Some versions of XEmacs use different byte codes than Emacs. These
4177 incompatible byte codes can make Emacs crash when it tries to execute
4179 load_dangerous_libraries
= 0;
4181 DEFVAR_LISP ("bytecomp-version-regexp", &Vbytecomp_version_regexp
,
4182 doc
: /* Regular expression matching safe to load compiled Lisp files.
4183 When Emacs loads a compiled Lisp file, it reads the first 512 bytes
4184 from the file, and matches them against this regular expression.
4185 When the regular expression matches, the file is considered to be safe
4186 to load. See also `load-dangerous-libraries'. */);
4187 Vbytecomp_version_regexp
4188 = build_string ("^;;;.\\(in Emacs version\\|bytecomp version FSF\\)");
4190 DEFVAR_LISP ("eval-buffer-list", &Veval_buffer_list
,
4191 doc
: /* List of buffers being read from by calls to `eval-buffer' and `eval-region'. */);
4192 Veval_buffer_list
= Qnil
;
4194 /* Vsource_directory was initialized in init_lread. */
4196 load_descriptor_list
= Qnil
;
4197 staticpro (&load_descriptor_list
);
4199 Qcurrent_load_list
= intern ("current-load-list");
4200 staticpro (&Qcurrent_load_list
);
4202 Qstandard_input
= intern ("standard-input");
4203 staticpro (&Qstandard_input
);
4205 Qread_char
= intern ("read-char");
4206 staticpro (&Qread_char
);
4208 Qget_file_char
= intern ("get-file-char");
4209 staticpro (&Qget_file_char
);
4211 Qbackquote
= intern ("`");
4212 staticpro (&Qbackquote
);
4213 Qcomma
= intern (",");
4214 staticpro (&Qcomma
);
4215 Qcomma_at
= intern (",@");
4216 staticpro (&Qcomma_at
);
4217 Qcomma_dot
= intern (",.");
4218 staticpro (&Qcomma_dot
);
4220 Qinhibit_file_name_operation
= intern ("inhibit-file-name-operation");
4221 staticpro (&Qinhibit_file_name_operation
);
4223 Qascii_character
= intern ("ascii-character");
4224 staticpro (&Qascii_character
);
4226 Qfunction
= intern ("function");
4227 staticpro (&Qfunction
);
4229 Qload
= intern ("load");
4232 Qload_file_name
= intern ("load-file-name");
4233 staticpro (&Qload_file_name
);
4235 Qeval_buffer_list
= intern ("eval-buffer-list");
4236 staticpro (&Qeval_buffer_list
);
4238 Qfile_truename
= intern ("file-truename");
4239 staticpro (&Qfile_truename
) ;
4241 Qdo_after_load_evaluation
= intern ("do-after-load-evaluation");
4242 staticpro (&Qdo_after_load_evaluation
) ;
4244 staticpro (&dump_path
);
4246 staticpro (&read_objects
);
4247 read_objects
= Qnil
;
4248 staticpro (&seen_list
);
4251 Vloads_in_progress
= Qnil
;
4252 staticpro (&Vloads_in_progress
);
4255 /* arch-tag: a0d02733-0f96-4844-a659-9fd53c4f414d
4256 (do not change this comment) */