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>
32 #include "intervals.h"
39 #include "termhooks.h"
41 #include "blockinput.h"
44 #include <sys/inode.h>
49 #include <unistd.h> /* to get X_OK */
66 #endif /* HAVE_SETLOCALE */
76 #define file_offset off_t
77 #define file_tell ftello
79 #define file_offset long
80 #define file_tell ftell
87 Lisp_Object Qread_char
, Qget_file_char
, Qstandard_input
, Qcurrent_load_list
;
88 Lisp_Object Qvariable_documentation
, Vvalues
, Vstandard_input
, Vafter_load_alist
;
89 Lisp_Object Qascii_character
, Qload
, Qload_file_name
;
90 Lisp_Object Qbackquote
, Qcomma
, Qcomma_at
, Qcomma_dot
, Qfunction
;
91 Lisp_Object Qinhibit_file_name_operation
;
92 Lisp_Object Qeval_buffer_list
, Veval_buffer_list
;
93 Lisp_Object Qfile_truename
, Qdo_after_load_evaluation
; /* ACM 2006/5/16 */
95 extern Lisp_Object Qevent_symbol_element_mask
;
96 extern Lisp_Object Qfile_exists_p
;
98 /* non-zero if inside `load' */
101 /* Directory in which the sources were found. */
102 Lisp_Object Vsource_directory
;
104 /* Search path and suffixes for files to be loaded. */
105 Lisp_Object Vload_path
, Vload_suffixes
, Vload_file_rep_suffixes
;
107 /* File name of user's init file. */
108 Lisp_Object Vuser_init_file
;
110 /* This is the user-visible association list that maps features to
111 lists of defs in their load files. */
112 Lisp_Object Vload_history
;
114 /* This is used to build the load history. */
115 Lisp_Object Vcurrent_load_list
;
117 /* List of files that were preloaded. */
118 Lisp_Object Vpreloaded_file_list
;
120 /* Name of file actually being read by `load'. */
121 Lisp_Object Vload_file_name
;
123 /* Function to use for reading, in `load' and friends. */
124 Lisp_Object Vload_read_function
;
126 /* The association list of objects read with the #n=object form.
127 Each member of the list has the form (n . object), and is used to
128 look up the object for the corresponding #n# construct.
129 It must be set to nil before all top-level calls to read0. */
130 Lisp_Object read_objects
;
132 /* Nonzero means load should forcibly load all dynamic doc strings. */
133 static int load_force_doc_strings
;
135 /* Nonzero means read should convert strings to unibyte. */
136 static int load_convert_to_unibyte
;
138 /* Function to use for loading an Emacs Lisp source file (not
139 compiled) instead of readevalloop. */
140 Lisp_Object Vload_source_file_function
;
142 /* List of all DEFVAR_BOOL variables. Used by the byte optimizer. */
143 Lisp_Object Vbyte_boolean_vars
;
145 /* Whether or not to add a `read-positions' property to symbols
147 Lisp_Object Vread_with_symbol_positions
;
149 /* List of (SYMBOL . POSITION) accumulated so far. */
150 Lisp_Object Vread_symbol_positions_list
;
152 /* List of descriptors now open for Fload. */
153 static Lisp_Object load_descriptor_list
;
155 /* File for get_file_char to read from. Use by load. */
156 static FILE *instream
;
158 /* When nonzero, read conses in pure space */
159 static int read_pure
;
161 /* For use within read-from-string (this reader is non-reentrant!!) */
162 static int read_from_string_index
;
163 static int read_from_string_index_byte
;
164 static int read_from_string_limit
;
166 /* Number of bytes left to read in the buffer character
167 that `readchar' has already advanced over. */
168 static int readchar_backlog
;
169 /* Number of characters read in the current call to Fread or
170 Fread_from_string. */
171 static int readchar_count
;
173 /* This contains the last string skipped with #@. */
174 static char *saved_doc_string
;
175 /* Length of buffer allocated in saved_doc_string. */
176 static int saved_doc_string_size
;
177 /* Length of actual data in saved_doc_string. */
178 static int saved_doc_string_length
;
179 /* This is the file position that string came from. */
180 static file_offset saved_doc_string_position
;
182 /* This contains the previous string skipped with #@.
183 We copy it from saved_doc_string when a new string
184 is put in saved_doc_string. */
185 static char *prev_saved_doc_string
;
186 /* Length of buffer allocated in prev_saved_doc_string. */
187 static int prev_saved_doc_string_size
;
188 /* Length of actual data in prev_saved_doc_string. */
189 static int prev_saved_doc_string_length
;
190 /* This is the file position that string came from. */
191 static file_offset prev_saved_doc_string_position
;
193 /* Nonzero means inside a new-style backquote
194 with no surrounding parentheses.
195 Fread initializes this to zero, so we need not specbind it
196 or worry about what happens to it when there is an error. */
197 static int new_backquote_flag
;
199 /* A list of file names for files being loaded in Fload. Used to
200 check for recursive loads. */
202 static Lisp_Object Vloads_in_progress
;
204 /* Non-zero means load dangerous compiled Lisp files. */
206 int load_dangerous_libraries
;
208 /* A regular expression used to detect files compiled with Emacs. */
210 static Lisp_Object Vbytecomp_version_regexp
;
212 static void to_multibyte
P_ ((char **, char **, int *));
213 static void readevalloop
P_ ((Lisp_Object
, FILE*, Lisp_Object
,
214 Lisp_Object (*) (), int,
215 Lisp_Object
, Lisp_Object
,
216 Lisp_Object
, Lisp_Object
));
217 static Lisp_Object load_unwind
P_ ((Lisp_Object
));
218 static Lisp_Object load_descriptor_unwind
P_ ((Lisp_Object
));
220 static void invalid_syntax
P_ ((const char *, int)) NO_RETURN
;
221 static void end_of_file_error
P_ (()) NO_RETURN
;
224 /* Handle unreading and rereading of characters.
225 Write READCHAR to read a character,
226 UNREAD(c) to unread c to be read again.
228 The READCHAR and UNREAD macros are meant for reading/unreading a
229 byte code; they do not handle multibyte characters. The caller
230 should manage them if necessary.
232 [ Actually that seems to be a lie; READCHAR will definitely read
233 multibyte characters from buffer sources, at least. Is the
234 comment just out of date?
235 -- Colin Walters <walters@gnu.org>, 22 May 2002 16:36:50 -0400 ]
238 #define READCHAR readchar (readcharfun)
239 #define UNREAD(c) unreadchar (readcharfun, c)
242 readchar (readcharfun
)
243 Lisp_Object readcharfun
;
250 if (BUFFERP (readcharfun
))
252 register struct buffer
*inbuffer
= XBUFFER (readcharfun
);
254 int pt_byte
= BUF_PT_BYTE (inbuffer
);
255 int orig_pt_byte
= pt_byte
;
257 if (readchar_backlog
> 0)
258 /* We get the address of the byte just passed,
259 which is the last byte of the character.
260 The other bytes in this character are consecutive with it,
261 because the gap can't be in the middle of a character. */
262 return *(BUF_BYTE_ADDRESS (inbuffer
, BUF_PT_BYTE (inbuffer
) - 1)
263 - --readchar_backlog
);
265 if (pt_byte
>= BUF_ZV_BYTE (inbuffer
))
268 readchar_backlog
= -1;
270 if (! NILP (inbuffer
->enable_multibyte_characters
))
272 /* Fetch the character code from the buffer. */
273 unsigned char *p
= BUF_BYTE_ADDRESS (inbuffer
, pt_byte
);
274 BUF_INC_POS (inbuffer
, pt_byte
);
275 c
= STRING_CHAR (p
, pt_byte
- orig_pt_byte
);
279 c
= BUF_FETCH_BYTE (inbuffer
, pt_byte
);
282 SET_BUF_PT_BOTH (inbuffer
, BUF_PT (inbuffer
) + 1, pt_byte
);
286 if (MARKERP (readcharfun
))
288 register struct buffer
*inbuffer
= XMARKER (readcharfun
)->buffer
;
290 int bytepos
= marker_byte_position (readcharfun
);
291 int orig_bytepos
= bytepos
;
293 if (readchar_backlog
> 0)
294 /* We get the address of the byte just passed,
295 which is the last byte of the character.
296 The other bytes in this character are consecutive with it,
297 because the gap can't be in the middle of a character. */
298 return *(BUF_BYTE_ADDRESS (inbuffer
, XMARKER (readcharfun
)->bytepos
- 1)
299 - --readchar_backlog
);
301 if (bytepos
>= BUF_ZV_BYTE (inbuffer
))
304 readchar_backlog
= -1;
306 if (! NILP (inbuffer
->enable_multibyte_characters
))
308 /* Fetch the character code from the buffer. */
309 unsigned char *p
= BUF_BYTE_ADDRESS (inbuffer
, bytepos
);
310 BUF_INC_POS (inbuffer
, bytepos
);
311 c
= STRING_CHAR (p
, bytepos
- orig_bytepos
);
315 c
= BUF_FETCH_BYTE (inbuffer
, bytepos
);
319 XMARKER (readcharfun
)->bytepos
= bytepos
;
320 XMARKER (readcharfun
)->charpos
++;
325 if (EQ (readcharfun
, Qlambda
))
326 return read_bytecode_char (0);
328 if (EQ (readcharfun
, Qget_file_char
))
333 /* Interrupted reads have been observed while reading over the network */
334 while (c
== EOF
&& ferror (instream
) && errno
== EINTR
)
347 if (STRINGP (readcharfun
))
349 if (read_from_string_index
>= read_from_string_limit
)
352 FETCH_STRING_CHAR_ADVANCE (c
, readcharfun
,
353 read_from_string_index
,
354 read_from_string_index_byte
);
359 tem
= call0 (readcharfun
);
366 /* Unread the character C in the way appropriate for the stream READCHARFUN.
367 If the stream is a user function, call it with the char as argument. */
370 unreadchar (readcharfun
, c
)
371 Lisp_Object readcharfun
;
376 /* Don't back up the pointer if we're unreading the end-of-input mark,
377 since readchar didn't advance it when we read it. */
379 else if (BUFFERP (readcharfun
))
381 struct buffer
*b
= XBUFFER (readcharfun
);
382 int bytepos
= BUF_PT_BYTE (b
);
384 if (readchar_backlog
>= 0)
389 if (! NILP (b
->enable_multibyte_characters
))
390 BUF_DEC_POS (b
, bytepos
);
394 BUF_PT_BYTE (b
) = bytepos
;
397 else if (MARKERP (readcharfun
))
399 struct buffer
*b
= XMARKER (readcharfun
)->buffer
;
400 int bytepos
= XMARKER (readcharfun
)->bytepos
;
402 if (readchar_backlog
>= 0)
406 XMARKER (readcharfun
)->charpos
--;
407 if (! NILP (b
->enable_multibyte_characters
))
408 BUF_DEC_POS (b
, bytepos
);
412 XMARKER (readcharfun
)->bytepos
= bytepos
;
415 else if (STRINGP (readcharfun
))
417 read_from_string_index
--;
418 read_from_string_index_byte
419 = string_char_to_byte (readcharfun
, read_from_string_index
);
421 else if (EQ (readcharfun
, Qlambda
))
422 read_bytecode_char (1);
423 else if (EQ (readcharfun
, Qget_file_char
))
426 ungetc (c
, instream
);
430 call1 (readcharfun
, make_number (c
));
433 static Lisp_Object read_internal_start
P_ ((Lisp_Object
, Lisp_Object
,
435 static Lisp_Object read0
P_ ((Lisp_Object
));
436 static Lisp_Object read1
P_ ((Lisp_Object
, int *, int));
438 static Lisp_Object read_list
P_ ((int, Lisp_Object
));
439 static Lisp_Object read_vector
P_ ((Lisp_Object
, int));
440 static int read_multibyte
P_ ((int, Lisp_Object
));
442 static Lisp_Object substitute_object_recurse
P_ ((Lisp_Object
, Lisp_Object
,
444 static void substitute_object_in_subtree
P_ ((Lisp_Object
,
446 static void substitute_in_interval
P_ ((INTERVAL
, Lisp_Object
));
449 /* Get a character from the tty. */
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. */
505 val
= read_char (0, 0, 0, (input_method
? Qnil
: Qt
), 0,
506 NUMBERP (seconds
) ? &end_time
: NULL
);
507 while (INTEGERP (val
) && XINT (val
) == -2); /* wrong_kboard_jmpbuf */
512 /* switch-frame events are put off until after the next ASCII
513 character. This is better than signaling an error just because
514 the last characters were typed to a separate minibuffer frame,
515 for example. Eventually, some code which can deal with
516 switch-frame events will read it and process it. */
518 && EVENT_HAS_PARAMETERS (val
)
519 && EQ (EVENT_HEAD_KIND (EVENT_HEAD (val
)), Qswitch_frame
))
521 delayed_switch_frame
= val
;
525 if (ascii_required
&& !(NUMBERP (seconds
) && NILP (val
)))
527 /* Convert certain symbols to their ASCII equivalents. */
530 Lisp_Object tem
, tem1
;
531 tem
= Fget (val
, Qevent_symbol_element_mask
);
534 tem1
= Fget (Fcar (tem
), Qascii_character
);
535 /* Merge this symbol's modifier bits
536 with the ASCII equivalent of its basic code. */
538 XSETFASTINT (val
, XINT (tem1
) | XINT (Fcar (Fcdr (tem
))));
542 /* If we don't have a character now, deal with it appropriately. */
547 Vunread_command_events
= Fcons (val
, Qnil
);
548 error ("Non-character input-event");
555 if (! NILP (delayed_switch_frame
))
556 unread_switch_frame
= delayed_switch_frame
;
560 #ifdef HAVE_WINDOW_SYSTEM
561 if (display_hourglass_p
)
570 DEFUN ("read-char", Fread_char
, Sread_char
, 0, 3, 0,
571 doc
: /* Read a character from the command input (keyboard or macro).
572 It is returned as a number.
573 If the user generates an event which is not a character (i.e. a mouse
574 click or function key event), `read-char' signals an error. As an
575 exception, switch-frame events are put off until non-ASCII events can
577 If you want to read non-character events, or ignore them, call
578 `read-event' or `read-char-exclusive' instead.
580 If the optional argument PROMPT is non-nil, display that as a prompt.
581 If the optional argument INHERIT-INPUT-METHOD is non-nil and some
582 input method is turned on in the current buffer, that input method
583 is used for reading a character.
584 If the optional argument SECONDS is non-nil, it should be a number
585 specifying the maximum number of seconds to wait for input. If no
586 input arrives in that time, return nil. SECONDS may be a
587 floating-point value. */)
588 (prompt
, inherit_input_method
, seconds
)
589 Lisp_Object prompt
, inherit_input_method
, seconds
;
592 message_with_string ("%s", prompt
, 0);
593 return read_filtered_event (1, 1, 1, ! NILP (inherit_input_method
), seconds
);
596 DEFUN ("read-event", Fread_event
, Sread_event
, 0, 3, 0,
597 doc
: /* Read an event object from the input stream.
598 If the optional argument PROMPT is non-nil, display that as a prompt.
599 If the optional argument INHERIT-INPUT-METHOD is non-nil and some
600 input method is turned on in the current buffer, that input method
601 is used for reading a character.
602 If the optional argument SECONDS is non-nil, it should be a number
603 specifying the maximum number of seconds to wait for input. If no
604 input arrives in that time, return nil. SECONDS may be a
605 floating-point value. */)
606 (prompt
, inherit_input_method
, seconds
)
607 Lisp_Object prompt
, inherit_input_method
, seconds
;
610 message_with_string ("%s", prompt
, 0);
611 return read_filtered_event (0, 0, 0, ! NILP (inherit_input_method
), seconds
);
614 DEFUN ("read-char-exclusive", Fread_char_exclusive
, Sread_char_exclusive
, 0, 3, 0,
615 doc
: /* Read a character from the command input (keyboard or macro).
616 It is returned as a number. Non-character events are ignored.
618 If the optional argument PROMPT is non-nil, display that as a prompt.
619 If the optional argument INHERIT-INPUT-METHOD is non-nil and some
620 input method is turned on in the current buffer, that input method
621 is used for reading a character.
622 If the optional argument SECONDS is non-nil, it should be a number
623 specifying the maximum number of seconds to wait for input. If no
624 input arrives in that time, return nil. SECONDS may be a
625 floating-point value. */)
626 (prompt
, inherit_input_method
, seconds
)
627 Lisp_Object prompt
, inherit_input_method
, seconds
;
630 message_with_string ("%s", prompt
, 0);
631 return read_filtered_event (1, 1, 0, ! NILP (inherit_input_method
), seconds
);
634 DEFUN ("get-file-char", Fget_file_char
, Sget_file_char
, 0, 0, 0,
635 doc
: /* Don't use this yourself. */)
638 register Lisp_Object val
;
640 XSETINT (val
, getc (instream
));
647 /* Value is non-zero if the file asswociated with file descriptor FD
648 is a compiled Lisp file that's safe to load. Only files compiled
649 with Emacs are safe to load. Files compiled with XEmacs can lead
650 to a crash in Fbyte_code because of an incompatible change in the
661 /* Read the first few bytes from the file, and look for a line
662 specifying the byte compiler version used. */
663 nbytes
= emacs_read (fd
, buf
, sizeof buf
- 1);
668 /* Skip to the next newline, skipping over the initial `ELC'
669 with NUL bytes following it. */
670 for (i
= 0; i
< nbytes
&& buf
[i
] != '\n'; ++i
)
674 && fast_c_string_match_ignore_case (Vbytecomp_version_regexp
,
679 lseek (fd
, 0, SEEK_SET
);
684 /* Callback for record_unwind_protect. Restore the old load list OLD,
685 after loading a file successfully. */
688 record_load_unwind (old
)
691 return Vloads_in_progress
= old
;
694 /* This handler function is used via internal_condition_case_1. */
697 load_error_handler (data
)
703 DEFUN ("get-load-suffixes", Fget_load_suffixes
, Sget_load_suffixes
, 0, 0, 0,
704 doc
: /* Return the suffixes that `load' should try if a suffix is \
706 This uses the variables `load-suffixes' and `load-file-rep-suffixes'. */)
709 Lisp_Object lst
= Qnil
, suffixes
= Vload_suffixes
, suffix
, ext
;
710 while (CONSP (suffixes
))
712 Lisp_Object exts
= Vload_file_rep_suffixes
;
713 suffix
= XCAR (suffixes
);
714 suffixes
= XCDR (suffixes
);
719 lst
= Fcons (concat2 (suffix
, ext
), lst
);
722 return Fnreverse (lst
);
725 DEFUN ("load", Fload
, Sload
, 1, 5, 0,
726 doc
: /* Execute a file of Lisp code named FILE.
727 First try FILE with `.elc' appended, then try with `.el',
728 then try FILE unmodified (the exact suffixes in the exact order are
729 determined by `load-suffixes'). Environment variable references in
730 FILE are replaced with their values by calling `substitute-in-file-name'.
731 This function searches the directories in `load-path'.
733 If optional second arg NOERROR is non-nil,
734 report no error if FILE doesn't exist.
735 Print messages at start and end of loading unless
736 optional third arg NOMESSAGE is non-nil.
737 If optional fourth arg NOSUFFIX is non-nil, don't try adding
738 suffixes `.elc' or `.el' to the specified name FILE.
739 If optional fifth arg MUST-SUFFIX is non-nil, insist on
740 the suffix `.elc' or `.el'; don't accept just FILE unless
741 it ends in one of those suffixes or includes a directory name.
743 If this function fails to find a file, it may look for different
744 representations of that file before trying another file.
745 It does so by adding the non-empty suffixes in `load-file-rep-suffixes'
746 to the file name. Emacs uses this feature mainly to find compressed
747 versions of files when Auto Compression mode is enabled.
749 The exact suffixes that this function tries out, in the exact order,
750 are given by the value of the variable `load-file-rep-suffixes' if
751 NOSUFFIX is non-nil and by the return value of the function
752 `get-load-suffixes' if MUST-SUFFIX is non-nil. If both NOSUFFIX and
753 MUST-SUFFIX are nil, this function first tries out the latter suffixes
756 Loading a file records its definitions, and its `provide' and
757 `require' calls, in an element of `load-history' whose
758 car is the file name loaded. See `load-history'.
760 Return t if the file exists and loads successfully. */)
761 (file
, noerror
, nomessage
, nosuffix
, must_suffix
)
762 Lisp_Object file
, noerror
, nomessage
, nosuffix
, must_suffix
;
764 register FILE *stream
;
765 register int fd
= -1;
766 int count
= SPECPDL_INDEX ();
768 struct gcpro gcpro1
, gcpro2
, gcpro3
;
769 Lisp_Object found
, efound
, hist_file_name
;
770 /* 1 means we printed the ".el is newer" message. */
772 /* 1 means we are loading a compiled file. */
784 /* If file name is magic, call the handler. */
785 /* This shouldn't be necessary any more now that `openp' handles it right.
786 handler = Ffind_file_name_handler (file, Qload);
788 return call5 (handler, Qload, file, noerror, nomessage, nosuffix); */
790 /* Do this after the handler to avoid
791 the need to gcpro noerror, nomessage and nosuffix.
792 (Below here, we care only whether they are nil or not.)
793 The presence of this call is the result of a historical accident:
794 it used to be in every file-operation and when it got removed
795 everywhere, it accidentally stayed here. Since then, enough people
796 supposedly have things like (load "$PROJECT/foo.el") in their .emacs
797 that it seemed risky to remove. */
798 if (! NILP (noerror
))
800 file
= internal_condition_case_1 (Fsubstitute_in_file_name
, file
,
801 Qt
, load_error_handler
);
806 file
= Fsubstitute_in_file_name (file
);
809 /* Avoid weird lossage with null string as arg,
810 since it would try to load a directory as a Lisp file */
811 if (SCHARS (file
) > 0)
813 int size
= SBYTES (file
);
816 GCPRO2 (file
, found
);
818 if (! NILP (must_suffix
))
820 /* Don't insist on adding a suffix if FILE already ends with one. */
822 && !strcmp (SDATA (file
) + size
- 3, ".el"))
825 && !strcmp (SDATA (file
) + size
- 4, ".elc"))
827 /* Don't insist on adding a suffix
828 if the argument includes a directory name. */
829 else if (! NILP (Ffile_name_directory (file
)))
833 fd
= openp (Vload_path
, file
,
834 (!NILP (nosuffix
) ? Qnil
835 : !NILP (must_suffix
) ? Fget_load_suffixes ()
836 : Fappend (2, (tmp
[0] = Fget_load_suffixes (),
837 tmp
[1] = Vload_file_rep_suffixes
,
846 xsignal2 (Qfile_error
, build_string ("Cannot open load file"), file
);
850 /* Tell startup.el whether or not we found the user's init file. */
851 if (EQ (Qt
, Vuser_init_file
))
852 Vuser_init_file
= found
;
854 /* If FD is -2, that means openp found a magic file. */
857 if (NILP (Fequal (found
, file
)))
858 /* If FOUND is a different file name from FILE,
859 find its handler even if we have already inhibited
860 the `load' operation on FILE. */
861 handler
= Ffind_file_name_handler (found
, Qt
);
863 handler
= Ffind_file_name_handler (found
, Qload
);
864 if (! NILP (handler
))
865 return call5 (handler
, Qload
, found
, noerror
, nomessage
, Qt
);
868 /* Check if we're stuck in a recursive load cycle.
870 2000-09-21: It's not possible to just check for the file loaded
871 being a member of Vloads_in_progress. This fails because of the
872 way the byte compiler currently works; `provide's are not
873 evaluted, see font-lock.el/jit-lock.el as an example. This
874 leads to a certain amount of ``normal'' recursion.
876 Also, just loading a file recursively is not always an error in
877 the general case; the second load may do something different. */
881 for (tem
= Vloads_in_progress
; CONSP (tem
); tem
= XCDR (tem
))
882 if (!NILP (Fequal (found
, XCAR (tem
))))
888 signal_error ("Recursive load", Fcons (found
, Vloads_in_progress
));
890 record_unwind_protect (record_load_unwind
, Vloads_in_progress
);
891 Vloads_in_progress
= Fcons (found
, Vloads_in_progress
);
894 /* Get the name for load-history. */
895 hist_file_name
= (! NILP (Vpurify_flag
)
896 ? Fconcat (2, (tmp
[0] = Ffile_name_directory (file
),
897 tmp
[1] = Ffile_name_nondirectory (found
),
901 if (!bcmp (SDATA (found
) + SBYTES (found
) - 4,
903 /* Load .elc files directly, but not when they are
904 remote and have no handler! */
911 GCPRO3 (file
, found
, hist_file_name
);
913 if (!safe_to_load_p (fd
))
916 if (!load_dangerous_libraries
)
920 error ("File `%s' was not compiled in Emacs",
923 else if (!NILP (nomessage
))
924 message_with_string ("File `%s' not compiled in Emacs", found
, 1);
929 efound
= ENCODE_FILE (found
);
934 stat ((char *)SDATA (efound
), &s1
);
935 SSET (efound
, SBYTES (efound
) - 1, 0);
936 result
= stat ((char *)SDATA (efound
), &s2
);
937 SSET (efound
, SBYTES (efound
) - 1, 'c');
939 if (result
>= 0 && (unsigned) s1
.st_mtime
< (unsigned) s2
.st_mtime
)
941 /* Make the progress messages mention that source is newer. */
944 /* If we won't print another message, mention this anyway. */
945 if (!NILP (nomessage
))
947 Lisp_Object msg_file
;
948 msg_file
= Fsubstring (found
, make_number (0), make_number (-1));
949 message_with_string ("Source file `%s' newer than byte-compiled file",
958 /* We are loading a source file (*.el). */
959 if (!NILP (Vload_source_file_function
))
965 val
= call4 (Vload_source_file_function
, found
, hist_file_name
,
966 NILP (noerror
) ? Qnil
: Qt
,
967 NILP (nomessage
) ? Qnil
: Qt
);
968 return unbind_to (count
, val
);
972 GCPRO3 (file
, found
, hist_file_name
);
976 efound
= ENCODE_FILE (found
);
977 stream
= fopen ((char *) SDATA (efound
), fmode
);
978 #else /* not WINDOWSNT */
979 stream
= fdopen (fd
, fmode
);
980 #endif /* not WINDOWSNT */
984 error ("Failure to create stdio stream for %s", SDATA (file
));
987 if (! NILP (Vpurify_flag
))
988 Vpreloaded_file_list
= Fcons (file
, Vpreloaded_file_list
);
990 if (NILP (nomessage
))
993 message_with_string ("Loading %s (compiled; note unsafe, not compiled in Emacs)...",
996 message_with_string ("Loading %s (source)...", file
, 1);
998 message_with_string ("Loading %s (compiled; note, source file is newer)...",
1000 else /* The typical case; compiled file newer than source file. */
1001 message_with_string ("Loading %s...", file
, 1);
1004 record_unwind_protect (load_unwind
, make_save_value (stream
, 0));
1005 record_unwind_protect (load_descriptor_unwind
, load_descriptor_list
);
1006 specbind (Qload_file_name
, found
);
1007 specbind (Qinhibit_file_name_operation
, Qnil
);
1008 load_descriptor_list
1009 = Fcons (make_number (fileno (stream
)), load_descriptor_list
);
1011 readevalloop (Qget_file_char
, stream
, hist_file_name
,
1012 Feval
, 0, Qnil
, Qnil
, Qnil
, Qnil
);
1013 unbind_to (count
, Qnil
);
1015 /* Run any eval-after-load forms for this file */
1016 if (NILP (Vpurify_flag
)
1017 && (!NILP (Ffboundp (Qdo_after_load_evaluation
))))
1018 call1 (Qdo_after_load_evaluation
, hist_file_name
) ;
1022 if (saved_doc_string
)
1023 free (saved_doc_string
);
1024 saved_doc_string
= 0;
1025 saved_doc_string_size
= 0;
1027 if (prev_saved_doc_string
)
1028 xfree (prev_saved_doc_string
);
1029 prev_saved_doc_string
= 0;
1030 prev_saved_doc_string_size
= 0;
1032 if (!noninteractive
&& NILP (nomessage
))
1035 message_with_string ("Loading %s (compiled; note unsafe, not compiled in Emacs)...done",
1038 message_with_string ("Loading %s (source)...done", file
, 1);
1040 message_with_string ("Loading %s (compiled; note, source file is newer)...done",
1042 else /* The typical case; compiled file newer than source file. */
1043 message_with_string ("Loading %s...done", file
, 1);
1046 if (!NILP (Fequal (build_string ("obsolete"),
1047 Ffile_name_nondirectory
1048 (Fdirectory_file_name (Ffile_name_directory (found
))))))
1049 message_with_string ("Package %s is obsolete", file
, 1);
1055 load_unwind (arg
) /* used as unwind-protect function in load */
1058 FILE *stream
= (FILE *) XSAVE_VALUE (arg
)->pointer
;
1065 if (--load_in_progress
< 0) load_in_progress
= 0;
1070 load_descriptor_unwind (oldlist
)
1071 Lisp_Object oldlist
;
1073 load_descriptor_list
= oldlist
;
1077 /* Close all descriptors in use for Floads.
1078 This is used when starting a subprocess. */
1085 for (tail
= load_descriptor_list
; !NILP (tail
); tail
= XCDR (tail
))
1086 emacs_close (XFASTINT (XCAR (tail
)));
1091 complete_filename_p (pathname
)
1092 Lisp_Object pathname
;
1094 register const unsigned char *s
= SDATA (pathname
);
1095 return (IS_DIRECTORY_SEP (s
[0])
1096 || (SCHARS (pathname
) > 2
1097 && IS_DEVICE_SEP (s
[1]) && IS_DIRECTORY_SEP (s
[2]))
1107 DEFUN ("locate-file-internal", Flocate_file_internal
, Slocate_file_internal
, 2, 4, 0,
1108 doc
: /* Search for FILENAME through PATH.
1109 Returns the file's name in absolute form, or nil if not found.
1110 If SUFFIXES is non-nil, it should be a list of suffixes to append to
1111 file name when searching.
1112 If non-nil, PREDICATE is used instead of `file-readable-p'.
1113 PREDICATE can also be an integer to pass to the access(2) function,
1114 in which case file-name-handlers are ignored. */)
1115 (filename
, path
, suffixes
, predicate
)
1116 Lisp_Object filename
, path
, suffixes
, predicate
;
1119 int fd
= openp (path
, filename
, suffixes
, &file
, predicate
);
1120 if (NILP (predicate
) && fd
> 0)
1126 /* Search for a file whose name is STR, looking in directories
1127 in the Lisp list PATH, and trying suffixes from SUFFIX.
1128 On success, returns a file descriptor. On failure, returns -1.
1130 SUFFIXES is a list of strings containing possible suffixes.
1131 The empty suffix is automatically added if the list is empty.
1133 PREDICATE non-nil means don't open the files,
1134 just look for one that satisfies the predicate. In this case,
1135 returns 1 on success. The predicate can be a lisp function or
1136 an integer to pass to `access' (in which case file-name-handlers
1139 If STOREPTR is nonzero, it points to a slot where the name of
1140 the file actually found should be stored as a Lisp string.
1141 nil is stored there on failure.
1143 If the file we find is remote, return -2
1144 but store the found remote file name in *STOREPTR. */
1147 openp (path
, str
, suffixes
, storeptr
, predicate
)
1148 Lisp_Object path
, str
;
1149 Lisp_Object suffixes
;
1150 Lisp_Object
*storeptr
;
1151 Lisp_Object predicate
;
1156 register char *fn
= buf
;
1159 Lisp_Object filename
;
1161 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
, gcpro5
, gcpro6
;
1162 Lisp_Object string
, tail
, encoded_fn
;
1163 int max_suffix_len
= 0;
1167 for (tail
= suffixes
; CONSP (tail
); tail
= XCDR (tail
))
1169 CHECK_STRING_CAR (tail
);
1170 max_suffix_len
= max (max_suffix_len
,
1171 SBYTES (XCAR (tail
)));
1174 string
= filename
= encoded_fn
= Qnil
;
1175 GCPRO6 (str
, string
, filename
, path
, suffixes
, encoded_fn
);
1180 if (complete_filename_p (str
))
1183 for (; CONSP (path
); path
= XCDR (path
))
1185 filename
= Fexpand_file_name (str
, XCAR (path
));
1186 if (!complete_filename_p (filename
))
1187 /* If there are non-absolute elts in PATH (eg ".") */
1188 /* Of course, this could conceivably lose if luser sets
1189 default-directory to be something non-absolute... */
1191 filename
= Fexpand_file_name (filename
, current_buffer
->directory
);
1192 if (!complete_filename_p (filename
))
1193 /* Give up on this path element! */
1197 /* Calculate maximum size of any filename made from
1198 this path element/specified file name and any possible suffix. */
1199 want_size
= max_suffix_len
+ SBYTES (filename
) + 1;
1200 if (fn_size
< want_size
)
1201 fn
= (char *) alloca (fn_size
= 100 + want_size
);
1203 /* Loop over suffixes. */
1204 for (tail
= NILP (suffixes
) ? Fcons (empty_unibyte_string
, Qnil
) : suffixes
;
1205 CONSP (tail
); tail
= XCDR (tail
))
1207 int lsuffix
= SBYTES (XCAR (tail
));
1208 Lisp_Object handler
;
1211 /* Concatenate path element/specified name with the suffix.
1212 If the directory starts with /:, remove that. */
1213 if (SCHARS (filename
) > 2
1214 && SREF (filename
, 0) == '/'
1215 && SREF (filename
, 1) == ':')
1217 strncpy (fn
, SDATA (filename
) + 2,
1218 SBYTES (filename
) - 2);
1219 fn
[SBYTES (filename
) - 2] = 0;
1223 strncpy (fn
, SDATA (filename
),
1225 fn
[SBYTES (filename
)] = 0;
1228 if (lsuffix
!= 0) /* Bug happens on CCI if lsuffix is 0. */
1229 strncat (fn
, SDATA (XCAR (tail
)), lsuffix
);
1231 /* Check that the file exists and is not a directory. */
1232 /* We used to only check for handlers on non-absolute file names:
1236 handler = Ffind_file_name_handler (filename, Qfile_exists_p);
1237 It's not clear why that was the case and it breaks things like
1238 (load "/bar.el") where the file is actually "/bar.el.gz". */
1239 string
= build_string (fn
);
1240 handler
= Ffind_file_name_handler (string
, Qfile_exists_p
);
1241 if ((!NILP (handler
) || !NILP (predicate
)) && !NATNUMP (predicate
))
1243 if (NILP (predicate
))
1244 exists
= !NILP (Ffile_readable_p (string
));
1246 exists
= !NILP (call1 (predicate
, string
));
1247 if (exists
&& !NILP (Ffile_directory_p (string
)))
1252 /* We succeeded; return this descriptor and filename. */
1263 encoded_fn
= ENCODE_FILE (string
);
1264 pfn
= SDATA (encoded_fn
);
1265 exists
= (stat (pfn
, &st
) >= 0
1266 && (st
.st_mode
& S_IFMT
) != S_IFDIR
);
1269 /* Check that we can access or open it. */
1270 if (NATNUMP (predicate
))
1271 fd
= (access (pfn
, XFASTINT (predicate
)) == 0) ? 1 : -1;
1273 fd
= emacs_open (pfn
, O_RDONLY
, 0);
1277 /* We succeeded; return this descriptor and filename. */
1295 /* Merge the list we've accumulated of globals from the current input source
1296 into the load_history variable. The details depend on whether
1297 the source has an associated file name or not.
1299 FILENAME is the file name that we are loading from.
1300 ENTIRE is 1 if loading that entire file, 0 if evaluating part of it. */
1303 build_load_history (filename
, entire
)
1304 Lisp_Object filename
;
1307 register Lisp_Object tail
, prev
, newelt
;
1308 register Lisp_Object tem
, tem2
;
1309 register int foundit
= 0;
1311 tail
= Vload_history
;
1314 while (CONSP (tail
))
1318 /* Find the feature's previous assoc list... */
1319 if (!NILP (Fequal (filename
, Fcar (tem
))))
1323 /* If we're loading the entire file, remove old data. */
1327 Vload_history
= XCDR (tail
);
1329 Fsetcdr (prev
, XCDR (tail
));
1332 /* Otherwise, cons on new symbols that are not already members. */
1335 tem2
= Vcurrent_load_list
;
1337 while (CONSP (tem2
))
1339 newelt
= XCAR (tem2
);
1341 if (NILP (Fmember (newelt
, tem
)))
1342 Fsetcar (tail
, Fcons (XCAR (tem
),
1343 Fcons (newelt
, XCDR (tem
))));
1356 /* If we're loading an entire file, cons the new assoc onto the
1357 front of load-history, the most-recently-loaded position. Also
1358 do this if we didn't find an existing member for the file. */
1359 if (entire
|| !foundit
)
1360 Vload_history
= Fcons (Fnreverse (Vcurrent_load_list
),
1365 unreadpure (junk
) /* Used as unwind-protect function in readevalloop */
1373 readevalloop_1 (old
)
1376 load_convert_to_unibyte
= ! NILP (old
);
1380 /* Signal an `end-of-file' error, if possible with file name
1384 end_of_file_error ()
1388 if (STRINGP (Vload_file_name
))
1389 xsignal1 (Qend_of_file
, Vload_file_name
);
1391 xsignal0 (Qend_of_file
);
1394 /* UNIBYTE specifies how to set load_convert_to_unibyte
1395 for this invocation.
1396 READFUN, if non-nil, is used instead of `read'.
1398 START, END specify region to read in current buffer (from eval-region).
1399 If the input is not from a buffer, they must be nil. */
1402 readevalloop (readcharfun
, stream
, sourcename
, evalfun
,
1403 printflag
, unibyte
, readfun
, start
, end
)
1404 Lisp_Object readcharfun
;
1406 Lisp_Object sourcename
;
1407 Lisp_Object (*evalfun
) ();
1409 Lisp_Object unibyte
, readfun
;
1410 Lisp_Object start
, end
;
1413 register Lisp_Object val
;
1414 int count
= SPECPDL_INDEX ();
1415 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1416 struct buffer
*b
= 0;
1417 int continue_reading_p
;
1418 /* Nonzero if reading an entire buffer. */
1419 int whole_buffer
= 0;
1420 /* 1 on the first time around. */
1423 if (MARKERP (readcharfun
))
1426 start
= readcharfun
;
1429 if (BUFFERP (readcharfun
))
1430 b
= XBUFFER (readcharfun
);
1431 else if (MARKERP (readcharfun
))
1432 b
= XMARKER (readcharfun
)->buffer
;
1434 /* We assume START is nil when input is not from a buffer. */
1435 if (! NILP (start
) && !b
)
1438 specbind (Qstandard_input
, readcharfun
); /* GCPROs readcharfun. */
1439 specbind (Qcurrent_load_list
, Qnil
);
1440 record_unwind_protect (readevalloop_1
, load_convert_to_unibyte
? Qt
: Qnil
);
1441 load_convert_to_unibyte
= !NILP (unibyte
);
1443 readchar_backlog
= -1;
1445 GCPRO4 (sourcename
, readfun
, start
, end
);
1447 /* Try to ensure sourcename is a truename, except whilst preloading. */
1448 if (NILP (Vpurify_flag
)
1449 && !NILP (sourcename
) && !NILP (Ffile_name_absolute_p (sourcename
))
1450 && !NILP (Ffboundp (Qfile_truename
)))
1451 sourcename
= call1 (Qfile_truename
, sourcename
) ;
1453 LOADHIST_ATTACH (sourcename
);
1455 continue_reading_p
= 1;
1456 while (continue_reading_p
)
1458 int count1
= SPECPDL_INDEX ();
1460 if (b
!= 0 && NILP (b
->name
))
1461 error ("Reading from killed buffer");
1465 /* Switch to the buffer we are reading from. */
1466 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
1467 set_buffer_internal (b
);
1469 /* Save point in it. */
1470 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
1471 /* Save ZV in it. */
1472 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
1473 /* Those get unbound after we read one expression. */
1475 /* Set point and ZV around stuff to be read. */
1478 Fnarrow_to_region (make_number (BEGV
), end
);
1480 /* Just for cleanliness, convert END to a marker
1481 if it is an integer. */
1483 end
= Fpoint_max_marker ();
1486 /* On the first cycle, we can easily test here
1487 whether we are reading the whole buffer. */
1488 if (b
&& first_sexp
)
1489 whole_buffer
= (PT
== BEG
&& ZV
== Z
);
1496 while ((c
= READCHAR
) != '\n' && c
!= -1);
1501 unbind_to (count1
, Qnil
);
1505 /* Ignore whitespace here, so we can detect eof. */
1506 if (c
== ' ' || c
== '\t' || c
== '\n' || c
== '\f' || c
== '\r'
1507 || c
== 0x8a0) /* NBSP */
1510 if (!NILP (Vpurify_flag
) && c
== '(')
1512 record_unwind_protect (unreadpure
, Qnil
);
1513 val
= read_list (-1, readcharfun
);
1518 read_objects
= Qnil
;
1519 if (!NILP (readfun
))
1521 val
= call1 (readfun
, readcharfun
);
1523 /* If READCHARFUN has set point to ZV, we should
1524 stop reading, even if the form read sets point
1525 to a different value when evaluated. */
1526 if (BUFFERP (readcharfun
))
1528 struct buffer
*b
= XBUFFER (readcharfun
);
1529 if (BUF_PT (b
) == BUF_ZV (b
))
1530 continue_reading_p
= 0;
1533 else if (! NILP (Vload_read_function
))
1534 val
= call1 (Vload_read_function
, readcharfun
);
1536 val
= read_internal_start (readcharfun
, Qnil
, Qnil
);
1539 if (!NILP (start
) && continue_reading_p
)
1540 start
= Fpoint_marker ();
1542 /* Restore saved point and BEGV. */
1543 unbind_to (count1
, Qnil
);
1545 /* Now eval what we just read. */
1546 val
= (*evalfun
) (val
);
1550 Vvalues
= Fcons (val
, Vvalues
);
1551 if (EQ (Vstandard_output
, Qt
))
1560 build_load_history (sourcename
,
1561 stream
|| whole_buffer
);
1565 unbind_to (count
, Qnil
);
1568 DEFUN ("eval-buffer", Feval_buffer
, Seval_buffer
, 0, 5, "",
1569 doc
: /* Execute the current buffer as Lisp code.
1570 Programs can pass two arguments, BUFFER and PRINTFLAG.
1571 BUFFER is the buffer to evaluate (nil means use current buffer).
1572 PRINTFLAG controls printing of output:
1573 A value of nil means discard it; anything else is stream for print.
1575 If the optional third argument FILENAME is non-nil,
1576 it specifies the file name to use for `load-history'.
1577 The optional fourth argument UNIBYTE specifies `load-convert-to-unibyte'
1578 for this invocation.
1580 The optional fifth argument DO-ALLOW-PRINT, if non-nil, specifies that
1581 `print' and related functions should work normally even if PRINTFLAG is nil.
1583 This function preserves the position of point. */)
1584 (buffer
, printflag
, filename
, unibyte
, do_allow_print
)
1585 Lisp_Object buffer
, printflag
, filename
, unibyte
, do_allow_print
;
1587 int count
= SPECPDL_INDEX ();
1588 Lisp_Object tem
, buf
;
1591 buf
= Fcurrent_buffer ();
1593 buf
= Fget_buffer (buffer
);
1595 error ("No such buffer");
1597 if (NILP (printflag
) && NILP (do_allow_print
))
1602 if (NILP (filename
))
1603 filename
= XBUFFER (buf
)->filename
;
1605 specbind (Qeval_buffer_list
, Fcons (buf
, Veval_buffer_list
));
1606 specbind (Qstandard_output
, tem
);
1607 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
1608 BUF_SET_PT (XBUFFER (buf
), BUF_BEGV (XBUFFER (buf
)));
1609 readevalloop (buf
, 0, filename
, Feval
,
1610 !NILP (printflag
), unibyte
, Qnil
, Qnil
, Qnil
);
1611 unbind_to (count
, Qnil
);
1616 DEFUN ("eval-region", Feval_region
, Seval_region
, 2, 4, "r",
1617 doc
: /* Execute the region as Lisp code.
1618 When called from programs, expects two arguments,
1619 giving starting and ending indices in the current buffer
1620 of the text to be executed.
1621 Programs can pass third argument PRINTFLAG which controls output:
1622 A value of nil means discard it; anything else is stream for printing it.
1623 Also the fourth argument READ-FUNCTION, if non-nil, is used
1624 instead of `read' to read each expression. It gets one argument
1625 which is the input stream for reading characters.
1627 This function does not move point. */)
1628 (start
, end
, printflag
, read_function
)
1629 Lisp_Object start
, end
, printflag
, read_function
;
1631 int count
= SPECPDL_INDEX ();
1632 Lisp_Object tem
, cbuf
;
1634 cbuf
= Fcurrent_buffer ();
1636 if (NILP (printflag
))
1640 specbind (Qstandard_output
, tem
);
1641 specbind (Qeval_buffer_list
, Fcons (cbuf
, Veval_buffer_list
));
1643 /* readevalloop calls functions which check the type of start and end. */
1644 readevalloop (cbuf
, 0, XBUFFER (cbuf
)->filename
, Feval
,
1645 !NILP (printflag
), Qnil
, read_function
,
1648 return unbind_to (count
, Qnil
);
1652 DEFUN ("read", Fread
, Sread
, 0, 1, 0,
1653 doc
: /* Read one Lisp expression as text from STREAM, return as Lisp object.
1654 If STREAM is nil, use the value of `standard-input' (which see).
1655 STREAM or the value of `standard-input' may be:
1656 a buffer (read from point and advance it)
1657 a marker (read from where it points and advance it)
1658 a function (call it with no arguments for each character,
1659 call it with a char as argument to push a char back)
1660 a string (takes text from string, starting at the beginning)
1661 t (read text line using minibuffer and use it, or read from
1662 standard input in batch mode). */)
1667 stream
= Vstandard_input
;
1668 if (EQ (stream
, Qt
))
1669 stream
= Qread_char
;
1670 if (EQ (stream
, Qread_char
))
1671 return Fread_minibuffer (build_string ("Lisp expression: "), Qnil
);
1673 return read_internal_start (stream
, Qnil
, Qnil
);
1676 DEFUN ("read-from-string", Fread_from_string
, Sread_from_string
, 1, 3, 0,
1677 doc
: /* Read one Lisp expression which is represented as text by STRING.
1678 Returns a cons: (OBJECT-READ . FINAL-STRING-INDEX).
1679 START and END optionally delimit a substring of STRING from which to read;
1680 they default to 0 and (length STRING) respectively. */)
1681 (string
, start
, end
)
1682 Lisp_Object string
, start
, end
;
1685 CHECK_STRING (string
);
1686 /* read_internal_start sets read_from_string_index. */
1687 ret
= read_internal_start (string
, start
, end
);
1688 return Fcons (ret
, make_number (read_from_string_index
));
1691 /* Function to set up the global context we need in toplevel read
1694 read_internal_start (stream
, start
, end
)
1696 Lisp_Object start
; /* Only used when stream is a string. */
1697 Lisp_Object end
; /* Only used when stream is a string. */
1701 readchar_backlog
= -1;
1703 new_backquote_flag
= 0;
1704 read_objects
= Qnil
;
1705 if (EQ (Vread_with_symbol_positions
, Qt
)
1706 || EQ (Vread_with_symbol_positions
, stream
))
1707 Vread_symbol_positions_list
= Qnil
;
1709 if (STRINGP (stream
))
1711 int startval
, endval
;
1713 endval
= SCHARS (stream
);
1717 endval
= XINT (end
);
1718 if (endval
< 0 || endval
> SCHARS (stream
))
1719 args_out_of_range (stream
, end
);
1726 CHECK_NUMBER (start
);
1727 startval
= XINT (start
);
1728 if (startval
< 0 || startval
> endval
)
1729 args_out_of_range (stream
, start
);
1731 read_from_string_index
= startval
;
1732 read_from_string_index_byte
= string_char_to_byte (stream
, startval
);
1733 read_from_string_limit
= endval
;
1736 retval
= read0 (stream
);
1737 if (EQ (Vread_with_symbol_positions
, Qt
)
1738 || EQ (Vread_with_symbol_positions
, stream
))
1739 Vread_symbol_positions_list
= Fnreverse (Vread_symbol_positions_list
);
1744 /* Signal Qinvalid_read_syntax error.
1745 S is error string of length N (if > 0) */
1748 invalid_syntax (s
, n
)
1754 xsignal1 (Qinvalid_read_syntax
, make_string (s
, n
));
1758 /* Use this for recursive reads, in contexts where internal tokens
1763 Lisp_Object readcharfun
;
1765 register Lisp_Object val
;
1768 val
= read1 (readcharfun
, &c
, 0);
1772 xsignal1 (Qinvalid_read_syntax
,
1773 Fmake_string (make_number (1), make_number (c
)));
1776 static int read_buffer_size
;
1777 static char *read_buffer
;
1779 /* Read multibyte form and return it as a character. C is a first
1780 byte of multibyte form, and rest of them are read from
1784 read_multibyte (c
, readcharfun
)
1786 Lisp_Object readcharfun
;
1788 /* We need the actual character code of this multibyte
1790 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
1798 while ((c
= READCHAR
) >= 0xA0
1799 && len
< MAX_MULTIBYTE_LENGTH
)
1805 if (UNIBYTE_STR_AS_MULTIBYTE_P (str
, len
, bytes
))
1806 return STRING_CHAR (str
, len
);
1807 /* The byte sequence is not valid as multibyte. Unread all bytes
1808 but the first one, and return the first byte. */
1814 /* Read a \-escape sequence, assuming we already read the `\'.
1815 If the escape sequence forces unibyte, store 1 into *BYTEREP.
1816 If the escape sequence forces multibyte, store 2 into *BYTEREP.
1817 Otherwise store 0 into *BYTEREP. */
1820 read_escape (readcharfun
, stringp
, byterep
)
1821 Lisp_Object readcharfun
;
1825 register int c
= READCHAR
;
1826 /* \u allows up to four hex digits, \U up to eight. Default to the
1827 behaviour for \u, and change this value in the case that \U is seen. */
1828 int unicode_hex_count
= 4;
1835 end_of_file_error ();
1865 error ("Invalid escape character syntax");
1868 c
= read_escape (readcharfun
, 0, byterep
);
1869 return c
| meta_modifier
;
1874 error ("Invalid escape character syntax");
1877 c
= read_escape (readcharfun
, 0, byterep
);
1878 return c
| shift_modifier
;
1883 error ("Invalid escape character syntax");
1886 c
= read_escape (readcharfun
, 0, byterep
);
1887 return c
| hyper_modifier
;
1892 error ("Invalid escape character syntax");
1895 c
= read_escape (readcharfun
, 0, byterep
);
1896 return c
| alt_modifier
;
1900 if (stringp
|| c
!= '-')
1907 c
= read_escape (readcharfun
, 0, byterep
);
1908 return c
| super_modifier
;
1913 error ("Invalid escape character syntax");
1917 c
= read_escape (readcharfun
, 0, byterep
);
1918 if ((c
& ~CHAR_MODIFIER_MASK
) == '?')
1919 return 0177 | (c
& CHAR_MODIFIER_MASK
);
1920 else if (! SINGLE_BYTE_CHAR_P ((c
& ~CHAR_MODIFIER_MASK
)))
1921 return c
| ctrl_modifier
;
1922 /* ASCII control chars are made from letters (both cases),
1923 as well as the non-letters within 0100...0137. */
1924 else if ((c
& 0137) >= 0101 && (c
& 0137) <= 0132)
1925 return (c
& (037 | ~0177));
1926 else if ((c
& 0177) >= 0100 && (c
& 0177) <= 0137)
1927 return (c
& (037 | ~0177));
1929 return c
| ctrl_modifier
;
1939 /* An octal escape, as in ANSI C. */
1941 register int i
= c
- '0';
1942 register int count
= 0;
1945 if ((c
= READCHAR
) >= '0' && c
<= '7')
1962 /* A hex escape, as in ANSI C. */
1968 if (c
>= '0' && c
<= '9')
1973 else if ((c
>= 'a' && c
<= 'f')
1974 || (c
>= 'A' && c
<= 'F'))
1977 if (c
>= 'a' && c
<= 'f')
1994 /* Post-Unicode-2.0: Up to eight hex chars. */
1995 unicode_hex_count
= 8;
1998 /* A Unicode escape. We only permit them in strings and characters,
1999 not arbitrarily in the source code, as in some other languages. */
2003 Lisp_Object lisp_char
;
2004 struct gcpro gcpro1
;
2006 while (++count
<= unicode_hex_count
)
2009 /* isdigit and isalpha may be locale-specific, which we don't
2011 if (c
>= '0' && c
<= '9') i
= (i
<< 4) + (c
- '0');
2012 else if (c
>= 'a' && c
<= 'f') i
= (i
<< 4) + (c
- 'a') + 10;
2013 else if (c
>= 'A' && c
<= 'F') i
= (i
<< 4) + (c
- 'A') + 10;
2016 error ("Non-hex digit used for Unicode escape");
2021 GCPRO1 (readcharfun
);
2022 lisp_char
= call2 (intern ("decode-char"), intern ("ucs"),
2026 if (NILP (lisp_char
))
2028 error ("Unsupported Unicode code point: U+%x", (unsigned)i
);
2031 return XFASTINT (lisp_char
);
2035 if (BASE_LEADING_CODE_P (c
))
2036 c
= read_multibyte (c
, readcharfun
);
2041 /* Read an integer in radix RADIX using READCHARFUN to read
2042 characters. RADIX must be in the interval [2..36]; if it isn't, a
2043 read error is signaled . Value is the integer read. Signals an
2044 error if encountering invalid read syntax or if RADIX is out of
2048 read_integer (readcharfun
, radix
)
2049 Lisp_Object readcharfun
;
2052 int ndigits
= 0, invalid_p
, c
, sign
= 0;
2053 EMACS_INT number
= 0;
2055 if (radix
< 2 || radix
> 36)
2059 number
= ndigits
= invalid_p
= 0;
2075 if (c
>= '0' && c
<= '9')
2077 else if (c
>= 'a' && c
<= 'z')
2078 digit
= c
- 'a' + 10;
2079 else if (c
>= 'A' && c
<= 'Z')
2080 digit
= c
- 'A' + 10;
2087 if (digit
< 0 || digit
>= radix
)
2090 number
= radix
* number
+ digit
;
2096 if (ndigits
== 0 || invalid_p
)
2099 sprintf (buf
, "integer, radix %d", radix
);
2100 invalid_syntax (buf
, 0);
2103 return make_number (sign
* number
);
2107 /* Convert unibyte text in read_buffer to multibyte.
2109 Initially, *P is a pointer after the end of the unibyte text, and
2110 the pointer *END points after the end of read_buffer.
2112 If read_buffer doesn't have enough room to hold the result
2113 of the conversion, reallocate it and adjust *P and *END.
2115 At the end, make *P point after the result of the conversion, and
2116 return in *NCHARS the number of characters in the converted
2120 to_multibyte (p
, end
, nchars
)
2126 parse_str_as_multibyte (read_buffer
, *p
- read_buffer
, &nbytes
, nchars
);
2127 if (read_buffer_size
< 2 * nbytes
)
2129 int offset
= *p
- read_buffer
;
2130 read_buffer_size
= 2 * max (read_buffer_size
, nbytes
);
2131 read_buffer
= (char *) xrealloc (read_buffer
, read_buffer_size
);
2132 *p
= read_buffer
+ offset
;
2133 *end
= read_buffer
+ read_buffer_size
;
2136 if (nbytes
!= *nchars
)
2137 nbytes
= str_as_multibyte (read_buffer
, read_buffer_size
,
2138 *p
- read_buffer
, nchars
);
2140 *p
= read_buffer
+ nbytes
;
2144 /* If the next token is ')' or ']' or '.', we store that character
2145 in *PCH and the return value is not interesting. Else, we store
2146 zero in *PCH and we read and return one lisp object.
2148 FIRST_IN_LIST is nonzero if this is the first element of a list. */
2151 read1 (readcharfun
, pch
, first_in_list
)
2152 register Lisp_Object readcharfun
;
2157 int uninterned_symbol
= 0;
2165 end_of_file_error ();
2170 return read_list (0, readcharfun
);
2173 return read_vector (readcharfun
, 0);
2190 tmp
= read_vector (readcharfun
, 0);
2191 if (XVECTOR (tmp
)->size
< CHAR_TABLE_STANDARD_SLOTS
2192 || XVECTOR (tmp
)->size
> CHAR_TABLE_STANDARD_SLOTS
+ 10)
2193 error ("Invalid size char-table");
2194 XSETCHAR_TABLE (tmp
, XCHAR_TABLE (tmp
));
2195 XCHAR_TABLE (tmp
)->top
= Qt
;
2204 tmp
= read_vector (readcharfun
, 0);
2205 if (XVECTOR (tmp
)->size
!= SUB_CHAR_TABLE_STANDARD_SLOTS
)
2206 error ("Invalid size char-table");
2207 XSETCHAR_TABLE (tmp
, XCHAR_TABLE (tmp
));
2208 XCHAR_TABLE (tmp
)->top
= Qnil
;
2211 invalid_syntax ("#^^", 3);
2213 invalid_syntax ("#^", 2);
2218 length
= read1 (readcharfun
, pch
, first_in_list
);
2222 Lisp_Object tmp
, val
;
2224 = ((XFASTINT (length
) + BOOL_VECTOR_BITS_PER_CHAR
- 1)
2225 / BOOL_VECTOR_BITS_PER_CHAR
);
2228 tmp
= read1 (readcharfun
, pch
, first_in_list
);
2229 if (size_in_chars
!= SCHARS (tmp
)
2230 /* We used to print 1 char too many
2231 when the number of bits was a multiple of 8.
2232 Accept such input in case it came from an old version. */
2233 && ! (XFASTINT (length
)
2234 == (SCHARS (tmp
) - 1) * BOOL_VECTOR_BITS_PER_CHAR
))
2235 invalid_syntax ("#&...", 5);
2237 val
= Fmake_bool_vector (length
, Qnil
);
2238 bcopy (SDATA (tmp
), XBOOL_VECTOR (val
)->data
,
2240 /* Clear the extraneous bits in the last byte. */
2241 if (XINT (length
) != size_in_chars
* BOOL_VECTOR_BITS_PER_CHAR
)
2242 XBOOL_VECTOR (val
)->data
[size_in_chars
- 1]
2243 &= (1 << (XINT (length
) % BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2246 invalid_syntax ("#&...", 5);
2250 /* Accept compiled functions at read-time so that we don't have to
2251 build them using function calls. */
2253 tmp
= read_vector (readcharfun
, 1);
2254 return Fmake_byte_code (XVECTOR (tmp
)->size
,
2255 XVECTOR (tmp
)->contents
);
2260 struct gcpro gcpro1
;
2263 /* Read the string itself. */
2264 tmp
= read1 (readcharfun
, &ch
, 0);
2265 if (ch
!= 0 || !STRINGP (tmp
))
2266 invalid_syntax ("#", 1);
2268 /* Read the intervals and their properties. */
2271 Lisp_Object beg
, end
, plist
;
2273 beg
= read1 (readcharfun
, &ch
, 0);
2278 end
= read1 (readcharfun
, &ch
, 0);
2280 plist
= read1 (readcharfun
, &ch
, 0);
2282 invalid_syntax ("Invalid string property list", 0);
2283 Fset_text_properties (beg
, end
, plist
, tmp
);
2289 /* #@NUMBER is used to skip NUMBER following characters.
2290 That's used in .elc files to skip over doc strings
2291 and function definitions. */
2296 /* Read a decimal integer. */
2297 while ((c
= READCHAR
) >= 0
2298 && c
>= '0' && c
<= '9')
2306 if (load_force_doc_strings
&& EQ (readcharfun
, Qget_file_char
))
2308 /* If we are supposed to force doc strings into core right now,
2309 record the last string that we skipped,
2310 and record where in the file it comes from. */
2312 /* But first exchange saved_doc_string
2313 with prev_saved_doc_string, so we save two strings. */
2315 char *temp
= saved_doc_string
;
2316 int temp_size
= saved_doc_string_size
;
2317 file_offset temp_pos
= saved_doc_string_position
;
2318 int temp_len
= saved_doc_string_length
;
2320 saved_doc_string
= prev_saved_doc_string
;
2321 saved_doc_string_size
= prev_saved_doc_string_size
;
2322 saved_doc_string_position
= prev_saved_doc_string_position
;
2323 saved_doc_string_length
= prev_saved_doc_string_length
;
2325 prev_saved_doc_string
= temp
;
2326 prev_saved_doc_string_size
= temp_size
;
2327 prev_saved_doc_string_position
= temp_pos
;
2328 prev_saved_doc_string_length
= temp_len
;
2331 if (saved_doc_string_size
== 0)
2333 saved_doc_string_size
= nskip
+ 100;
2334 saved_doc_string
= (char *) xmalloc (saved_doc_string_size
);
2336 if (nskip
> saved_doc_string_size
)
2338 saved_doc_string_size
= nskip
+ 100;
2339 saved_doc_string
= (char *) xrealloc (saved_doc_string
,
2340 saved_doc_string_size
);
2343 saved_doc_string_position
= file_tell (instream
);
2345 /* Copy that many characters into saved_doc_string. */
2346 for (i
= 0; i
< nskip
&& c
>= 0; i
++)
2347 saved_doc_string
[i
] = c
= READCHAR
;
2349 saved_doc_string_length
= i
;
2353 /* Skip that many characters. */
2354 for (i
= 0; i
< nskip
&& c
>= 0; i
++)
2362 /* #! appears at the beginning of an executable file.
2363 Skip the first line. */
2364 while (c
!= '\n' && c
>= 0)
2369 return Vload_file_name
;
2371 return Fcons (Qfunction
, Fcons (read0 (readcharfun
), Qnil
));
2372 /* #:foo is the uninterned symbol named foo. */
2375 uninterned_symbol
= 1;
2379 /* Reader forms that can reuse previously read objects. */
2380 if (c
>= '0' && c
<= '9')
2385 /* Read a non-negative integer. */
2386 while (c
>= '0' && c
<= '9')
2392 /* #n=object returns object, but associates it with n for #n#. */
2395 /* Make a placeholder for #n# to use temporarily */
2396 Lisp_Object placeholder
;
2399 placeholder
= Fcons(Qnil
, Qnil
);
2400 cell
= Fcons (make_number (n
), placeholder
);
2401 read_objects
= Fcons (cell
, read_objects
);
2403 /* Read the object itself. */
2404 tem
= read0 (readcharfun
);
2406 /* Now put it everywhere the placeholder was... */
2407 substitute_object_in_subtree (tem
, placeholder
);
2409 /* ...and #n# will use the real value from now on. */
2410 Fsetcdr (cell
, tem
);
2414 /* #n# returns a previously read object. */
2417 tem
= Fassq (make_number (n
), read_objects
);
2420 /* Fall through to error message. */
2422 else if (c
== 'r' || c
== 'R')
2423 return read_integer (readcharfun
, n
);
2425 /* Fall through to error message. */
2427 else if (c
== 'x' || c
== 'X')
2428 return read_integer (readcharfun
, 16);
2429 else if (c
== 'o' || c
== 'O')
2430 return read_integer (readcharfun
, 8);
2431 else if (c
== 'b' || c
== 'B')
2432 return read_integer (readcharfun
, 2);
2435 invalid_syntax ("#", 1);
2438 while ((c
= READCHAR
) >= 0 && c
!= '\n');
2443 return Fcons (Qquote
, Fcons (read0 (readcharfun
), Qnil
));
2453 new_backquote_flag
++;
2454 value
= read0 (readcharfun
);
2455 new_backquote_flag
--;
2457 return Fcons (Qbackquote
, Fcons (value
, Qnil
));
2461 if (new_backquote_flag
)
2463 Lisp_Object comma_type
= Qnil
;
2468 comma_type
= Qcomma_at
;
2470 comma_type
= Qcomma_dot
;
2473 if (ch
>= 0) UNREAD (ch
);
2474 comma_type
= Qcomma
;
2477 new_backquote_flag
--;
2478 value
= read0 (readcharfun
);
2479 new_backquote_flag
++;
2480 return Fcons (comma_type
, Fcons (value
, Qnil
));
2493 end_of_file_error ();
2495 /* Accept `single space' syntax like (list ? x) where the
2496 whitespace character is SPC or TAB.
2497 Other literal whitespace like NL, CR, and FF are not accepted,
2498 as there are well-established escape sequences for these. */
2499 if (c
== ' ' || c
== '\t')
2500 return make_number (c
);
2503 c
= read_escape (readcharfun
, 0, &discard
);
2504 else if (BASE_LEADING_CODE_P (c
))
2505 c
= read_multibyte (c
, readcharfun
);
2507 next_char
= READCHAR
;
2508 if (next_char
== '.')
2510 /* Only a dotted-pair dot is valid after a char constant. */
2511 int next_next_char
= READCHAR
;
2512 UNREAD (next_next_char
);
2514 ok
= (next_next_char
<= 040
2515 || (next_next_char
< 0200
2516 && (index ("\"';([#?", next_next_char
)
2517 || (!first_in_list
&& next_next_char
== '`')
2518 || (new_backquote_flag
&& next_next_char
== ','))));
2522 ok
= (next_char
<= 040
2523 || (next_char
< 0200
2524 && (index ("\"';()[]#?", next_char
)
2525 || (!first_in_list
&& next_char
== '`')
2526 || (new_backquote_flag
&& next_char
== ','))));
2530 return make_number (c
);
2532 invalid_syntax ("?", 1);
2537 char *p
= read_buffer
;
2538 char *end
= read_buffer
+ read_buffer_size
;
2540 /* 1 if we saw an escape sequence specifying
2541 a multibyte character, or a multibyte character. */
2542 int force_multibyte
= 0;
2543 /* 1 if we saw an escape sequence specifying
2544 a single-byte character. */
2545 int force_singlebyte
= 0;
2546 /* 1 if read_buffer contains multibyte text now. */
2547 int is_multibyte
= 0;
2551 while ((c
= READCHAR
) >= 0
2554 if (end
- p
< MAX_MULTIBYTE_LENGTH
)
2556 int offset
= p
- read_buffer
;
2557 read_buffer
= (char *) xrealloc (read_buffer
,
2558 read_buffer_size
*= 2);
2559 p
= read_buffer
+ offset
;
2560 end
= read_buffer
+ read_buffer_size
;
2567 c
= read_escape (readcharfun
, 1, &byterep
);
2569 /* C is -1 if \ newline has just been seen */
2572 if (p
== read_buffer
)
2578 force_singlebyte
= 1;
2579 else if (byterep
== 2)
2580 force_multibyte
= 1;
2583 /* A character that must be multibyte forces multibyte. */
2584 if (! SINGLE_BYTE_CHAR_P (c
& ~CHAR_MODIFIER_MASK
))
2585 force_multibyte
= 1;
2587 /* If we just discovered the need to be multibyte,
2588 convert the text accumulated thus far. */
2589 if (force_multibyte
&& ! is_multibyte
)
2592 to_multibyte (&p
, &end
, &nchars
);
2595 /* Allow `\C- ' and `\C-?'. */
2596 if (c
== (CHAR_CTL
| ' '))
2598 else if (c
== (CHAR_CTL
| '?'))
2603 /* Shift modifier is valid only with [A-Za-z]. */
2604 if ((c
& 0377) >= 'A' && (c
& 0377) <= 'Z')
2606 else if ((c
& 0377) >= 'a' && (c
& 0377) <= 'z')
2607 c
= (c
& ~CHAR_SHIFT
) - ('a' - 'A');
2611 /* Move the meta bit to the right place for a string. */
2612 c
= (c
& ~CHAR_META
) | 0x80;
2613 if (c
& CHAR_MODIFIER_MASK
)
2614 error ("Invalid modifier in string");
2617 p
+= CHAR_STRING (c
, p
);
2625 end_of_file_error ();
2627 /* If purifying, and string starts with \ newline,
2628 return zero instead. This is for doc strings
2629 that we are really going to find in etc/DOC.nn.nn */
2630 if (!NILP (Vpurify_flag
) && NILP (Vdoc_file_name
) && cancel
)
2631 return make_number (0);
2633 if (is_multibyte
|| force_singlebyte
)
2635 else if (load_convert_to_unibyte
)
2638 to_multibyte (&p
, &end
, &nchars
);
2639 if (p
- read_buffer
!= nchars
)
2641 string
= make_multibyte_string (read_buffer
, nchars
,
2643 return Fstring_make_unibyte (string
);
2645 /* We can make a unibyte string directly. */
2648 else if (EQ (readcharfun
, Qget_file_char
)
2649 || EQ (readcharfun
, Qlambda
))
2651 /* Nowadays, reading directly from a file is used only for
2652 compiled Emacs Lisp files, and those always use the
2653 Emacs internal encoding. Meanwhile, Qlambda is used
2654 for reading dynamic byte code (compiled with
2655 byte-compile-dynamic = t). So make the string multibyte
2656 if the string contains any multibyte sequences.
2657 (to_multibyte is a no-op if not.) */
2658 to_multibyte (&p
, &end
, &nchars
);
2659 is_multibyte
= (p
- read_buffer
) != nchars
;
2662 /* In all other cases, if we read these bytes as
2663 separate characters, treat them as separate characters now. */
2666 /* We want readchar_count to be the number of characters, not
2667 bytes. Hence we adjust for multibyte characters in the
2668 string. ... But it doesn't seem to be necessary, because
2669 READCHAR *does* read multibyte characters from buffers. */
2670 /* readchar_count -= (p - read_buffer) - nchars; */
2672 return make_pure_string (read_buffer
, nchars
, p
- read_buffer
,
2674 return make_specified_string (read_buffer
, nchars
, p
- read_buffer
,
2680 int next_char
= READCHAR
;
2683 if (next_char
<= 040
2684 || (next_char
< 0200
2685 && (index ("\"';([#?", next_char
)
2686 || (!first_in_list
&& next_char
== '`')
2687 || (new_backquote_flag
&& next_char
== ','))))
2693 /* Otherwise, we fall through! Note that the atom-reading loop
2694 below will now loop at least once, assuring that we will not
2695 try to UNREAD two characters in a row. */
2699 if (c
<= 040) goto retry
;
2700 if (c
== 0x8a0) /* NBSP */
2703 char *p
= read_buffer
;
2707 char *end
= read_buffer
+ read_buffer_size
;
2710 && c
!= 0x8a0 /* NBSP */
2712 || (!index ("\"';()[]#", c
)
2713 && !(!first_in_list
&& c
== '`')
2714 && !(new_backquote_flag
&& c
== ','))))
2716 if (end
- p
< MAX_MULTIBYTE_LENGTH
)
2718 int offset
= p
- read_buffer
;
2719 read_buffer
= (char *) xrealloc (read_buffer
,
2720 read_buffer_size
*= 2);
2721 p
= read_buffer
+ offset
;
2722 end
= read_buffer
+ read_buffer_size
;
2729 end_of_file_error ();
2733 if (! SINGLE_BYTE_CHAR_P (c
))
2734 p
+= CHAR_STRING (c
, p
);
2743 int offset
= p
- read_buffer
;
2744 read_buffer
= (char *) xrealloc (read_buffer
,
2745 read_buffer_size
*= 2);
2746 p
= read_buffer
+ offset
;
2747 end
= read_buffer
+ read_buffer_size
;
2754 if (!quoted
&& !uninterned_symbol
)
2757 register Lisp_Object val
;
2759 if (*p1
== '+' || *p1
== '-') p1
++;
2760 /* Is it an integer? */
2763 while (p1
!= p
&& (c
= *p1
) >= '0' && c
<= '9') p1
++;
2764 /* Integers can have trailing decimal points. */
2765 if (p1
> read_buffer
&& p1
< p
&& *p1
== '.') p1
++;
2767 /* It is an integer. */
2771 if (sizeof (int) == sizeof (EMACS_INT
))
2772 XSETINT (val
, atoi (read_buffer
));
2773 else if (sizeof (long) == sizeof (EMACS_INT
))
2774 XSETINT (val
, atol (read_buffer
));
2780 if (isfloat_string (read_buffer
))
2782 /* Compute NaN and infinities using 0.0 in a variable,
2783 to cope with compilers that think they are smarter
2789 /* Negate the value ourselves. This treats 0, NaNs,
2790 and infinity properly on IEEE floating point hosts,
2791 and works around a common bug where atof ("-0.0")
2793 int negative
= read_buffer
[0] == '-';
2795 /* The only way p[-1] can be 'F' or 'N', after isfloat_string
2796 returns 1, is if the input ends in e+INF or e+NaN. */
2803 value
= zero
/ zero
;
2805 /* If that made a "negative" NaN, negate it. */
2809 union { double d
; char c
[sizeof (double)]; } u_data
, u_minus_zero
;
2812 u_minus_zero
.d
= - 0.0;
2813 for (i
= 0; i
< sizeof (double); i
++)
2814 if (u_data
.c
[i
] & u_minus_zero
.c
[i
])
2820 /* Now VALUE is a positive NaN. */
2823 value
= atof (read_buffer
+ negative
);
2827 return make_float (negative
? - value
: value
);
2831 Lisp_Object result
= uninterned_symbol
? make_symbol (read_buffer
)
2832 : intern (read_buffer
);
2833 if (EQ (Vread_with_symbol_positions
, Qt
)
2834 || EQ (Vread_with_symbol_positions
, readcharfun
))
2835 Vread_symbol_positions_list
=
2836 /* Kind of a hack; this will probably fail if characters
2837 in the symbol name were escaped. Not really a big
2839 Fcons (Fcons (result
,
2840 make_number (readchar_count
2841 - XFASTINT (Flength (Fsymbol_name (result
))))),
2842 Vread_symbol_positions_list
);
2850 /* List of nodes we've seen during substitute_object_in_subtree. */
2851 static Lisp_Object seen_list
;
2854 substitute_object_in_subtree (object
, placeholder
)
2856 Lisp_Object placeholder
;
2858 Lisp_Object check_object
;
2860 /* We haven't seen any objects when we start. */
2863 /* Make all the substitutions. */
2865 = substitute_object_recurse (object
, placeholder
, object
);
2867 /* Clear seen_list because we're done with it. */
2870 /* The returned object here is expected to always eq the
2872 if (!EQ (check_object
, object
))
2873 error ("Unexpected mutation error in reader");
2876 /* Feval doesn't get called from here, so no gc protection is needed. */
2877 #define SUBSTITUTE(get_val, set_val) \
2879 Lisp_Object old_value = get_val; \
2880 Lisp_Object true_value \
2881 = substitute_object_recurse (object, placeholder,\
2884 if (!EQ (old_value, true_value)) \
2891 substitute_object_recurse (object
, placeholder
, subtree
)
2893 Lisp_Object placeholder
;
2894 Lisp_Object subtree
;
2896 /* If we find the placeholder, return the target object. */
2897 if (EQ (placeholder
, subtree
))
2900 /* If we've been to this node before, don't explore it again. */
2901 if (!EQ (Qnil
, Fmemq (subtree
, seen_list
)))
2904 /* If this node can be the entry point to a cycle, remember that
2905 we've seen it. It can only be such an entry point if it was made
2906 by #n=, which means that we can find it as a value in
2908 if (!EQ (Qnil
, Frassq (subtree
, read_objects
)))
2909 seen_list
= Fcons (subtree
, seen_list
);
2911 /* Recurse according to subtree's type.
2912 Every branch must return a Lisp_Object. */
2913 switch (XTYPE (subtree
))
2915 case Lisp_Vectorlike
:
2918 int length
= XINT (Flength(subtree
));
2919 for (i
= 0; i
< length
; i
++)
2921 Lisp_Object idx
= make_number (i
);
2922 SUBSTITUTE (Faref (subtree
, idx
),
2923 Faset (subtree
, idx
, true_value
));
2930 SUBSTITUTE (Fcar_safe (subtree
),
2931 Fsetcar (subtree
, true_value
));
2932 SUBSTITUTE (Fcdr_safe (subtree
),
2933 Fsetcdr (subtree
, true_value
));
2939 /* Check for text properties in each interval.
2940 substitute_in_interval contains part of the logic. */
2942 INTERVAL root_interval
= STRING_INTERVALS (subtree
);
2943 Lisp_Object arg
= Fcons (object
, placeholder
);
2945 traverse_intervals_noorder (root_interval
,
2946 &substitute_in_interval
, arg
);
2951 /* Other types don't recurse any further. */
2957 /* Helper function for substitute_object_recurse. */
2959 substitute_in_interval (interval
, arg
)
2963 Lisp_Object object
= Fcar (arg
);
2964 Lisp_Object placeholder
= Fcdr (arg
);
2966 SUBSTITUTE(interval
->plist
, interval
->plist
= true_value
);
2985 if (*cp
== '+' || *cp
== '-')
2988 if (*cp
>= '0' && *cp
<= '9')
2991 while (*cp
>= '0' && *cp
<= '9')
2999 if (*cp
>= '0' && *cp
<= '9')
3002 while (*cp
>= '0' && *cp
<= '9')
3005 if (*cp
== 'e' || *cp
== 'E')
3009 if (*cp
== '+' || *cp
== '-')
3013 if (*cp
>= '0' && *cp
<= '9')
3016 while (*cp
>= '0' && *cp
<= '9')
3019 else if (cp
== start
)
3021 else if (cp
[-1] == '+' && cp
[0] == 'I' && cp
[1] == 'N' && cp
[2] == 'F')
3026 else if (cp
[-1] == '+' && cp
[0] == 'N' && cp
[1] == 'a' && cp
[2] == 'N')
3032 return (((*cp
== 0) || (*cp
== ' ') || (*cp
== '\t') || (*cp
== '\n') || (*cp
== '\r') || (*cp
== '\f'))
3033 && (state
== (LEAD_INT
|DOT_CHAR
|TRAIL_INT
)
3034 || state
== (DOT_CHAR
|TRAIL_INT
)
3035 || state
== (LEAD_INT
|E_CHAR
|EXP_INT
)
3036 || state
== (LEAD_INT
|DOT_CHAR
|TRAIL_INT
|E_CHAR
|EXP_INT
)
3037 || state
== (DOT_CHAR
|TRAIL_INT
|E_CHAR
|EXP_INT
)));
3042 read_vector (readcharfun
, bytecodeflag
)
3043 Lisp_Object readcharfun
;
3048 register Lisp_Object
*ptr
;
3049 register Lisp_Object tem
, item
, vector
;
3050 register struct Lisp_Cons
*otem
;
3053 tem
= read_list (1, readcharfun
);
3054 len
= Flength (tem
);
3055 vector
= (read_pure
? make_pure_vector (XINT (len
)) : Fmake_vector (len
, Qnil
));
3057 size
= XVECTOR (vector
)->size
;
3058 ptr
= XVECTOR (vector
)->contents
;
3059 for (i
= 0; i
< size
; i
++)
3062 /* If `load-force-doc-strings' is t when reading a lazily-loaded
3063 bytecode object, the docstring containing the bytecode and
3064 constants values must be treated as unibyte and passed to
3065 Fread, to get the actual bytecode string and constants vector. */
3066 if (bytecodeflag
&& load_force_doc_strings
)
3068 if (i
== COMPILED_BYTECODE
)
3070 if (!STRINGP (item
))
3071 error ("Invalid byte code");
3073 /* Delay handling the bytecode slot until we know whether
3074 it is lazily-loaded (we can tell by whether the
3075 constants slot is nil). */
3076 ptr
[COMPILED_CONSTANTS
] = item
;
3079 else if (i
== COMPILED_CONSTANTS
)
3081 Lisp_Object bytestr
= ptr
[COMPILED_CONSTANTS
];
3085 /* Coerce string to unibyte (like string-as-unibyte,
3086 but without generating extra garbage and
3087 guaranteeing no change in the contents). */
3088 STRING_SET_CHARS (bytestr
, SBYTES (bytestr
));
3089 STRING_SET_UNIBYTE (bytestr
);
3091 item
= Fread (bytestr
);
3093 error ("Invalid byte code");
3095 otem
= XCONS (item
);
3096 bytestr
= XCAR (item
);
3101 /* Now handle the bytecode slot. */
3102 ptr
[COMPILED_BYTECODE
] = read_pure
? Fpurecopy (bytestr
) : bytestr
;
3105 ptr
[i
] = read_pure
? Fpurecopy (item
) : item
;
3113 /* FLAG = 1 means check for ] to terminate rather than ) and .
3114 FLAG = -1 means check for starting with defun
3115 and make structure pure. */
3118 read_list (flag
, readcharfun
)
3120 register Lisp_Object readcharfun
;
3122 /* -1 means check next element for defun,
3123 0 means don't check,
3124 1 means already checked and found defun. */
3125 int defunflag
= flag
< 0 ? -1 : 0;
3126 Lisp_Object val
, tail
;
3127 register Lisp_Object elt
, tem
;
3128 struct gcpro gcpro1
, gcpro2
;
3129 /* 0 is the normal case.
3130 1 means this list is a doc reference; replace it with the number 0.
3131 2 means this list is a doc reference; replace it with the doc string. */
3132 int doc_reference
= 0;
3134 /* Initialize this to 1 if we are reading a list. */
3135 int first_in_list
= flag
<= 0;
3144 elt
= read1 (readcharfun
, &ch
, first_in_list
);
3149 /* While building, if the list starts with #$, treat it specially. */
3150 if (EQ (elt
, Vload_file_name
)
3152 && !NILP (Vpurify_flag
))
3154 if (NILP (Vdoc_file_name
))
3155 /* We have not yet called Snarf-documentation, so assume
3156 this file is described in the DOC-MM.NN file
3157 and Snarf-documentation will fill in the right value later.
3158 For now, replace the whole list with 0. */
3161 /* We have already called Snarf-documentation, so make a relative
3162 file name for this file, so it can be found properly
3163 in the installed Lisp directory.
3164 We don't use Fexpand_file_name because that would make
3165 the directory absolute now. */
3166 elt
= concat2 (build_string ("../lisp/"),
3167 Ffile_name_nondirectory (elt
));
3169 else if (EQ (elt
, Vload_file_name
)
3171 && load_force_doc_strings
)
3180 invalid_syntax (") or . in a vector", 18);
3188 XSETCDR (tail
, read0 (readcharfun
));
3190 val
= read0 (readcharfun
);
3191 read1 (readcharfun
, &ch
, 0);
3195 if (doc_reference
== 1)
3196 return make_number (0);
3197 if (doc_reference
== 2)
3199 /* Get a doc string from the file we are loading.
3200 If it's in saved_doc_string, get it from there. */
3201 int pos
= XINT (XCDR (val
));
3202 /* Position is negative for user variables. */
3203 if (pos
< 0) pos
= -pos
;
3204 if (pos
>= saved_doc_string_position
3205 && pos
< (saved_doc_string_position
3206 + saved_doc_string_length
))
3208 int start
= pos
- saved_doc_string_position
;
3211 /* Process quoting with ^A,
3212 and find the end of the string,
3213 which is marked with ^_ (037). */
3214 for (from
= start
, to
= start
;
3215 saved_doc_string
[from
] != 037;)
3217 int c
= saved_doc_string
[from
++];
3220 c
= saved_doc_string
[from
++];
3222 saved_doc_string
[to
++] = c
;
3224 saved_doc_string
[to
++] = 0;
3226 saved_doc_string
[to
++] = 037;
3229 saved_doc_string
[to
++] = c
;
3232 return make_string (saved_doc_string
+ start
,
3235 /* Look in prev_saved_doc_string the same way. */
3236 else if (pos
>= prev_saved_doc_string_position
3237 && pos
< (prev_saved_doc_string_position
3238 + prev_saved_doc_string_length
))
3240 int start
= pos
- prev_saved_doc_string_position
;
3243 /* Process quoting with ^A,
3244 and find the end of the string,
3245 which is marked with ^_ (037). */
3246 for (from
= start
, to
= start
;
3247 prev_saved_doc_string
[from
] != 037;)
3249 int c
= prev_saved_doc_string
[from
++];
3252 c
= prev_saved_doc_string
[from
++];
3254 prev_saved_doc_string
[to
++] = c
;
3256 prev_saved_doc_string
[to
++] = 0;
3258 prev_saved_doc_string
[to
++] = 037;
3261 prev_saved_doc_string
[to
++] = c
;
3264 return make_string (prev_saved_doc_string
+ start
,
3268 return get_doc_string (val
, 0, 0);
3273 invalid_syntax (". in wrong context", 18);
3275 invalid_syntax ("] in a list", 11);
3277 tem
= (read_pure
&& flag
<= 0
3278 ? pure_cons (elt
, Qnil
)
3279 : Fcons (elt
, Qnil
));
3281 XSETCDR (tail
, tem
);
3286 defunflag
= EQ (elt
, Qdefun
);
3287 else if (defunflag
> 0)
3292 Lisp_Object Vobarray
;
3293 Lisp_Object initial_obarray
;
3295 /* oblookup stores the bucket number here, for the sake of Funintern. */
3297 int oblookup_last_bucket_number
;
3299 static int hash_string ();
3301 /* Get an error if OBARRAY is not an obarray.
3302 If it is one, return it. */
3305 check_obarray (obarray
)
3306 Lisp_Object obarray
;
3308 if (!VECTORP (obarray
) || XVECTOR (obarray
)->size
== 0)
3310 /* If Vobarray is now invalid, force it to be valid. */
3311 if (EQ (Vobarray
, obarray
)) Vobarray
= initial_obarray
;
3312 wrong_type_argument (Qvectorp
, obarray
);
3317 /* Intern the C string STR: return a symbol with that name,
3318 interned in the current obarray. */
3325 int len
= strlen (str
);
3326 Lisp_Object obarray
;
3329 if (!VECTORP (obarray
) || XVECTOR (obarray
)->size
== 0)
3330 obarray
= check_obarray (obarray
);
3331 tem
= oblookup (obarray
, str
, len
, len
);
3334 return Fintern (make_string (str
, len
), obarray
);
3337 /* Create an uninterned symbol with name STR. */
3343 int len
= strlen (str
);
3345 return Fmake_symbol ((!NILP (Vpurify_flag
)
3346 ? make_pure_string (str
, len
, len
, 0)
3347 : make_string (str
, len
)));
3350 DEFUN ("intern", Fintern
, Sintern
, 1, 2, 0,
3351 doc
: /* Return the canonical symbol whose name is STRING.
3352 If there is none, one is created by this function and returned.
3353 A second optional argument specifies the obarray to use;
3354 it defaults to the value of `obarray'. */)
3356 Lisp_Object string
, obarray
;
3358 register Lisp_Object tem
, sym
, *ptr
;
3360 if (NILP (obarray
)) obarray
= Vobarray
;
3361 obarray
= check_obarray (obarray
);
3363 CHECK_STRING (string
);
3365 tem
= oblookup (obarray
, SDATA (string
),
3368 if (!INTEGERP (tem
))
3371 if (!NILP (Vpurify_flag
))
3372 string
= Fpurecopy (string
);
3373 sym
= Fmake_symbol (string
);
3375 if (EQ (obarray
, initial_obarray
))
3376 XSYMBOL (sym
)->interned
= SYMBOL_INTERNED_IN_INITIAL_OBARRAY
;
3378 XSYMBOL (sym
)->interned
= SYMBOL_INTERNED
;
3380 if ((SREF (string
, 0) == ':')
3381 && EQ (obarray
, initial_obarray
))
3383 XSYMBOL (sym
)->constant
= 1;
3384 XSYMBOL (sym
)->value
= sym
;
3387 ptr
= &XVECTOR (obarray
)->contents
[XINT (tem
)];
3389 XSYMBOL (sym
)->next
= XSYMBOL (*ptr
);
3391 XSYMBOL (sym
)->next
= 0;
3396 DEFUN ("intern-soft", Fintern_soft
, Sintern_soft
, 1, 2, 0,
3397 doc
: /* Return the canonical symbol named NAME, or nil if none exists.
3398 NAME may be a string or a symbol. If it is a symbol, that exact
3399 symbol is searched for.
3400 A second optional argument specifies the obarray to use;
3401 it defaults to the value of `obarray'. */)
3403 Lisp_Object name
, obarray
;
3405 register Lisp_Object tem
, string
;
3407 if (NILP (obarray
)) obarray
= Vobarray
;
3408 obarray
= check_obarray (obarray
);
3410 if (!SYMBOLP (name
))
3412 CHECK_STRING (name
);
3416 string
= SYMBOL_NAME (name
);
3418 tem
= oblookup (obarray
, SDATA (string
), SCHARS (string
), SBYTES (string
));
3419 if (INTEGERP (tem
) || (SYMBOLP (name
) && !EQ (name
, tem
)))
3425 DEFUN ("unintern", Funintern
, Sunintern
, 1, 2, 0,
3426 doc
: /* Delete the symbol named NAME, if any, from OBARRAY.
3427 The value is t if a symbol was found and deleted, nil otherwise.
3428 NAME may be a string or a symbol. If it is a symbol, that symbol
3429 is deleted, if it belongs to OBARRAY--no other symbol is deleted.
3430 OBARRAY defaults to the value of the variable `obarray'. */)
3432 Lisp_Object name
, obarray
;
3434 register Lisp_Object string
, tem
;
3437 if (NILP (obarray
)) obarray
= Vobarray
;
3438 obarray
= check_obarray (obarray
);
3441 string
= SYMBOL_NAME (name
);
3444 CHECK_STRING (name
);
3448 tem
= oblookup (obarray
, SDATA (string
),
3453 /* If arg was a symbol, don't delete anything but that symbol itself. */
3454 if (SYMBOLP (name
) && !EQ (name
, tem
))
3457 XSYMBOL (tem
)->interned
= SYMBOL_UNINTERNED
;
3458 XSYMBOL (tem
)->constant
= 0;
3459 XSYMBOL (tem
)->indirect_variable
= 0;
3461 hash
= oblookup_last_bucket_number
;
3463 if (EQ (XVECTOR (obarray
)->contents
[hash
], tem
))
3465 if (XSYMBOL (tem
)->next
)
3466 XSETSYMBOL (XVECTOR (obarray
)->contents
[hash
], XSYMBOL (tem
)->next
);
3468 XSETINT (XVECTOR (obarray
)->contents
[hash
], 0);
3472 Lisp_Object tail
, following
;
3474 for (tail
= XVECTOR (obarray
)->contents
[hash
];
3475 XSYMBOL (tail
)->next
;
3478 XSETSYMBOL (following
, XSYMBOL (tail
)->next
);
3479 if (EQ (following
, tem
))
3481 XSYMBOL (tail
)->next
= XSYMBOL (following
)->next
;
3490 /* Return the symbol in OBARRAY whose names matches the string
3491 of SIZE characters (SIZE_BYTE bytes) at PTR.
3492 If there is no such symbol in OBARRAY, return nil.
3494 Also store the bucket number in oblookup_last_bucket_number. */
3497 oblookup (obarray
, ptr
, size
, size_byte
)
3498 Lisp_Object obarray
;
3499 register const char *ptr
;
3500 int size
, size_byte
;
3504 register Lisp_Object tail
;
3505 Lisp_Object bucket
, tem
;
3507 if (!VECTORP (obarray
)
3508 || (obsize
= XVECTOR (obarray
)->size
) == 0)
3510 obarray
= check_obarray (obarray
);
3511 obsize
= XVECTOR (obarray
)->size
;
3513 /* This is sometimes needed in the middle of GC. */
3514 obsize
&= ~ARRAY_MARK_FLAG
;
3515 /* Combining next two lines breaks VMS C 2.3. */
3516 hash
= hash_string (ptr
, size_byte
);
3518 bucket
= XVECTOR (obarray
)->contents
[hash
];
3519 oblookup_last_bucket_number
= hash
;
3520 if (EQ (bucket
, make_number (0)))
3522 else if (!SYMBOLP (bucket
))
3523 error ("Bad data in guts of obarray"); /* Like CADR error message */
3525 for (tail
= bucket
; ; XSETSYMBOL (tail
, XSYMBOL (tail
)->next
))
3527 if (SBYTES (SYMBOL_NAME (tail
)) == size_byte
3528 && SCHARS (SYMBOL_NAME (tail
)) == size
3529 && !bcmp (SDATA (SYMBOL_NAME (tail
)), ptr
, size_byte
))
3531 else if (XSYMBOL (tail
)->next
== 0)
3534 XSETINT (tem
, hash
);
3539 hash_string (ptr
, len
)
3540 const unsigned char *ptr
;
3543 register const unsigned char *p
= ptr
;
3544 register const unsigned char *end
= p
+ len
;
3545 register unsigned char c
;
3546 register int hash
= 0;
3551 if (c
>= 0140) c
-= 40;
3552 hash
= ((hash
<<3) + (hash
>>28) + c
);
3554 return hash
& 07777777777;
3558 map_obarray (obarray
, fn
, arg
)
3559 Lisp_Object obarray
;
3560 void (*fn
) P_ ((Lisp_Object
, Lisp_Object
));
3564 register Lisp_Object tail
;
3565 CHECK_VECTOR (obarray
);
3566 for (i
= XVECTOR (obarray
)->size
- 1; i
>= 0; i
--)
3568 tail
= XVECTOR (obarray
)->contents
[i
];
3573 if (XSYMBOL (tail
)->next
== 0)
3575 XSETSYMBOL (tail
, XSYMBOL (tail
)->next
);
3581 mapatoms_1 (sym
, function
)
3582 Lisp_Object sym
, function
;
3584 call1 (function
, sym
);
3587 DEFUN ("mapatoms", Fmapatoms
, Smapatoms
, 1, 2, 0,
3588 doc
: /* Call FUNCTION on every symbol in OBARRAY.
3589 OBARRAY defaults to the value of `obarray'. */)
3591 Lisp_Object function
, obarray
;
3593 if (NILP (obarray
)) obarray
= Vobarray
;
3594 obarray
= check_obarray (obarray
);
3596 map_obarray (obarray
, mapatoms_1
, function
);
3600 #define OBARRAY_SIZE 1511
3605 Lisp_Object oblength
;
3609 XSETFASTINT (oblength
, OBARRAY_SIZE
);
3611 Qnil
= Fmake_symbol (make_pure_string ("nil", 3, 3, 0));
3612 Vobarray
= Fmake_vector (oblength
, make_number (0));
3613 initial_obarray
= Vobarray
;
3614 staticpro (&initial_obarray
);
3615 /* Intern nil in the obarray */
3616 XSYMBOL (Qnil
)->interned
= SYMBOL_INTERNED_IN_INITIAL_OBARRAY
;
3617 XSYMBOL (Qnil
)->constant
= 1;
3619 /* These locals are to kludge around a pyramid compiler bug. */
3620 hash
= hash_string ("nil", 3);
3621 /* Separate statement here to avoid VAXC bug. */
3622 hash
%= OBARRAY_SIZE
;
3623 tem
= &XVECTOR (Vobarray
)->contents
[hash
];
3626 Qunbound
= Fmake_symbol (make_pure_string ("unbound", 7, 7, 0));
3627 XSYMBOL (Qnil
)->function
= Qunbound
;
3628 XSYMBOL (Qunbound
)->value
= Qunbound
;
3629 XSYMBOL (Qunbound
)->function
= Qunbound
;
3632 XSYMBOL (Qnil
)->value
= Qnil
;
3633 XSYMBOL (Qnil
)->plist
= Qnil
;
3634 XSYMBOL (Qt
)->value
= Qt
;
3635 XSYMBOL (Qt
)->constant
= 1;
3637 /* Qt is correct even if CANNOT_DUMP. loadup.el will set to nil at end. */
3640 Qvariable_documentation
= intern ("variable-documentation");
3641 staticpro (&Qvariable_documentation
);
3643 read_buffer_size
= 100 + MAX_MULTIBYTE_LENGTH
;
3644 read_buffer
= (char *) xmalloc (read_buffer_size
);
3649 struct Lisp_Subr
*sname
;
3652 sym
= intern (sname
->symbol_name
);
3653 XSETSUBR (XSYMBOL (sym
)->function
, sname
);
3656 #ifdef NOTDEF /* use fset in subr.el now */
3658 defalias (sname
, string
)
3659 struct Lisp_Subr
*sname
;
3663 sym
= intern (string
);
3664 XSETSUBR (XSYMBOL (sym
)->function
, sname
);
3668 /* Define an "integer variable"; a symbol whose value is forwarded
3669 to a C variable of type int. Sample call: */
3670 /* DEFVAR_INT ("indent-tabs-mode", &indent_tabs_mode, "Documentation"); */
3672 defvar_int (namestring
, address
)
3676 Lisp_Object sym
, val
;
3677 sym
= intern (namestring
);
3678 val
= allocate_misc ();
3679 XMISCTYPE (val
) = Lisp_Misc_Intfwd
;
3680 XINTFWD (val
)->intvar
= address
;
3681 SET_SYMBOL_VALUE (sym
, val
);
3684 /* Similar but define a variable whose value is t if address contains 1,
3685 nil if address contains 0 */
3687 defvar_bool (namestring
, address
)
3691 Lisp_Object sym
, val
;
3692 sym
= intern (namestring
);
3693 val
= allocate_misc ();
3694 XMISCTYPE (val
) = Lisp_Misc_Boolfwd
;
3695 XBOOLFWD (val
)->boolvar
= address
;
3696 SET_SYMBOL_VALUE (sym
, val
);
3697 Vbyte_boolean_vars
= Fcons (sym
, Vbyte_boolean_vars
);
3700 /* Similar but define a variable whose value is the Lisp Object stored
3701 at address. Two versions: with and without gc-marking of the C
3702 variable. The nopro version is used when that variable will be
3703 gc-marked for some other reason, since marking the same slot twice
3704 can cause trouble with strings. */
3706 defvar_lisp_nopro (namestring
, address
)
3708 Lisp_Object
*address
;
3710 Lisp_Object sym
, val
;
3711 sym
= intern (namestring
);
3712 val
= allocate_misc ();
3713 XMISCTYPE (val
) = Lisp_Misc_Objfwd
;
3714 XOBJFWD (val
)->objvar
= address
;
3715 SET_SYMBOL_VALUE (sym
, val
);
3719 defvar_lisp (namestring
, address
)
3721 Lisp_Object
*address
;
3723 defvar_lisp_nopro (namestring
, address
);
3724 staticpro (address
);
3727 /* Similar but define a variable whose value is the Lisp Object stored in
3728 the current buffer. address is the address of the slot in the buffer
3729 that is current now. */
3732 defvar_per_buffer (namestring
, address
, type
, doc
)
3734 Lisp_Object
*address
;
3738 Lisp_Object sym
, val
;
3741 sym
= intern (namestring
);
3742 val
= allocate_misc ();
3743 offset
= (char *)address
- (char *)current_buffer
;
3745 XMISCTYPE (val
) = Lisp_Misc_Buffer_Objfwd
;
3746 XBUFFER_OBJFWD (val
)->offset
= offset
;
3747 SET_SYMBOL_VALUE (sym
, val
);
3748 PER_BUFFER_SYMBOL (offset
) = sym
;
3749 PER_BUFFER_TYPE (offset
) = type
;
3751 if (PER_BUFFER_IDX (offset
) == 0)
3752 /* Did a DEFVAR_PER_BUFFER without initializing the corresponding
3753 slot of buffer_local_flags */
3758 /* Similar but define a variable whose value is the Lisp Object stored
3759 at a particular offset in the current kboard object. */
3762 defvar_kboard (namestring
, offset
)
3766 Lisp_Object sym
, val
;
3767 sym
= intern (namestring
);
3768 val
= allocate_misc ();
3769 XMISCTYPE (val
) = Lisp_Misc_Kboard_Objfwd
;
3770 XKBOARD_OBJFWD (val
)->offset
= offset
;
3771 SET_SYMBOL_VALUE (sym
, val
);
3774 /* Record the value of load-path used at the start of dumping
3775 so we can see if the site changed it later during dumping. */
3776 static Lisp_Object dump_path
;
3782 int turn_off_warning
= 0;
3784 /* Compute the default load-path. */
3786 normal
= PATH_LOADSEARCH
;
3787 Vload_path
= decode_env_path (0, normal
);
3789 if (NILP (Vpurify_flag
))
3790 normal
= PATH_LOADSEARCH
;
3792 normal
= PATH_DUMPLOADSEARCH
;
3794 /* In a dumped Emacs, we normally have to reset the value of
3795 Vload_path from PATH_LOADSEARCH, since the value that was dumped
3796 uses ../lisp, instead of the path of the installed elisp
3797 libraries. However, if it appears that Vload_path was changed
3798 from the default before dumping, don't override that value. */
3801 if (! NILP (Fequal (dump_path
, Vload_path
)))
3803 Vload_path
= decode_env_path (0, normal
);
3804 if (!NILP (Vinstallation_directory
))
3806 Lisp_Object tem
, tem1
, sitelisp
;
3808 /* Remove site-lisp dirs from path temporarily and store
3809 them in sitelisp, then conc them on at the end so
3810 they're always first in path. */
3814 tem
= Fcar (Vload_path
);
3815 tem1
= Fstring_match (build_string ("site-lisp"),
3819 Vload_path
= Fcdr (Vload_path
);
3820 sitelisp
= Fcons (tem
, sitelisp
);
3826 /* Add to the path the lisp subdir of the
3827 installation dir, if it exists. */
3828 tem
= Fexpand_file_name (build_string ("lisp"),
3829 Vinstallation_directory
);
3830 tem1
= Ffile_exists_p (tem
);
3833 if (NILP (Fmember (tem
, Vload_path
)))
3835 turn_off_warning
= 1;
3836 Vload_path
= Fcons (tem
, Vload_path
);
3840 /* That dir doesn't exist, so add the build-time
3841 Lisp dirs instead. */
3842 Vload_path
= nconc2 (Vload_path
, dump_path
);
3844 /* Add leim under the installation dir, if it exists. */
3845 tem
= Fexpand_file_name (build_string ("leim"),
3846 Vinstallation_directory
);
3847 tem1
= Ffile_exists_p (tem
);
3850 if (NILP (Fmember (tem
, Vload_path
)))
3851 Vload_path
= Fcons (tem
, Vload_path
);
3854 /* Add site-list under the installation dir, if it exists. */
3855 tem
= Fexpand_file_name (build_string ("site-lisp"),
3856 Vinstallation_directory
);
3857 tem1
= Ffile_exists_p (tem
);
3860 if (NILP (Fmember (tem
, Vload_path
)))
3861 Vload_path
= Fcons (tem
, Vload_path
);
3864 /* If Emacs was not built in the source directory,
3865 and it is run from where it was built, add to load-path
3866 the lisp, leim and site-lisp dirs under that directory. */
3868 if (NILP (Fequal (Vinstallation_directory
, Vsource_directory
)))
3872 tem
= Fexpand_file_name (build_string ("src/Makefile"),
3873 Vinstallation_directory
);
3874 tem1
= Ffile_exists_p (tem
);
3876 /* Don't be fooled if they moved the entire source tree
3877 AFTER dumping Emacs. If the build directory is indeed
3878 different from the source dir, src/Makefile.in and
3879 src/Makefile will not be found together. */
3880 tem
= Fexpand_file_name (build_string ("src/Makefile.in"),
3881 Vinstallation_directory
);
3882 tem2
= Ffile_exists_p (tem
);
3883 if (!NILP (tem1
) && NILP (tem2
))
3885 tem
= Fexpand_file_name (build_string ("lisp"),
3888 if (NILP (Fmember (tem
, Vload_path
)))
3889 Vload_path
= Fcons (tem
, Vload_path
);
3891 tem
= Fexpand_file_name (build_string ("leim"),
3894 if (NILP (Fmember (tem
, Vload_path
)))
3895 Vload_path
= Fcons (tem
, Vload_path
);
3897 tem
= Fexpand_file_name (build_string ("site-lisp"),
3900 if (NILP (Fmember (tem
, Vload_path
)))
3901 Vload_path
= Fcons (tem
, Vload_path
);
3904 if (!NILP (sitelisp
))
3905 Vload_path
= nconc2 (Fnreverse (sitelisp
), Vload_path
);
3911 /* NORMAL refers to the lisp dir in the source directory. */
3912 /* We used to add ../lisp at the front here, but
3913 that caused trouble because it was copied from dump_path
3914 into Vload_path, aboe, when Vinstallation_directory was non-nil.
3915 It should be unnecessary. */
3916 Vload_path
= decode_env_path (0, normal
);
3917 dump_path
= Vload_path
;
3921 #if (!(defined(WINDOWSNT) || (defined(HAVE_CARBON))))
3922 /* When Emacs is invoked over network shares on NT, PATH_LOADSEARCH is
3923 almost never correct, thereby causing a warning to be printed out that
3924 confuses users. Since PATH_LOADSEARCH is always overridden by the
3925 EMACSLOADPATH environment variable below, disable the warning on NT.
3926 Also, when using the "self-contained" option for Carbon Emacs for MacOSX,
3927 the "standard" paths may not exist and would be overridden by
3928 EMACSLOADPATH as on NT. Since this depends on how the executable
3929 was build and packaged, turn off the warnings in general */
3931 /* Warn if dirs in the *standard* path don't exist. */
3932 if (!turn_off_warning
)
3934 Lisp_Object path_tail
;
3936 for (path_tail
= Vload_path
;
3938 path_tail
= XCDR (path_tail
))
3940 Lisp_Object dirfile
;
3941 dirfile
= Fcar (path_tail
);
3942 if (STRINGP (dirfile
))
3944 dirfile
= Fdirectory_file_name (dirfile
);
3945 if (access (SDATA (dirfile
), 0) < 0)
3946 dir_warning ("Warning: Lisp directory `%s' does not exist.\n",
3951 #endif /* !(WINDOWSNT || HAVE_CARBON) */
3953 /* If the EMACSLOADPATH environment variable is set, use its value.
3954 This doesn't apply if we're dumping. */
3956 if (NILP (Vpurify_flag
)
3957 && egetenv ("EMACSLOADPATH"))
3959 Vload_path
= decode_env_path ("EMACSLOADPATH", normal
);
3963 load_in_progress
= 0;
3964 Vload_file_name
= Qnil
;
3966 load_descriptor_list
= Qnil
;
3968 Vstandard_input
= Qt
;
3969 Vloads_in_progress
= Qnil
;
3972 /* Print a warning, using format string FORMAT, that directory DIRNAME
3973 does not exist. Print it on stderr and put it in *Message*. */
3976 dir_warning (format
, dirname
)
3978 Lisp_Object dirname
;
3981 = (char *) alloca (SCHARS (dirname
) + strlen (format
) + 5);
3983 fprintf (stderr
, format
, SDATA (dirname
));
3984 sprintf (buffer
, format
, SDATA (dirname
));
3985 /* Don't log the warning before we've initialized!! */
3987 message_dolog (buffer
, strlen (buffer
), 0, STRING_MULTIBYTE (dirname
));
3994 defsubr (&Sread_from_string
);
3996 defsubr (&Sintern_soft
);
3997 defsubr (&Sunintern
);
3998 defsubr (&Sget_load_suffixes
);
4000 defsubr (&Seval_buffer
);
4001 defsubr (&Seval_region
);
4002 defsubr (&Sread_char
);
4003 defsubr (&Sread_char_exclusive
);
4004 defsubr (&Sread_event
);
4005 defsubr (&Sget_file_char
);
4006 defsubr (&Smapatoms
);
4007 defsubr (&Slocate_file_internal
);
4009 DEFVAR_LISP ("obarray", &Vobarray
,
4010 doc
: /* Symbol table for use by `intern' and `read'.
4011 It is a vector whose length ought to be prime for best results.
4012 The vector's contents don't make sense if examined from Lisp programs;
4013 to find all the symbols in an obarray, use `mapatoms'. */);
4015 DEFVAR_LISP ("values", &Vvalues
,
4016 doc
: /* List of values of all expressions which were read, evaluated and printed.
4017 Order is reverse chronological. */);
4019 DEFVAR_LISP ("standard-input", &Vstandard_input
,
4020 doc
: /* Stream for read to get input from.
4021 See documentation of `read' for possible values. */);
4022 Vstandard_input
= Qt
;
4024 DEFVAR_LISP ("read-with-symbol-positions", &Vread_with_symbol_positions
,
4025 doc
: /* If non-nil, add position of read symbols to `read-symbol-positions-list'.
4027 If this variable is a buffer, then only forms read from that buffer
4028 will be added to `read-symbol-positions-list'.
4029 If this variable is t, then all read forms will be added.
4030 The effect of all other values other than nil are not currently
4031 defined, although they may be in the future.
4033 The positions are relative to the last call to `read' or
4034 `read-from-string'. It is probably a bad idea to set this variable at
4035 the toplevel; bind it instead. */);
4036 Vread_with_symbol_positions
= Qnil
;
4038 DEFVAR_LISP ("read-symbol-positions-list", &Vread_symbol_positions_list
,
4039 doc
: /* A list mapping read symbols to their positions.
4040 This variable is modified during calls to `read' or
4041 `read-from-string', but only when `read-with-symbol-positions' is
4044 Each element of the list looks like (SYMBOL . CHAR-POSITION), where
4045 CHAR-POSITION is an integer giving the offset of that occurrence of the
4046 symbol from the position where `read' or `read-from-string' started.
4048 Note that a symbol will appear multiple times in this list, if it was
4049 read multiple times. The list is in the same order as the symbols
4051 Vread_symbol_positions_list
= Qnil
;
4053 DEFVAR_LISP ("load-path", &Vload_path
,
4054 doc
: /* *List of directories to search for files to load.
4055 Each element is a string (directory name) or nil (try default directory).
4056 Initialized based on EMACSLOADPATH environment variable, if any,
4057 otherwise to default specified by file `epaths.h' when Emacs was built. */);
4059 DEFVAR_LISP ("load-suffixes", &Vload_suffixes
,
4060 doc
: /* List of suffixes for (compiled or source) Emacs Lisp files.
4061 This list should not include the empty string.
4062 `load' and related functions try to append these suffixes, in order,
4063 to the specified file name if a Lisp suffix is allowed or required. */);
4064 Vload_suffixes
= Fcons (build_string (".elc"),
4065 Fcons (build_string (".el"), Qnil
));
4066 DEFVAR_LISP ("load-file-rep-suffixes", &Vload_file_rep_suffixes
,
4067 doc
: /* List of suffixes that indicate representations of \
4069 This list should normally start with the empty string.
4071 Enabling Auto Compression mode appends the suffixes in
4072 `jka-compr-load-suffixes' to this list and disabling Auto Compression
4073 mode removes them again. `load' and related functions use this list to
4074 determine whether they should look for compressed versions of a file
4075 and, if so, which suffixes they should try to append to the file name
4076 in order to do so. However, if you want to customize which suffixes
4077 the loading functions recognize as compression suffixes, you should
4078 customize `jka-compr-load-suffixes' rather than the present variable. */);
4079 Vload_file_rep_suffixes
= Fcons (empty_unibyte_string
, Qnil
);
4081 DEFVAR_BOOL ("load-in-progress", &load_in_progress
,
4082 doc
: /* Non-nil if inside of `load'. */);
4084 DEFVAR_LISP ("after-load-alist", &Vafter_load_alist
,
4085 doc
: /* An alist of expressions to be evalled when particular files are loaded.
4086 Each element looks like (REGEXP-OR-FEATURE FORMS...).
4088 REGEXP-OR-FEATURE is either a regular expression to match file names, or
4089 a symbol \(a feature name).
4091 When `load' is run and the file-name argument matches an element's
4092 REGEXP-OR-FEATURE, or when `provide' is run and provides the symbol
4093 REGEXP-OR-FEATURE, the FORMS in the element are executed.
4095 An error in FORMS does not undo the load, but does prevent execution of
4096 the rest of the FORMS. */);
4097 Vafter_load_alist
= Qnil
;
4099 DEFVAR_LISP ("load-history", &Vload_history
,
4100 doc
: /* Alist mapping file names to symbols and features.
4101 Each alist element is a list that starts with a file name,
4102 except for one element (optional) that starts with nil and describes
4103 definitions evaluated from buffers not visiting files.
4105 The file name is absolute and is the true file name (i.e. it doesn't
4106 contain symbolic links) of the loaded file.
4108 The remaining elements of each list are symbols defined as variables
4109 and cons cells of the form `(provide . FEATURE)', `(require . FEATURE)',
4110 `(defun . FUNCTION)', `(autoload . SYMBOL)', `(defface . SYMBOL)'
4111 and `(t . SYMBOL)'. An element `(t . SYMBOL)' precedes an entry
4112 `(defun . FUNCTION)', and means that SYMBOL was an autoload before
4113 this file redefined it as a function.
4115 During preloading, the file name recorded is relative to the main Lisp
4116 directory. These file names are converted to absolute at startup. */);
4117 Vload_history
= Qnil
;
4119 DEFVAR_LISP ("load-file-name", &Vload_file_name
,
4120 doc
: /* Full name of file being loaded by `load'. */);
4121 Vload_file_name
= Qnil
;
4123 DEFVAR_LISP ("user-init-file", &Vuser_init_file
,
4124 doc
: /* File name, including directory, of user's initialization file.
4125 If the file loaded had extension `.elc', and the corresponding source file
4126 exists, this variable contains the name of source file, suitable for use
4127 by functions like `custom-save-all' which edit the init file.
4128 While Emacs loads and evaluates the init file, value is the real name
4129 of the file, regardless of whether or not it has the `.elc' extension. */);
4130 Vuser_init_file
= Qnil
;
4132 DEFVAR_LISP ("current-load-list", &Vcurrent_load_list
,
4133 doc
: /* Used for internal purposes by `load'. */);
4134 Vcurrent_load_list
= Qnil
;
4136 DEFVAR_LISP ("load-read-function", &Vload_read_function
,
4137 doc
: /* Function used by `load' and `eval-region' for reading expressions.
4138 The default is nil, which means use the function `read'. */);
4139 Vload_read_function
= Qnil
;
4141 DEFVAR_LISP ("load-source-file-function", &Vload_source_file_function
,
4142 doc
: /* Function called in `load' for loading an Emacs Lisp source file.
4143 This function is for doing code conversion before reading the source file.
4144 If nil, loading is done without any code conversion.
4145 Arguments are FULLNAME, FILE, NOERROR, NOMESSAGE, where
4146 FULLNAME is the full name of FILE.
4147 See `load' for the meaning of the remaining arguments. */);
4148 Vload_source_file_function
= Qnil
;
4150 DEFVAR_BOOL ("load-force-doc-strings", &load_force_doc_strings
,
4151 doc
: /* Non-nil means `load' should force-load all dynamic doc strings.
4152 This is useful when the file being loaded is a temporary copy. */);
4153 load_force_doc_strings
= 0;
4155 DEFVAR_BOOL ("load-convert-to-unibyte", &load_convert_to_unibyte
,
4156 doc
: /* Non-nil means `read' converts strings to unibyte whenever possible.
4157 This is normally bound by `load' and `eval-buffer' to control `read',
4158 and is not meant for users to change. */);
4159 load_convert_to_unibyte
= 0;
4161 DEFVAR_LISP ("source-directory", &Vsource_directory
,
4162 doc
: /* Directory in which Emacs sources were found when Emacs was built.
4163 You cannot count on them to still be there! */);
4165 = Fexpand_file_name (build_string ("../"),
4166 Fcar (decode_env_path (0, PATH_DUMPLOADSEARCH
)));
4168 DEFVAR_LISP ("preloaded-file-list", &Vpreloaded_file_list
,
4169 doc
: /* List of files that were preloaded (when dumping Emacs). */);
4170 Vpreloaded_file_list
= Qnil
;
4172 DEFVAR_LISP ("byte-boolean-vars", &Vbyte_boolean_vars
,
4173 doc
: /* List of all DEFVAR_BOOL variables, used by the byte code optimizer. */);
4174 Vbyte_boolean_vars
= Qnil
;
4176 DEFVAR_BOOL ("load-dangerous-libraries", &load_dangerous_libraries
,
4177 doc
: /* Non-nil means load dangerous compiled Lisp files.
4178 Some versions of XEmacs use different byte codes than Emacs. These
4179 incompatible byte codes can make Emacs crash when it tries to execute
4181 load_dangerous_libraries
= 0;
4183 DEFVAR_LISP ("bytecomp-version-regexp", &Vbytecomp_version_regexp
,
4184 doc
: /* Regular expression matching safe to load compiled Lisp files.
4185 When Emacs loads a compiled Lisp file, it reads the first 512 bytes
4186 from the file, and matches them against this regular expression.
4187 When the regular expression matches, the file is considered to be safe
4188 to load. See also `load-dangerous-libraries'. */);
4189 Vbytecomp_version_regexp
4190 = build_string ("^;;;.\\(in Emacs version\\|bytecomp version FSF\\)");
4192 DEFVAR_LISP ("eval-buffer-list", &Veval_buffer_list
,
4193 doc
: /* List of buffers being read from by calls to `eval-buffer' and `eval-region'. */);
4194 Veval_buffer_list
= Qnil
;
4196 /* Vsource_directory was initialized in init_lread. */
4198 load_descriptor_list
= Qnil
;
4199 staticpro (&load_descriptor_list
);
4201 Qcurrent_load_list
= intern ("current-load-list");
4202 staticpro (&Qcurrent_load_list
);
4204 Qstandard_input
= intern ("standard-input");
4205 staticpro (&Qstandard_input
);
4207 Qread_char
= intern ("read-char");
4208 staticpro (&Qread_char
);
4210 Qget_file_char
= intern ("get-file-char");
4211 staticpro (&Qget_file_char
);
4213 Qbackquote
= intern ("`");
4214 staticpro (&Qbackquote
);
4215 Qcomma
= intern (",");
4216 staticpro (&Qcomma
);
4217 Qcomma_at
= intern (",@");
4218 staticpro (&Qcomma_at
);
4219 Qcomma_dot
= intern (",.");
4220 staticpro (&Qcomma_dot
);
4222 Qinhibit_file_name_operation
= intern ("inhibit-file-name-operation");
4223 staticpro (&Qinhibit_file_name_operation
);
4225 Qascii_character
= intern ("ascii-character");
4226 staticpro (&Qascii_character
);
4228 Qfunction
= intern ("function");
4229 staticpro (&Qfunction
);
4231 Qload
= intern ("load");
4234 Qload_file_name
= intern ("load-file-name");
4235 staticpro (&Qload_file_name
);
4237 Qeval_buffer_list
= intern ("eval-buffer-list");
4238 staticpro (&Qeval_buffer_list
);
4240 Qfile_truename
= intern ("file-truename");
4241 staticpro (&Qfile_truename
) ;
4243 Qdo_after_load_evaluation
= intern ("do-after-load-evaluation");
4244 staticpro (&Qdo_after_load_evaluation
) ;
4246 staticpro (&dump_path
);
4248 staticpro (&read_objects
);
4249 read_objects
= Qnil
;
4250 staticpro (&seen_list
);
4253 Vloads_in_progress
= Qnil
;
4254 staticpro (&Vloads_in_progress
);
4257 /* arch-tag: a0d02733-0f96-4844-a659-9fd53c4f414d
4258 (do not change this comment) */