1 /* Lisp parsing and input streams.
2 Copyright (C) 1985, 1986, 1987, 1988, 1989,
3 1993, 1994, 1995 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
25 #include <sys/types.h>
37 #include "termhooks.h"
41 #include <sys/inode.h>
46 #include <unistd.h> /* to get X_OK */
55 #ifdef LISP_FLOAT_TYPE
61 #endif /* LISP_FLOAT_TYPE */
65 #endif /* HAVE_SETLOCALE */
73 Lisp_Object Qread_char
, Qget_file_char
, Qstandard_input
, Qcurrent_load_list
;
74 Lisp_Object Qvariable_documentation
, Vvalues
, Vstandard_input
, Vafter_load_alist
;
75 Lisp_Object Qascii_character
, Qload
, Qload_file_name
;
76 Lisp_Object Qbackquote
, Qcomma
, Qcomma_at
, Qcomma_dot
, Qfunction
;
77 Lisp_Object Qinhibit_file_name_operation
;
79 extern Lisp_Object Qevent_symbol_element_mask
;
80 extern Lisp_Object Qfile_exists_p
;
82 /* non-zero if inside `load' */
85 /* Directory in which the sources were found. */
86 Lisp_Object Vsource_directory
;
88 /* Search path for files to be loaded. */
89 Lisp_Object Vload_path
;
91 /* This is the user-visible association list that maps features to
92 lists of defs in their load files. */
93 Lisp_Object Vload_history
;
95 /* This is used to build the load history. */
96 Lisp_Object Vcurrent_load_list
;
98 /* Name of file actually being read by `load'. */
99 Lisp_Object Vload_file_name
;
101 /* Function to use for reading, in `load' and friends. */
102 Lisp_Object Vload_read_function
;
104 /* The association list of objects read with the #n=object form.
105 Each member of the list has the form (n . object), and is used to
106 look up the object for the corresponding #n# construct.
107 It must be set to nil before all top-level calls to read0. */
108 Lisp_Object read_objects
;
110 /* Nonzero means load should forcibly load all dynamic doc strings. */
111 static int load_force_doc_strings
;
113 /* Function to use for loading an Emacs lisp source file (not
114 compiled) instead of readevalloop. */
115 Lisp_Object Vload_source_file_function
;
117 /* List of descriptors now open for Fload. */
118 static Lisp_Object load_descriptor_list
;
120 /* File for get_file_char to read from. Use by load. */
121 static FILE *instream
;
123 /* When nonzero, read conses in pure space */
124 static int read_pure
;
126 /* For use within read-from-string (this reader is non-reentrant!!) */
127 static int read_from_string_index
;
128 static int read_from_string_limit
;
130 /* This contains the last string skipped with #@. */
131 static char *saved_doc_string
;
132 /* Length of buffer allocated in saved_doc_string. */
133 static int saved_doc_string_size
;
134 /* Length of actual data in saved_doc_string. */
135 static int saved_doc_string_length
;
136 /* This is the file position that string came from. */
137 static int saved_doc_string_position
;
139 /* Nonzero means inside a new-style backquote
140 with no surrounding parentheses.
141 Fread initializes this to zero, so we need not specbind it
142 or worry about what happens to it when there is an error. */
143 static int new_backquote_flag
;
145 /* Handle unreading and rereading of characters.
146 Write READCHAR to read a character,
147 UNREAD(c) to unread c to be read again.
149 These macros actually read/unread a byte code, multibyte characters
150 are not handled here. The caller should manage them if necessary.
153 #define READCHAR readchar (readcharfun)
154 #define UNREAD(c) unreadchar (readcharfun, c)
157 readchar (readcharfun
)
158 Lisp_Object readcharfun
;
161 register struct buffer
*inbuffer
;
162 register int c
, mpos
;
164 if (BUFFERP (readcharfun
))
166 inbuffer
= XBUFFER (readcharfun
);
168 if (BUF_PT (inbuffer
) >= BUF_ZV (inbuffer
))
170 c
= *(unsigned char *) BUF_CHAR_ADDRESS (inbuffer
, BUF_PT (inbuffer
));
171 SET_BUF_PT (inbuffer
, BUF_PT (inbuffer
) + 1);
175 if (MARKERP (readcharfun
))
177 inbuffer
= XMARKER (readcharfun
)->buffer
;
179 mpos
= marker_position (readcharfun
);
181 if (mpos
> BUF_ZV (inbuffer
) - 1)
183 c
= *(unsigned char *) BUF_CHAR_ADDRESS (inbuffer
, mpos
);
184 if (mpos
!= BUF_GPT (inbuffer
))
185 XMARKER (readcharfun
)->bufpos
++;
187 Fset_marker (readcharfun
, make_number (mpos
+ 1),
188 Fmarker_buffer (readcharfun
));
191 if (EQ (readcharfun
, Qget_file_char
))
195 /* Interrupted reads have been observed while reading over the network */
196 while (c
== EOF
&& ferror (instream
) && errno
== EINTR
)
205 if (STRINGP (readcharfun
))
208 /* This used to be return of a conditional expression,
209 but that truncated -1 to a char on VMS. */
210 if (read_from_string_index
< read_from_string_limit
)
211 c
= XSTRING (readcharfun
)->data
[read_from_string_index
++];
217 tem
= call0 (readcharfun
);
224 /* Unread the character C in the way appropriate for the stream READCHARFUN.
225 If the stream is a user function, call it with the char as argument. */
228 unreadchar (readcharfun
, c
)
229 Lisp_Object readcharfun
;
233 /* Don't back up the pointer if we're unreading the end-of-input mark,
234 since readchar didn't advance it when we read it. */
236 else if (BUFFERP (readcharfun
))
238 if (XBUFFER (readcharfun
) == current_buffer
)
241 SET_BUF_PT (XBUFFER (readcharfun
), BUF_PT (XBUFFER (readcharfun
)) - 1);
243 else if (MARKERP (readcharfun
))
244 XMARKER (readcharfun
)->bufpos
--;
245 else if (STRINGP (readcharfun
))
246 read_from_string_index
--;
247 else if (EQ (readcharfun
, Qget_file_char
))
248 ungetc (c
, instream
);
250 call1 (readcharfun
, make_number (c
));
253 static Lisp_Object
read0 (), read1 (), read_list (), read_vector ();
255 /* get a character from the tty */
257 extern Lisp_Object
read_char ();
259 /* Read input events until we get one that's acceptable for our purposes.
261 If NO_SWITCH_FRAME is non-zero, switch-frame events are stashed
262 until we get a character we like, and then stuffed into
265 If ASCII_REQUIRED is non-zero, we check function key events to see
266 if the unmodified version of the symbol has a Qascii_character
267 property, and use that character, if present.
269 If ERROR_NONASCII is non-zero, we signal an error if the input we
270 get isn't an ASCII character with modifiers. If it's zero but
271 ASCII_REQUIRED is non-zero, we just re-read until we get an ASCII
275 read_filtered_event (no_switch_frame
, ascii_required
, error_nonascii
)
276 int no_switch_frame
, ascii_required
, error_nonascii
;
279 return make_number (getchar ());
281 register Lisp_Object val
, delayed_switch_frame
;
283 delayed_switch_frame
= Qnil
;
285 /* Read until we get an acceptable event. */
287 val
= read_char (0, 0, 0, Qnil
, 0);
292 /* switch-frame events are put off until after the next ASCII
293 character. This is better than signaling an error just because
294 the last characters were typed to a separate minibuffer frame,
295 for example. Eventually, some code which can deal with
296 switch-frame events will read it and process it. */
298 && EVENT_HAS_PARAMETERS (val
)
299 && EQ (EVENT_HEAD (val
), Qswitch_frame
))
301 delayed_switch_frame
= val
;
307 /* Convert certain symbols to their ASCII equivalents. */
310 Lisp_Object tem
, tem1
, tem2
;
311 tem
= Fget (val
, Qevent_symbol_element_mask
);
314 tem1
= Fget (Fcar (tem
), Qascii_character
);
315 /* Merge this symbol's modifier bits
316 with the ASCII equivalent of its basic code. */
318 XSETFASTINT (val
, XINT (tem1
) | XINT (Fcar (Fcdr (tem
))));
322 /* If we don't have a character now, deal with it appropriately. */
327 Vunread_command_events
= Fcons (val
, Qnil
);
328 error ("Non-character input-event");
335 if (! NILP (delayed_switch_frame
))
336 unread_switch_frame
= delayed_switch_frame
;
342 DEFUN ("read-char", Fread_char
, Sread_char
, 0, 0, 0,
343 "Read a character from the command input (keyboard or macro).\n\
344 It is returned as a number.\n\
345 If the user generates an event which is not a character (i.e. a mouse\n\
346 click or function key event), `read-char' signals an error. As an\n\
347 exception, switch-frame events are put off until non-ASCII events can\n\
349 If you want to read non-character events, or ignore them, call\n\
350 `read-event' or `read-char-exclusive' instead.")
353 return read_filtered_event (1, 1, 1);
356 DEFUN ("read-event", Fread_event
, Sread_event
, 0, 0, 0,
357 "Read an event object from the input stream.")
360 return read_filtered_event (0, 0, 0);
363 DEFUN ("read-char-exclusive", Fread_char_exclusive
, Sread_char_exclusive
, 0, 0, 0,
364 "Read a character from the command input (keyboard or macro).\n\
365 It is returned as a number. Non-character events are ignored.")
368 return read_filtered_event (1, 1, 0);
371 DEFUN ("get-file-char", Fget_file_char
, Sget_file_char
, 0, 0, 0,
372 "Don't use this yourself.")
375 register Lisp_Object val
;
376 XSETINT (val
, getc (instream
));
380 static void readevalloop ();
381 static Lisp_Object
load_unwind ();
382 static Lisp_Object
load_descriptor_unwind ();
384 DEFUN ("load", Fload
, Sload
, 1, 4, 0,
385 "Execute a file of Lisp code named FILE.\n\
386 First try FILE with `.elc' appended, then try with `.el',\n\
387 then try FILE unmodified.\n\
388 This function searches the directories in `load-path'.\n\
389 If optional second arg NOERROR is non-nil,\n\
390 report no error if FILE doesn't exist.\n\
391 Print messages at start and end of loading unless\n\
392 optional third arg NOMESSAGE is non-nil.\n\
393 If optional fourth arg NOSUFFIX is non-nil, don't try adding\n\
394 suffixes `.elc' or `.el' to the specified name FILE.\n\
395 Return t if file exists.")
396 (file
, noerror
, nomessage
, nosuffix
)
397 Lisp_Object file
, noerror
, nomessage
, nosuffix
;
399 register FILE *stream
;
400 register int fd
= -1;
401 register Lisp_Object lispstream
;
402 int count
= specpdl_ptr
- specpdl
;
406 /* 1 means we printed the ".el is newer" message. */
408 /* 1 means we are loading a compiled file. */
412 char *dosmode
= "rt";
415 CHECK_STRING (file
, 0);
417 /* If file name is magic, call the handler. */
418 handler
= Ffind_file_name_handler (file
, Qload
);
420 return call5 (handler
, Qload
, file
, noerror
, nomessage
, nosuffix
);
422 /* Do this after the handler to avoid
423 the need to gcpro noerror, nomessage and nosuffix.
424 (Below here, we care only whether they are nil or not.) */
425 file
= Fsubstitute_in_file_name (file
);
427 /* Avoid weird lossage with null string as arg,
428 since it would try to load a directory as a Lisp file */
429 if (XSTRING (file
)->size
> 0)
432 fd
= openp (Vload_path
, file
, !NILP (nosuffix
) ? "" : ".elc:.el:",
441 Fsignal (Qfile_error
, Fcons (build_string ("Cannot open load file"),
442 Fcons (file
, Qnil
)));
447 /* If FD is 0, that means openp found a remote file. */
450 handler
= Ffind_file_name_handler (found
, Qload
);
451 return call5 (handler
, Qload
, found
, noerror
, nomessage
, Qt
);
454 if (!bcmp (&(XSTRING (found
)->data
[XSTRING (found
)->size
- 4]),
465 stat ((char *)XSTRING (found
)->data
, &s1
);
466 XSTRING (found
)->data
[XSTRING (found
)->size
- 1] = 0;
467 result
= stat ((char *)XSTRING (found
)->data
, &s2
);
468 if (result
>= 0 && (unsigned) s1
.st_mtime
< (unsigned) s2
.st_mtime
)
470 /* Make the progress messages mention that source is newer. */
473 /* If we won't print another message, mention this anyway. */
474 if (! NILP (nomessage
))
475 message ("Source file `%s' newer than byte-compiled file",
476 XSTRING (found
)->data
);
478 XSTRING (found
)->data
[XSTRING (found
)->size
- 1] = 'c';
482 /* We are loading a source file (*.el). */
483 if (!NILP (Vload_source_file_function
))
486 return call4 (Vload_source_file_function
, found
, file
,
487 NILP (noerror
) ? Qnil
: Qt
,
488 NILP (nomessage
) ? Qnil
: Qt
);
494 stream
= fopen ((char *) XSTRING (found
)->data
, dosmode
);
495 #else /* not DOS_NT */
496 stream
= fdopen (fd
, "r");
497 #endif /* not DOS_NT */
501 error ("Failure to create stdio stream for %s", XSTRING (file
)->data
);
504 if (NILP (nomessage
))
507 message ("Loading %s (compiled; note, source file is newer)...",
508 XSTRING (file
)->data
);
510 message ("Loading %s (compiled)...", XSTRING (file
)->data
);
512 message ("Loading %s...", XSTRING (file
)->data
);
516 lispstream
= Fcons (Qnil
, Qnil
);
517 XSETFASTINT (XCONS (lispstream
)->car
, (EMACS_UINT
)stream
>> 16);
518 XSETFASTINT (XCONS (lispstream
)->cdr
, (EMACS_UINT
)stream
& 0xffff);
519 record_unwind_protect (load_unwind
, lispstream
);
520 record_unwind_protect (load_descriptor_unwind
, load_descriptor_list
);
521 specbind (Qload_file_name
, found
);
522 specbind (Qinhibit_file_name_operation
, Qnil
);
524 = Fcons (make_number (fileno (stream
)), load_descriptor_list
);
526 readevalloop (Qget_file_char
, stream
, file
, Feval
, 0);
527 unbind_to (count
, Qnil
);
529 /* Run any load-hooks for this file. */
530 temp
= Fassoc (file
, Vafter_load_alist
);
532 Fprogn (Fcdr (temp
));
535 if (saved_doc_string
)
536 free (saved_doc_string
);
537 saved_doc_string
= 0;
538 saved_doc_string_size
= 0;
540 if (!noninteractive
&& NILP (nomessage
))
543 message ("Loading %s (compiled; note, source file is newer)...done",
544 XSTRING (file
)->data
);
546 message ("Loading %s (compiled)...done", XSTRING (file
)->data
);
548 message ("Loading %s...done", XSTRING (file
)->data
);
554 load_unwind (stream
) /* used as unwind-protect function in load */
557 fclose ((FILE *) (XFASTINT (XCONS (stream
)->car
) << 16
558 | XFASTINT (XCONS (stream
)->cdr
)));
559 if (--load_in_progress
< 0) load_in_progress
= 0;
564 load_descriptor_unwind (oldlist
)
567 load_descriptor_list
= oldlist
;
571 /* Close all descriptors in use for Floads.
572 This is used when starting a subprocess. */
579 for (tail
= load_descriptor_list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
580 close (XFASTINT (XCONS (tail
)->car
));
585 complete_filename_p (pathname
)
586 Lisp_Object pathname
;
588 register unsigned char *s
= XSTRING (pathname
)->data
;
589 return (IS_DIRECTORY_SEP (s
[0])
590 || (XSTRING (pathname
)->size
> 2
591 && IS_DEVICE_SEP (s
[1]) && IS_DIRECTORY_SEP (s
[2]))
601 /* Search for a file whose name is STR, looking in directories
602 in the Lisp list PATH, and trying suffixes from SUFFIX.
603 SUFFIX is a string containing possible suffixes separated by colons.
604 On success, returns a file descriptor. On failure, returns -1.
606 EXEC_ONLY nonzero means don't open the files,
607 just look for one that is executable. In this case,
608 returns 1 on success.
610 If STOREPTR is nonzero, it points to a slot where the name of
611 the file actually found should be stored as a Lisp string.
612 nil is stored there on failure.
614 If the file we find is remote, return 0
615 but store the found remote file name in *STOREPTR.
616 We do not check for remote files if EXEC_ONLY is nonzero. */
619 openp (path
, str
, suffix
, storeptr
, exec_only
)
620 Lisp_Object path
, str
;
622 Lisp_Object
*storeptr
;
628 register char *fn
= buf
;
631 Lisp_Object filename
;
639 if (complete_filename_p (str
))
642 for (; !NILP (path
); path
= Fcdr (path
))
646 filename
= Fexpand_file_name (str
, Fcar (path
));
647 if (!complete_filename_p (filename
))
648 /* If there are non-absolute elts in PATH (eg ".") */
649 /* Of course, this could conceivably lose if luser sets
650 default-directory to be something non-absolute... */
652 filename
= Fexpand_file_name (filename
, current_buffer
->directory
);
653 if (!complete_filename_p (filename
))
654 /* Give up on this path element! */
658 /* Calculate maximum size of any filename made from
659 this path element/specified file name and any possible suffix. */
660 want_size
= strlen (suffix
) + XSTRING (filename
)->size
+ 1;
661 if (fn_size
< want_size
)
662 fn
= (char *) alloca (fn_size
= 100 + want_size
);
666 /* Loop over suffixes. */
669 char *esuffix
= (char *) index (nsuffix
, ':');
670 int lsuffix
= esuffix
? esuffix
- nsuffix
: strlen (nsuffix
);
673 /* Concatenate path element/specified name with the suffix.
674 If the directory starts with /:, remove that. */
675 if (XSTRING (filename
)->size
> 2
676 && XSTRING (filename
)->data
[0] == '/'
677 && XSTRING (filename
)->data
[1] == ':')
679 strncpy (fn
, XSTRING (filename
)->data
+ 2,
680 XSTRING (filename
)->size
- 2);
681 fn
[XSTRING (filename
)->size
- 2] = 0;
685 strncpy (fn
, XSTRING (filename
)->data
, XSTRING (filename
)->size
);
686 fn
[XSTRING (filename
)->size
] = 0;
689 if (lsuffix
!= 0) /* Bug happens on CCI if lsuffix is 0. */
690 strncat (fn
, nsuffix
, lsuffix
);
692 /* Check that the file exists and is not a directory. */
696 handler
= Ffind_file_name_handler (filename
, Qfile_exists_p
);
697 if (! NILP (handler
) && ! exec_only
)
702 string
= build_string (fn
);
703 exists
= ! NILP (exec_only
? Ffile_executable_p (string
)
704 : Ffile_readable_p (string
));
706 && ! NILP (Ffile_directory_p (build_string (fn
))))
711 /* We succeeded; return this descriptor and filename. */
713 *storeptr
= build_string (fn
);
720 int exists
= (stat (fn
, &st
) >= 0
721 && (st
.st_mode
& S_IFMT
) != S_IFDIR
);
724 /* Check that we can access or open it. */
726 fd
= (access (fn
, X_OK
) == 0) ? 1 : -1;
728 fd
= open (fn
, O_RDONLY
, 0);
732 /* We succeeded; return this descriptor and filename. */
734 *storeptr
= build_string (fn
);
741 /* Advance to next suffix. */
744 nsuffix
+= lsuffix
+ 1;
755 /* Merge the list we've accumulated of globals from the current input source
756 into the load_history variable. The details depend on whether
757 the source has an associated file name or not. */
760 build_load_history (stream
, source
)
764 register Lisp_Object tail
, prev
, newelt
;
765 register Lisp_Object tem
, tem2
;
766 register int foundit
, loading
;
768 /* Don't bother recording anything for preloaded files. */
769 if (!NILP (Vpurify_flag
))
772 loading
= stream
|| !NARROWED
;
774 tail
= Vload_history
;
781 /* Find the feature's previous assoc list... */
782 if (!NILP (Fequal (source
, Fcar (tem
))))
786 /* If we're loading, remove it. */
790 Vload_history
= Fcdr (tail
);
792 Fsetcdr (prev
, Fcdr (tail
));
795 /* Otherwise, cons on new symbols that are not already members. */
798 tem2
= Vcurrent_load_list
;
802 newelt
= Fcar (tem2
);
804 if (NILP (Fmemq (newelt
, tem
)))
805 Fsetcar (tail
, Fcons (Fcar (tem
),
806 Fcons (newelt
, Fcdr (tem
))));
819 /* If we're loading, cons the new assoc onto the front of load-history,
820 the most-recently-loaded position. Also do this if we didn't find
821 an existing member for the current source. */
822 if (loading
|| !foundit
)
823 Vload_history
= Fcons (Fnreverse (Vcurrent_load_list
),
828 unreadpure () /* Used as unwind-protect function in readevalloop */
835 readevalloop (readcharfun
, stream
, sourcename
, evalfun
, printflag
)
836 Lisp_Object readcharfun
;
838 Lisp_Object sourcename
;
839 Lisp_Object (*evalfun
) ();
843 register Lisp_Object val
;
844 int count
= specpdl_ptr
- specpdl
;
846 struct buffer
*b
= 0;
848 if (BUFFERP (readcharfun
))
849 b
= XBUFFER (readcharfun
);
850 else if (MARKERP (readcharfun
))
851 b
= XMARKER (readcharfun
)->buffer
;
853 specbind (Qstandard_input
, readcharfun
);
854 specbind (Qcurrent_load_list
, Qnil
);
858 LOADHIST_ATTACH (sourcename
);
862 if (b
!= 0 && NILP (b
->name
))
863 error ("Reading from killed buffer");
869 while ((c
= READCHAR
) != '\n' && c
!= -1);
874 /* Ignore whitespace here, so we can detect eof. */
875 if (c
== ' ' || c
== '\t' || c
== '\n' || c
== '\f' || c
== '\r')
878 if (!NILP (Vpurify_flag
) && c
== '(')
880 int count1
= specpdl_ptr
- specpdl
;
881 record_unwind_protect (unreadpure
, Qnil
);
882 val
= read_list (-1, readcharfun
);
883 unbind_to (count1
, Qnil
);
889 if (NILP (Vload_read_function
))
890 val
= read0 (readcharfun
);
892 val
= call1 (Vload_read_function
, readcharfun
);
895 val
= (*evalfun
) (val
);
898 Vvalues
= Fcons (val
, Vvalues
);
899 if (EQ (Vstandard_output
, Qt
))
906 build_load_history (stream
, sourcename
);
909 unbind_to (count
, Qnil
);
914 DEFUN ("eval-buffer", Feval_buffer
, Seval_buffer
, 0, 2, "",
915 "Execute the current buffer as Lisp code.\n\
916 Programs can pass two arguments, BUFFER and PRINTFLAG.\n\
917 BUFFER is the buffer to evaluate (nil means use current buffer).\n\
918 PRINTFLAG controls printing of output:\n\
919 nil means discard it; anything else is stream for print.\n\
921 This function preserves the position of point.")
923 Lisp_Object buffer
, printflag
;
925 int count
= specpdl_ptr
- specpdl
;
926 Lisp_Object tem
, buf
;
929 buf
= Fcurrent_buffer ();
931 buf
= Fget_buffer (buffer
);
933 error ("No such buffer.");
935 if (NILP (printflag
))
939 specbind (Qstandard_output
, tem
);
940 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
941 BUF_SET_PT (XBUFFER (buf
), BUF_BEGV (XBUFFER (buf
)));
942 readevalloop (buf
, 0, XBUFFER (buf
)->filename
, Feval
, !NILP (printflag
));
943 unbind_to (count
, Qnil
);
949 DEFUN ("eval-current-buffer", Feval_current_buffer
, Seval_current_buffer
, 0, 1, "",
950 "Execute the current buffer as Lisp code.\n\
951 Programs can pass argument PRINTFLAG which controls printing of output:\n\
952 nil means discard it; anything else is stream for print.\n\
954 If there is no error, point does not move. If there is an error,\n\
955 point remains at the end of the last character read from the buffer.")
957 Lisp_Object printflag
;
959 int count
= specpdl_ptr
- specpdl
;
960 Lisp_Object tem
, cbuf
;
962 cbuf
= Fcurrent_buffer ()
964 if (NILP (printflag
))
968 specbind (Qstandard_output
, tem
);
969 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
971 readevalloop (cbuf
, 0, XBUFFER (cbuf
)->filename
, Feval
, !NILP (printflag
));
972 return unbind_to (count
, Qnil
);
976 DEFUN ("eval-region", Feval_region
, Seval_region
, 2, 3, "r",
977 "Execute the region as Lisp code.\n\
978 When called from programs, expects two arguments,\n\
979 giving starting and ending indices in the current buffer\n\
980 of the text to be executed.\n\
981 Programs can pass third argument PRINTFLAG which controls output:\n\
982 nil means discard it; anything else is stream for printing it.\n\
984 If there is no error, point does not move. If there is an error,\n\
985 point remains at the end of the last character read from the buffer.")
986 (start
, end
, printflag
)
987 Lisp_Object start
, end
, printflag
;
989 int count
= specpdl_ptr
- specpdl
;
990 Lisp_Object tem
, cbuf
;
992 cbuf
= Fcurrent_buffer ();
994 if (NILP (printflag
))
998 specbind (Qstandard_output
, tem
);
1000 if (NILP (printflag
))
1001 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
1002 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
1004 /* This both uses start and checks its type. */
1006 Fnarrow_to_region (make_number (BEGV
), end
);
1007 readevalloop (cbuf
, 0, XBUFFER (cbuf
)->filename
, Feval
, !NILP (printflag
));
1009 return unbind_to (count
, Qnil
);
1012 #endif /* standalone */
1014 DEFUN ("read", Fread
, Sread
, 0, 1, 0,
1015 "Read one Lisp expression as text from STREAM, return as Lisp object.\n\
1016 If STREAM is nil, use the value of `standard-input' (which see).\n\
1017 STREAM or the value of `standard-input' may be:\n\
1018 a buffer (read from point and advance it)\n\
1019 a marker (read from where it points and advance it)\n\
1020 a function (call it with no arguments for each character,\n\
1021 call it with a char as argument to push a char back)\n\
1022 a string (takes text from string, starting at the beginning)\n\
1023 t (read text line using minibuffer and use it).")
1027 extern Lisp_Object
Fread_minibuffer ();
1030 stream
= Vstandard_input
;
1031 if (EQ (stream
, Qt
))
1032 stream
= Qread_char
;
1034 new_backquote_flag
= 0;
1035 read_objects
= Qnil
;
1038 if (EQ (stream
, Qread_char
))
1039 return Fread_minibuffer (build_string ("Lisp expression: "), Qnil
);
1042 if (STRINGP (stream
))
1043 return Fcar (Fread_from_string (stream
, Qnil
, Qnil
));
1045 return read0 (stream
);
1048 DEFUN ("read-from-string", Fread_from_string
, Sread_from_string
, 1, 3, 0,
1049 "Read one Lisp expression which is represented as text by STRING.\n\
1050 Returns a cons: (OBJECT-READ . FINAL-STRING-INDEX).\n\
1051 START and END optionally delimit a substring of STRING from which to read;\n\
1052 they default to 0 and (length STRING) respectively.")
1053 (string
, start
, end
)
1054 Lisp_Object string
, start
, end
;
1056 int startval
, endval
;
1059 CHECK_STRING (string
,0);
1062 endval
= XSTRING (string
)->size
;
1064 { CHECK_NUMBER (end
,2);
1065 endval
= XINT (end
);
1066 if (endval
< 0 || endval
> XSTRING (string
)->size
)
1067 args_out_of_range (string
, end
);
1073 { CHECK_NUMBER (start
,1);
1074 startval
= XINT (start
);
1075 if (startval
< 0 || startval
> endval
)
1076 args_out_of_range (string
, start
);
1079 read_from_string_index
= startval
;
1080 read_from_string_limit
= endval
;
1082 new_backquote_flag
= 0;
1083 read_objects
= Qnil
;
1085 tem
= read0 (string
);
1086 return Fcons (tem
, make_number (read_from_string_index
));
1089 /* Use this for recursive reads, in contexts where internal tokens
1093 Lisp_Object readcharfun
;
1095 register Lisp_Object val
;
1098 val
= read1 (readcharfun
, &c
, 0);
1100 Fsignal (Qinvalid_read_syntax
, Fcons (make_string (&c
, 1), Qnil
));
1105 static int read_buffer_size
;
1106 static char *read_buffer
;
1108 /* Read multibyte form and return it as a character. C is a first
1109 byte of multibyte form, and rest of them are read from
1112 read_multibyte (c
, readcharfun
)
1114 Lisp_Object readcharfun
;
1116 /* We need the actual character code of this multibyte
1118 unsigned char str
[MAX_LENGTH_OF_MULTI_BYTE_FORM
];
1122 while ((c
= READCHAR
) >= 0xA0
1123 && len
< MAX_LENGTH_OF_MULTI_BYTE_FORM
)
1126 return STRING_CHAR (str
, len
);
1130 read_escape (readcharfun
)
1131 Lisp_Object readcharfun
;
1133 register int c
= READCHAR
;
1137 error ("End of file");
1163 error ("Invalid escape character syntax");
1166 c
= read_escape (readcharfun
);
1167 return c
| meta_modifier
;
1172 error ("Invalid escape character syntax");
1175 c
= read_escape (readcharfun
);
1176 return c
| shift_modifier
;
1181 error ("Invalid escape character syntax");
1184 c
= read_escape (readcharfun
);
1185 return c
| hyper_modifier
;
1190 error ("Invalid escape character syntax");
1193 c
= read_escape (readcharfun
);
1194 return c
| alt_modifier
;
1199 error ("Invalid escape character syntax");
1202 c
= read_escape (readcharfun
);
1203 return c
| super_modifier
;
1208 error ("Invalid escape character syntax");
1212 c
= read_escape (readcharfun
);
1213 if ((c
& 0177) == '?')
1215 /* ASCII control chars are made from letters (both cases),
1216 as well as the non-letters within 0100...0137. */
1217 else if ((c
& 0137) >= 0101 && (c
& 0137) <= 0132)
1218 return (c
& (037 | ~0177));
1219 else if ((c
& 0177) >= 0100 && (c
& 0177) <= 0137)
1220 return (c
& (037 | ~0177));
1222 return c
| ctrl_modifier
;
1232 /* An octal escape, as in ANSI C. */
1234 register int i
= c
- '0';
1235 register int count
= 0;
1238 if ((c
= READCHAR
) >= '0' && c
<= '7')
1253 /* A hex escape, as in ANSI C. */
1259 if (c
>= '0' && c
<= '9')
1264 else if ((c
>= 'a' && c
<= 'f')
1265 || (c
>= 'A' && c
<= 'F'))
1268 if (c
>= 'a' && c
<= 'f')
1283 if (BASE_LEADING_CODE_P (c
))
1284 c
= read_multibyte (c
, readcharfun
);
1289 /* If the next token is ')' or ']' or '.', we store that character
1290 in *PCH and the return value is not interesting. Else, we store
1291 zero in *PCH and we read and return one lisp object.
1293 FIRST_IN_LIST is nonzero if this is the first element of a list. */
1296 read1 (readcharfun
, pch
, first_in_list
)
1297 register Lisp_Object readcharfun
;
1302 int uninterned_symbol
= 0;
1309 if (c
< 0) return Fsignal (Qend_of_file
, Qnil
);
1314 return read_list (0, readcharfun
);
1317 return read_vector (readcharfun
);
1334 tmp
= read_vector (readcharfun
);
1335 if (XVECTOR (tmp
)->size
< CHAR_TABLE_STANDARD_SLOTS
1336 || XVECTOR (tmp
)->size
> CHAR_TABLE_STANDARD_SLOTS
+ 10)
1337 error ("Invalid size char-table");
1338 XSETCHAR_TABLE (tmp
, XCHAR_TABLE (tmp
));
1339 XCHAR_TABLE (tmp
)->top
= Qt
;
1348 tmp
= read_vector (readcharfun
);
1349 if (XVECTOR (tmp
)->size
!= SUB_CHAR_TABLE_STANDARD_SLOTS
)
1350 error ("Invalid size char-table");
1351 XSETCHAR_TABLE (tmp
, XCHAR_TABLE (tmp
));
1352 XCHAR_TABLE (tmp
)->top
= Qnil
;
1355 Fsignal (Qinvalid_read_syntax
,
1356 Fcons (make_string ("#^^", 3), Qnil
));
1358 Fsignal (Qinvalid_read_syntax
, Fcons (make_string ("#^", 2), Qnil
));
1363 length
= read1 (readcharfun
, pch
, first_in_list
);
1367 Lisp_Object tmp
, val
;
1368 int size_in_chars
= ((XFASTINT (length
) + BITS_PER_CHAR
- 1)
1372 tmp
= read1 (readcharfun
, pch
, first_in_list
);
1373 if (size_in_chars
!= XSTRING (tmp
)->size
1374 /* We used to print 1 char too many
1375 when the number of bits was a multiple of 8.
1376 Accept such input in case it came from an old version. */
1377 && ! (XFASTINT (length
)
1378 == (XSTRING (tmp
)->size
- 1) * BITS_PER_CHAR
))
1379 Fsignal (Qinvalid_read_syntax
,
1380 Fcons (make_string ("#&...", 5), Qnil
));
1382 val
= Fmake_bool_vector (length
, Qnil
);
1383 bcopy (XSTRING (tmp
)->data
, XBOOL_VECTOR (val
)->data
,
1387 Fsignal (Qinvalid_read_syntax
, Fcons (make_string ("#&...", 5),
1392 /* Accept compiled functions at read-time so that we don't have to
1393 build them using function calls. */
1395 tmp
= read_vector (readcharfun
);
1396 return Fmake_byte_code (XVECTOR (tmp
)->size
,
1397 XVECTOR (tmp
)->contents
);
1399 #ifdef USE_TEXT_PROPERTIES
1403 struct gcpro gcpro1
;
1406 /* Read the string itself. */
1407 tmp
= read1 (readcharfun
, &ch
, 0);
1408 if (ch
!= 0 || !STRINGP (tmp
))
1409 Fsignal (Qinvalid_read_syntax
, Fcons (make_string ("#", 1), Qnil
));
1411 /* Read the intervals and their properties. */
1414 Lisp_Object beg
, end
, plist
;
1416 beg
= read1 (readcharfun
, &ch
, 0);
1420 end
= read1 (readcharfun
, &ch
, 0);
1422 plist
= read1 (readcharfun
, &ch
, 0);
1424 Fsignal (Qinvalid_read_syntax
,
1425 Fcons (build_string ("invalid string property list"),
1427 Fset_text_properties (beg
, end
, plist
, tmp
);
1433 /* #@NUMBER is used to skip NUMBER following characters.
1434 That's used in .elc files to skip over doc strings
1435 and function definitions. */
1440 /* Read a decimal integer. */
1441 while ((c
= READCHAR
) >= 0
1442 && c
>= '0' && c
<= '9')
1450 #ifndef DOS_NT /* I don't know if filepos works right on MSDOS and Windoze. */
1451 if (load_force_doc_strings
&& EQ (readcharfun
, Qget_file_char
))
1453 /* If we are supposed to force doc strings into core right now,
1454 record the last string that we skipped,
1455 and record where in the file it comes from. */
1456 if (saved_doc_string_size
== 0)
1458 saved_doc_string_size
= nskip
+ 100;
1459 saved_doc_string
= (char *) xmalloc (saved_doc_string_size
);
1461 if (nskip
> saved_doc_string_size
)
1463 saved_doc_string_size
= nskip
+ 100;
1464 saved_doc_string
= (char *) xrealloc (saved_doc_string
,
1465 saved_doc_string_size
);
1468 saved_doc_string_position
= ftell (instream
);
1470 /* Copy that many characters into saved_doc_string. */
1471 for (i
= 0; i
< nskip
&& c
>= 0; i
++)
1472 saved_doc_string
[i
] = c
= READCHAR
;
1474 saved_doc_string_length
= i
;
1477 #endif /* not DOS_NT */
1479 /* Skip that many characters. */
1480 for (i
= 0; i
< nskip
&& c
>= 0; i
++)
1486 return Vload_file_name
;
1488 return Fcons (Qfunction
, Fcons (read0 (readcharfun
), Qnil
));
1489 /* #:foo is the uninterned symbol named foo. */
1492 uninterned_symbol
= 1;
1496 /* Reader forms that can reuse previously read objects. */
1497 if (c
>= '0' && c
<= '9')
1502 /* Read a non-negative integer. */
1503 while (c
>= '0' && c
<= '9')
1509 /* #n=object returns object, but associates it with n for #n#. */
1512 tem
= read0 (readcharfun
);
1513 read_objects
= Fcons (Fcons (make_number (n
), tem
), read_objects
);
1516 /* #n# returns a previously read object. */
1519 tem
= Fassq (make_number (n
), read_objects
);
1522 /* Fall through to error message. */
1524 /* Fall through to error message. */
1528 Fsignal (Qinvalid_read_syntax
, Fcons (make_string ("#", 1), Qnil
));
1531 while ((c
= READCHAR
) >= 0 && c
!= '\n');
1536 return Fcons (Qquote
, Fcons (read0 (readcharfun
), Qnil
));
1546 new_backquote_flag
= 1;
1547 value
= read0 (readcharfun
);
1548 new_backquote_flag
= 0;
1550 return Fcons (Qbackquote
, Fcons (value
, Qnil
));
1554 if (new_backquote_flag
)
1556 Lisp_Object comma_type
= Qnil
;
1561 comma_type
= Qcomma_at
;
1563 comma_type
= Qcomma_dot
;
1566 if (ch
>= 0) UNREAD (ch
);
1567 comma_type
= Qcomma
;
1570 new_backquote_flag
= 0;
1571 value
= read0 (readcharfun
);
1572 new_backquote_flag
= 1;
1573 return Fcons (comma_type
, Fcons (value
, Qnil
));
1580 register Lisp_Object val
;
1583 if (c
< 0) return Fsignal (Qend_of_file
, Qnil
);
1586 c
= read_escape (readcharfun
);
1587 else if (BASE_LEADING_CODE_P (c
))
1588 c
= read_multibyte (c
, readcharfun
);
1596 register char *p
= read_buffer
;
1597 register char *end
= read_buffer
+ read_buffer_size
;
1601 while ((c
= READCHAR
) >= 0
1606 char *new = (char *) xrealloc (read_buffer
, read_buffer_size
*= 2);
1607 p
+= new - read_buffer
;
1608 read_buffer
+= new - read_buffer
;
1609 end
= read_buffer
+ read_buffer_size
;
1612 c
= read_escape (readcharfun
);
1613 /* c is -1 if \ newline has just been seen */
1616 if (p
== read_buffer
)
1621 /* Allow `\C- ' and `\C-?'. */
1622 if (c
== (CHAR_CTL
| ' '))
1624 else if (c
== (CHAR_CTL
| '?'))
1628 /* Move the meta bit to the right place for a string. */
1629 c
= (c
& ~CHAR_META
) | 0x80;
1631 error ("Invalid modifier in string");
1635 if (c
< 0) return Fsignal (Qend_of_file
, Qnil
);
1637 /* If purifying, and string starts with \ newline,
1638 return zero instead. This is for doc strings
1639 that we are really going to find in etc/DOC.nn.nn */
1640 if (!NILP (Vpurify_flag
) && NILP (Vdoc_file_name
) && cancel
)
1641 return make_number (0);
1644 return make_pure_string (read_buffer
, p
- read_buffer
);
1646 return make_string (read_buffer
, p
- read_buffer
);
1651 #ifdef LISP_FLOAT_TYPE
1652 /* If a period is followed by a number, then we should read it
1653 as a floating point number. Otherwise, it denotes a dotted
1655 int next_char
= READCHAR
;
1658 if (! (next_char
>= '0' && next_char
<= '9'))
1665 /* Otherwise, we fall through! Note that the atom-reading loop
1666 below will now loop at least once, assuring that we will not
1667 try to UNREAD two characters in a row. */
1671 if (c
<= 040) goto retry
;
1673 register char *p
= read_buffer
;
1677 register char *end
= read_buffer
+ read_buffer_size
;
1680 !(c
== '\"' || c
== '\'' || c
== ';' || c
== '?'
1681 || c
== '(' || c
== ')'
1682 #ifndef LISP_FLOAT_TYPE
1683 /* If we have floating-point support, then we need
1684 to allow <digits><dot><digits>. */
1686 #endif /* not LISP_FLOAT_TYPE */
1687 || c
== '[' || c
== ']' || c
== '#'
1692 register char *new = (char *) xrealloc (read_buffer
, read_buffer_size
*= 2);
1693 p
+= new - read_buffer
;
1694 read_buffer
+= new - read_buffer
;
1695 end
= read_buffer
+ read_buffer_size
;
1708 char *new = (char *) xrealloc (read_buffer
, read_buffer_size
*= 2);
1709 p
+= new - read_buffer
;
1710 read_buffer
+= new - read_buffer
;
1711 /* end = read_buffer + read_buffer_size; */
1718 if (!quoted
&& !uninterned_symbol
)
1721 register Lisp_Object val
;
1723 if (*p1
== '+' || *p1
== '-') p1
++;
1724 /* Is it an integer? */
1727 while (p1
!= p
&& (c
= *p1
) >= '0' && c
<= '9') p1
++;
1728 #ifdef LISP_FLOAT_TYPE
1729 /* Integers can have trailing decimal points. */
1730 if (p1
> read_buffer
&& p1
< p
&& *p1
== '.') p1
++;
1733 /* It is an integer. */
1735 #ifdef LISP_FLOAT_TYPE
1739 if (sizeof (int) == sizeof (EMACS_INT
))
1740 XSETINT (val
, atoi (read_buffer
));
1741 else if (sizeof (long) == sizeof (EMACS_INT
))
1742 XSETINT (val
, atol (read_buffer
));
1748 #ifdef LISP_FLOAT_TYPE
1749 if (isfloat_string (read_buffer
))
1750 return make_float (atof (read_buffer
));
1754 if (uninterned_symbol
)
1755 return make_symbol (read_buffer
);
1757 return intern (read_buffer
);
1762 #ifdef LISP_FLOAT_TYPE
1777 if (*cp
== '+' || *cp
== '-')
1780 if (*cp
>= '0' && *cp
<= '9')
1783 while (*cp
>= '0' && *cp
<= '9')
1791 if (*cp
>= '0' && *cp
<= '9')
1794 while (*cp
>= '0' && *cp
<= '9')
1797 if (*cp
== 'e' || *cp
== 'E')
1801 if (*cp
== '+' || *cp
== '-')
1805 if (*cp
>= '0' && *cp
<= '9')
1808 while (*cp
>= '0' && *cp
<= '9')
1811 return (((*cp
== 0) || (*cp
== ' ') || (*cp
== '\t') || (*cp
== '\n') || (*cp
== '\r') || (*cp
== '\f'))
1812 && (state
== (LEAD_INT
|DOT_CHAR
|TRAIL_INT
)
1813 || state
== (DOT_CHAR
|TRAIL_INT
)
1814 || state
== (LEAD_INT
|E_CHAR
|EXP_INT
)
1815 || state
== (LEAD_INT
|DOT_CHAR
|TRAIL_INT
|E_CHAR
|EXP_INT
)
1816 || state
== (DOT_CHAR
|TRAIL_INT
|E_CHAR
|EXP_INT
)));
1818 #endif /* LISP_FLOAT_TYPE */
1821 read_vector (readcharfun
)
1822 Lisp_Object readcharfun
;
1826 register Lisp_Object
*ptr
;
1827 register Lisp_Object tem
, vector
;
1828 register struct Lisp_Cons
*otem
;
1831 tem
= read_list (1, readcharfun
);
1832 len
= Flength (tem
);
1833 vector
= (read_pure
? make_pure_vector (XINT (len
)) : Fmake_vector (len
, Qnil
));
1836 size
= XVECTOR (vector
)->size
;
1837 ptr
= XVECTOR (vector
)->contents
;
1838 for (i
= 0; i
< size
; i
++)
1840 ptr
[i
] = read_pure
? Fpurecopy (Fcar (tem
)) : Fcar (tem
);
1848 /* flag = 1 means check for ] to terminate rather than ) and .
1849 flag = -1 means check for starting with defun
1850 and make structure pure. */
1853 read_list (flag
, readcharfun
)
1855 register Lisp_Object readcharfun
;
1857 /* -1 means check next element for defun,
1858 0 means don't check,
1859 1 means already checked and found defun. */
1860 int defunflag
= flag
< 0 ? -1 : 0;
1861 Lisp_Object val
, tail
;
1862 register Lisp_Object elt
, tem
;
1863 struct gcpro gcpro1
, gcpro2
;
1864 /* 0 is the normal case.
1865 1 means this list is a doc reference; replace it with the number 0.
1866 2 means this list is a doc reference; replace it with the doc string. */
1867 int doc_reference
= 0;
1869 /* Initialize this to 1 if we are reading a list. */
1870 int first_in_list
= flag
<= 0;
1879 elt
= read1 (readcharfun
, &ch
, first_in_list
);
1884 /* While building, if the list starts with #$, treat it specially. */
1885 if (EQ (elt
, Vload_file_name
)
1886 && !NILP (Vpurify_flag
))
1888 if (NILP (Vdoc_file_name
))
1889 /* We have not yet called Snarf-documentation, so assume
1890 this file is described in the DOC-MM.NN file
1891 and Snarf-documentation will fill in the right value later.
1892 For now, replace the whole list with 0. */
1895 /* We have already called Snarf-documentation, so make a relative
1896 file name for this file, so it can be found properly
1897 in the installed Lisp directory.
1898 We don't use Fexpand_file_name because that would make
1899 the directory absolute now. */
1900 elt
= concat2 (build_string ("../lisp/"),
1901 Ffile_name_nondirectory (elt
));
1903 else if (EQ (elt
, Vload_file_name
)
1904 && load_force_doc_strings
)
1913 Fsignal (Qinvalid_read_syntax
,
1914 Fcons (make_string (") or . in a vector", 18), Qnil
));
1922 XCONS (tail
)->cdr
= read0 (readcharfun
);
1924 val
= read0 (readcharfun
);
1925 read1 (readcharfun
, &ch
, 0);
1929 if (doc_reference
== 1)
1930 return make_number (0);
1931 if (doc_reference
== 2)
1933 /* Get a doc string from the file we are loading.
1934 If it's in saved_doc_string, get it from there. */
1935 int pos
= XINT (XCONS (val
)->cdr
);
1936 if (pos
>= saved_doc_string_position
1937 && pos
< (saved_doc_string_position
1938 + saved_doc_string_length
))
1940 int start
= pos
- saved_doc_string_position
;
1943 /* Process quoting with ^A,
1944 and find the end of the string,
1945 which is marked with ^_ (037). */
1946 for (from
= start
, to
= start
;
1947 saved_doc_string
[from
] != 037;)
1949 int c
= saved_doc_string
[from
++];
1952 c
= saved_doc_string
[from
++];
1954 saved_doc_string
[to
++] = c
;
1956 saved_doc_string
[to
++] = 0;
1958 saved_doc_string
[to
++] = 037;
1961 saved_doc_string
[to
++] = c
;
1964 return make_string (saved_doc_string
+ start
,
1968 return read_doc_string (val
);
1973 return Fsignal (Qinvalid_read_syntax
, Fcons (make_string (". in wrong context", 18), Qnil
));
1975 return Fsignal (Qinvalid_read_syntax
, Fcons (make_string ("] in a list", 11), Qnil
));
1977 tem
= (read_pure
&& flag
<= 0
1978 ? pure_cons (elt
, Qnil
)
1979 : Fcons (elt
, Qnil
));
1981 XCONS (tail
)->cdr
= tem
;
1986 defunflag
= EQ (elt
, Qdefun
);
1987 else if (defunflag
> 0)
1992 Lisp_Object Vobarray
;
1993 Lisp_Object initial_obarray
;
1995 /* oblookup stores the bucket number here, for the sake of Funintern. */
1997 int oblookup_last_bucket_number
;
1999 static int hash_string ();
2000 Lisp_Object
oblookup ();
2002 /* Get an error if OBARRAY is not an obarray.
2003 If it is one, return it. */
2006 check_obarray (obarray
)
2007 Lisp_Object obarray
;
2009 while (!VECTORP (obarray
) || XVECTOR (obarray
)->size
== 0)
2011 /* If Vobarray is now invalid, force it to be valid. */
2012 if (EQ (Vobarray
, obarray
)) Vobarray
= initial_obarray
;
2014 obarray
= wrong_type_argument (Qvectorp
, obarray
);
2019 /* Intern the C string STR: return a symbol with that name,
2020 interned in the current obarray. */
2027 int len
= strlen (str
);
2028 Lisp_Object obarray
;
2031 if (!VECTORP (obarray
) || XVECTOR (obarray
)->size
== 0)
2032 obarray
= check_obarray (obarray
);
2033 tem
= oblookup (obarray
, str
, len
);
2036 return Fintern (make_string (str
, len
), obarray
);
2039 /* Create an uninterned symbol with name STR. */
2045 int len
= strlen (str
);
2047 return Fmake_symbol ((!NILP (Vpurify_flag
)
2048 ? make_pure_string (str
, len
)
2049 : make_string (str
, len
)));
2052 DEFUN ("intern", Fintern
, Sintern
, 1, 2, 0,
2053 "Return the canonical symbol whose name is STRING.\n\
2054 If there is none, one is created by this function and returned.\n\
2055 A second optional argument specifies the obarray to use;\n\
2056 it defaults to the value of `obarray'.")
2058 Lisp_Object string
, obarray
;
2060 register Lisp_Object tem
, sym
, *ptr
;
2062 if (NILP (obarray
)) obarray
= Vobarray
;
2063 obarray
= check_obarray (obarray
);
2065 CHECK_STRING (string
, 0);
2067 tem
= oblookup (obarray
, XSTRING (string
)->data
, XSTRING (string
)->size
);
2068 if (!INTEGERP (tem
))
2071 if (!NILP (Vpurify_flag
))
2072 string
= Fpurecopy (string
);
2073 sym
= Fmake_symbol (string
);
2074 XSYMBOL (sym
)->obarray
= obarray
;
2076 if (XSTRING (string
)->data
[0] == ':')
2077 XSYMBOL (sym
)->value
= sym
;
2079 ptr
= &XVECTOR (obarray
)->contents
[XINT (tem
)];
2081 XSYMBOL (sym
)->next
= XSYMBOL (*ptr
);
2083 XSYMBOL (sym
)->next
= 0;
2088 DEFUN ("intern-soft", Fintern_soft
, Sintern_soft
, 1, 2, 0,
2089 "Return the canonical symbol whose name is STRING, or nil if none exists.\n\
2090 A second optional argument specifies the obarray to use;\n\
2091 it defaults to the value of `obarray'.")
2093 Lisp_Object string
, obarray
;
2095 register Lisp_Object tem
;
2097 if (NILP (obarray
)) obarray
= Vobarray
;
2098 obarray
= check_obarray (obarray
);
2100 CHECK_STRING (string
, 0);
2102 tem
= oblookup (obarray
, XSTRING (string
)->data
, XSTRING (string
)->size
);
2103 if (!INTEGERP (tem
))
2108 DEFUN ("unintern", Funintern
, Sunintern
, 1, 2, 0,
2109 "Delete the symbol named NAME, if any, from OBARRAY.\n\
2110 The value is t if a symbol was found and deleted, nil otherwise.\n\
2111 NAME may be a string or a symbol. If it is a symbol, that symbol\n\
2112 is deleted, if it belongs to OBARRAY--no other symbol is deleted.\n\
2113 OBARRAY defaults to the value of the variable `obarray'.")
2115 Lisp_Object name
, obarray
;
2117 register Lisp_Object string
, tem
;
2120 if (NILP (obarray
)) obarray
= Vobarray
;
2121 obarray
= check_obarray (obarray
);
2124 XSETSTRING (string
, XSYMBOL (name
)->name
);
2127 CHECK_STRING (name
, 0);
2131 tem
= oblookup (obarray
, XSTRING (string
)->data
, XSTRING (string
)->size
);
2134 /* If arg was a symbol, don't delete anything but that symbol itself. */
2135 if (SYMBOLP (name
) && !EQ (name
, tem
))
2138 hash
= oblookup_last_bucket_number
;
2140 if (EQ (XVECTOR (obarray
)->contents
[hash
], tem
))
2142 if (XSYMBOL (tem
)->next
)
2143 XSETSYMBOL (XVECTOR (obarray
)->contents
[hash
], XSYMBOL (tem
)->next
);
2145 XSETINT (XVECTOR (obarray
)->contents
[hash
], 0);
2149 Lisp_Object tail
, following
;
2151 for (tail
= XVECTOR (obarray
)->contents
[hash
];
2152 XSYMBOL (tail
)->next
;
2155 XSETSYMBOL (following
, XSYMBOL (tail
)->next
);
2156 if (EQ (following
, tem
))
2158 XSYMBOL (tail
)->next
= XSYMBOL (following
)->next
;
2167 /* Return the symbol in OBARRAY whose names matches the string
2168 of SIZE characters at PTR. If there is no such symbol in OBARRAY,
2171 Also store the bucket number in oblookup_last_bucket_number. */
2174 oblookup (obarray
, ptr
, size
)
2175 Lisp_Object obarray
;
2181 register Lisp_Object tail
;
2182 Lisp_Object bucket
, tem
;
2184 if (!VECTORP (obarray
)
2185 || (obsize
= XVECTOR (obarray
)->size
) == 0)
2187 obarray
= check_obarray (obarray
);
2188 obsize
= XVECTOR (obarray
)->size
;
2190 /* This is sometimes needed in the middle of GC. */
2191 obsize
&= ~ARRAY_MARK_FLAG
;
2192 /* Combining next two lines breaks VMS C 2.3. */
2193 hash
= hash_string (ptr
, size
);
2195 bucket
= XVECTOR (obarray
)->contents
[hash
];
2196 oblookup_last_bucket_number
= hash
;
2197 if (XFASTINT (bucket
) == 0)
2199 else if (!SYMBOLP (bucket
))
2200 error ("Bad data in guts of obarray"); /* Like CADR error message */
2202 for (tail
= bucket
; ; XSETSYMBOL (tail
, XSYMBOL (tail
)->next
))
2204 if (XSYMBOL (tail
)->name
->size
== size
2205 && !bcmp (XSYMBOL (tail
)->name
->data
, ptr
, size
))
2207 else if (XSYMBOL (tail
)->next
== 0)
2210 XSETINT (tem
, hash
);
2215 hash_string (ptr
, len
)
2219 register unsigned char *p
= ptr
;
2220 register unsigned char *end
= p
+ len
;
2221 register unsigned char c
;
2222 register int hash
= 0;
2227 if (c
>= 0140) c
-= 40;
2228 hash
= ((hash
<<3) + (hash
>>28) + c
);
2230 return hash
& 07777777777;
2234 map_obarray (obarray
, fn
, arg
)
2235 Lisp_Object obarray
;
2240 register Lisp_Object tail
;
2241 CHECK_VECTOR (obarray
, 1);
2242 for (i
= XVECTOR (obarray
)->size
- 1; i
>= 0; i
--)
2244 tail
= XVECTOR (obarray
)->contents
[i
];
2245 if (XFASTINT (tail
) != 0)
2249 if (XSYMBOL (tail
)->next
== 0)
2251 XSETSYMBOL (tail
, XSYMBOL (tail
)->next
);
2256 mapatoms_1 (sym
, function
)
2257 Lisp_Object sym
, function
;
2259 call1 (function
, sym
);
2262 DEFUN ("mapatoms", Fmapatoms
, Smapatoms
, 1, 2, 0,
2263 "Call FUNCTION on every symbol in OBARRAY.\n\
2264 OBARRAY defaults to the value of `obarray'.")
2266 Lisp_Object function
, obarray
;
2270 if (NILP (obarray
)) obarray
= Vobarray
;
2271 obarray
= check_obarray (obarray
);
2273 map_obarray (obarray
, mapatoms_1
, function
);
2277 #define OBARRAY_SIZE 1511
2282 Lisp_Object oblength
;
2286 XSETFASTINT (oblength
, OBARRAY_SIZE
);
2288 Qnil
= Fmake_symbol (make_pure_string ("nil", 3));
2289 Vobarray
= Fmake_vector (oblength
, make_number (0));
2290 initial_obarray
= Vobarray
;
2291 staticpro (&initial_obarray
);
2292 /* Intern nil in the obarray */
2293 XSYMBOL (Qnil
)->obarray
= Vobarray
;
2294 /* These locals are to kludge around a pyramid compiler bug. */
2295 hash
= hash_string ("nil", 3);
2296 /* Separate statement here to avoid VAXC bug. */
2297 hash
%= OBARRAY_SIZE
;
2298 tem
= &XVECTOR (Vobarray
)->contents
[hash
];
2301 Qunbound
= Fmake_symbol (make_pure_string ("unbound", 7));
2302 XSYMBOL (Qnil
)->function
= Qunbound
;
2303 XSYMBOL (Qunbound
)->value
= Qunbound
;
2304 XSYMBOL (Qunbound
)->function
= Qunbound
;
2307 XSYMBOL (Qnil
)->value
= Qnil
;
2308 XSYMBOL (Qnil
)->plist
= Qnil
;
2309 XSYMBOL (Qt
)->value
= Qt
;
2311 /* Qt is correct even if CANNOT_DUMP. loadup.el will set to nil at end. */
2314 Qvariable_documentation
= intern ("variable-documentation");
2315 staticpro (&Qvariable_documentation
);
2317 read_buffer_size
= 100;
2318 read_buffer
= (char *) malloc (read_buffer_size
);
2323 struct Lisp_Subr
*sname
;
2326 sym
= intern (sname
->symbol_name
);
2327 XSETSUBR (XSYMBOL (sym
)->function
, sname
);
2330 #ifdef NOTDEF /* use fset in subr.el now */
2332 defalias (sname
, string
)
2333 struct Lisp_Subr
*sname
;
2337 sym
= intern (string
);
2338 XSETSUBR (XSYMBOL (sym
)->function
, sname
);
2342 /* Define an "integer variable"; a symbol whose value is forwarded
2343 to a C variable of type int. Sample call: */
2344 /* DEFVAR_INT ("indent-tabs-mode", &indent_tabs_mode, "Documentation"); */
2346 defvar_int (namestring
, address
)
2350 Lisp_Object sym
, val
;
2351 sym
= intern (namestring
);
2352 val
= allocate_misc ();
2353 XMISCTYPE (val
) = Lisp_Misc_Intfwd
;
2354 XINTFWD (val
)->intvar
= address
;
2355 XSYMBOL (sym
)->value
= val
;
2358 /* Similar but define a variable whose value is T if address contains 1,
2359 NIL if address contains 0 */
2361 defvar_bool (namestring
, address
)
2365 Lisp_Object sym
, val
;
2366 sym
= intern (namestring
);
2367 val
= allocate_misc ();
2368 XMISCTYPE (val
) = Lisp_Misc_Boolfwd
;
2369 XBOOLFWD (val
)->boolvar
= address
;
2370 XSYMBOL (sym
)->value
= val
;
2373 /* Similar but define a variable whose value is the Lisp Object stored
2374 at address. Two versions: with and without gc-marking of the C
2375 variable. The nopro version is used when that variable will be
2376 gc-marked for some other reason, since marking the same slot twice
2377 can cause trouble with strings. */
2379 defvar_lisp_nopro (namestring
, address
)
2381 Lisp_Object
*address
;
2383 Lisp_Object sym
, val
;
2384 sym
= intern (namestring
);
2385 val
= allocate_misc ();
2386 XMISCTYPE (val
) = Lisp_Misc_Objfwd
;
2387 XOBJFWD (val
)->objvar
= address
;
2388 XSYMBOL (sym
)->value
= val
;
2392 defvar_lisp (namestring
, address
)
2394 Lisp_Object
*address
;
2396 defvar_lisp_nopro (namestring
, address
);
2397 staticpro (address
);
2402 /* Similar but define a variable whose value is the Lisp Object stored in
2403 the current buffer. address is the address of the slot in the buffer
2404 that is current now. */
2407 defvar_per_buffer (namestring
, address
, type
, doc
)
2409 Lisp_Object
*address
;
2413 Lisp_Object sym
, val
;
2415 extern struct buffer buffer_local_symbols
;
2417 sym
= intern (namestring
);
2418 val
= allocate_misc ();
2419 offset
= (char *)address
- (char *)current_buffer
;
2421 XMISCTYPE (val
) = Lisp_Misc_Buffer_Objfwd
;
2422 XBUFFER_OBJFWD (val
)->offset
= offset
;
2423 XSYMBOL (sym
)->value
= val
;
2424 *(Lisp_Object
*)(offset
+ (char *)&buffer_local_symbols
) = sym
;
2425 *(Lisp_Object
*)(offset
+ (char *)&buffer_local_types
) = type
;
2426 if (XINT (*(Lisp_Object
*)(offset
+ (char *)&buffer_local_flags
)) == 0)
2427 /* Did a DEFVAR_PER_BUFFER without initializing the corresponding
2428 slot of buffer_local_flags */
2432 #endif /* standalone */
2434 /* Similar but define a variable whose value is the Lisp Object stored
2435 at a particular offset in the current kboard object. */
2438 defvar_kboard (namestring
, offset
)
2442 Lisp_Object sym
, val
;
2443 sym
= intern (namestring
);
2444 val
= allocate_misc ();
2445 XMISCTYPE (val
) = Lisp_Misc_Kboard_Objfwd
;
2446 XKBOARD_OBJFWD (val
)->offset
= offset
;
2447 XSYMBOL (sym
)->value
= val
;
2450 /* Record the value of load-path used at the start of dumping
2451 so we can see if the site changed it later during dumping. */
2452 static Lisp_Object dump_path
;
2457 int turn_off_warning
= 0;
2459 #ifdef HAVE_SETLOCALE
2460 /* Make sure numbers are parsed as we expect. */
2461 setlocale (LC_NUMERIC
, "C");
2462 #endif /* HAVE_SETLOCALE */
2464 /* Compute the default load-path. */
2466 normal
= PATH_LOADSEARCH
;
2467 Vload_path
= decode_env_path (0, normal
);
2469 if (NILP (Vpurify_flag
))
2470 normal
= PATH_LOADSEARCH
;
2472 normal
= PATH_DUMPLOADSEARCH
;
2474 /* In a dumped Emacs, we normally have to reset the value of
2475 Vload_path from PATH_LOADSEARCH, since the value that was dumped
2476 uses ../lisp, instead of the path of the installed elisp
2477 libraries. However, if it appears that Vload_path was changed
2478 from the default before dumping, don't override that value. */
2481 if (! NILP (Fequal (dump_path
, Vload_path
)))
2483 Vload_path
= decode_env_path (0, normal
);
2484 if (!NILP (Vinstallation_directory
))
2486 /* Add to the path the lisp subdir of the
2487 installation dir, if it exists. */
2488 Lisp_Object tem
, tem1
;
2489 tem
= Fexpand_file_name (build_string ("lisp"),
2490 Vinstallation_directory
);
2491 tem1
= Ffile_exists_p (tem
);
2494 if (NILP (Fmember (tem
, Vload_path
)))
2496 turn_off_warning
= 1;
2497 Vload_path
= nconc2 (Vload_path
, Fcons (tem
, Qnil
));
2501 /* That dir doesn't exist, so add the build-time
2502 Lisp dirs instead. */
2503 Vload_path
= nconc2 (Vload_path
, dump_path
);
2505 /* Add site-list under the installation dir, if it exists. */
2506 tem
= Fexpand_file_name (build_string ("site-lisp"),
2507 Vinstallation_directory
);
2508 tem1
= Ffile_exists_p (tem
);
2511 if (NILP (Fmember (tem
, Vload_path
)))
2512 Vload_path
= nconc2 (Vload_path
, Fcons (tem
, Qnil
));
2515 /* If Emacs was not built in the source directory,
2516 and it is run from where it was built,
2518 the lisp and site-lisp dirs under the source directory. */
2520 if (NILP (Fequal (Vinstallation_directory
, Vsource_directory
)))
2522 tem
= Fexpand_file_name (build_string ("src/Makefile"),
2523 Vinstallation_directory
);
2524 tem1
= Ffile_exists_p (tem
);
2527 tem
= Fexpand_file_name (build_string ("lisp"),
2530 if (NILP (Fmember (tem
, Vload_path
)))
2531 Vload_path
= nconc2 (Vload_path
, Fcons (tem
, Qnil
));
2533 tem
= Fexpand_file_name (build_string ("site-lisp"),
2536 if (NILP (Fmember (tem
, Vload_path
)))
2537 Vload_path
= nconc2 (Vload_path
, Fcons (tem
, Qnil
));
2545 /* NORMAL refers to the lisp dir in the source directory. */
2546 /* We used to add ../lisp at the front here, but
2547 that caused trouble because it was copied from dump_path
2548 into Vload_path, aboe, when Vinstallation_directory was non-nil.
2549 It should be unnecessary. */
2550 Vload_path
= decode_env_path (0, normal
);
2551 dump_path
= Vload_path
;
2556 /* When Emacs is invoked over network shares on NT, PATH_LOADSEARCH is
2557 almost never correct, thereby causing a warning to be printed out that
2558 confuses users. Since PATH_LOADSEARCH is always overridden by the
2559 EMACSLOADPATH environment variable below, disable the warning on NT. */
2561 /* Warn if dirs in the *standard* path don't exist. */
2562 if (!turn_off_warning
)
2564 Lisp_Object path_tail
;
2566 for (path_tail
= Vload_path
;
2568 path_tail
= XCONS (path_tail
)->cdr
)
2570 Lisp_Object dirfile
;
2571 dirfile
= Fcar (path_tail
);
2572 if (STRINGP (dirfile
))
2574 dirfile
= Fdirectory_file_name (dirfile
);
2575 if (access (XSTRING (dirfile
)->data
, 0) < 0)
2576 dir_warning ("Warning: Lisp directory `%s' does not exist.\n",
2577 XCONS (path_tail
)->car
);
2581 #endif /* WINDOWSNT */
2583 /* If the EMACSLOADPATH environment variable is set, use its value.
2584 This doesn't apply if we're dumping. */
2586 if (NILP (Vpurify_flag
)
2587 && egetenv ("EMACSLOADPATH"))
2589 Vload_path
= decode_env_path ("EMACSLOADPATH", normal
);
2593 load_in_progress
= 0;
2594 Vload_file_name
= Qnil
;
2596 load_descriptor_list
= Qnil
;
2599 /* Print a warning, using format string FORMAT, that directory DIRNAME
2600 does not exist. Print it on stderr and put it in *Message*. */
2602 dir_warning (format
, dirname
)
2604 Lisp_Object dirname
;
2607 = (char *) alloca (XSTRING (dirname
)->size
+ strlen (format
) + 5);
2609 fprintf (stderr
, format
, XSTRING (dirname
)->data
);
2610 sprintf (buffer
, format
, XSTRING (dirname
)->data
);
2611 message_dolog (buffer
, strlen (buffer
), 0);
2618 defsubr (&Sread_from_string
);
2620 defsubr (&Sintern_soft
);
2621 defsubr (&Sunintern
);
2623 defsubr (&Seval_buffer
);
2624 defsubr (&Seval_region
);
2625 defsubr (&Sread_char
);
2626 defsubr (&Sread_char_exclusive
);
2627 defsubr (&Sread_event
);
2628 defsubr (&Sget_file_char
);
2629 defsubr (&Smapatoms
);
2631 DEFVAR_LISP ("obarray", &Vobarray
,
2632 "Symbol table for use by `intern' and `read'.\n\
2633 It is a vector whose length ought to be prime for best results.\n\
2634 The vector's contents don't make sense if examined from Lisp programs;\n\
2635 to find all the symbols in an obarray, use `mapatoms'.");
2637 DEFVAR_LISP ("values", &Vvalues
,
2638 "List of values of all expressions which were read, evaluated and printed.\n\
2639 Order is reverse chronological.");
2641 DEFVAR_LISP ("standard-input", &Vstandard_input
,
2642 "Stream for read to get input from.\n\
2643 See documentation of `read' for possible values.");
2644 Vstandard_input
= Qt
;
2646 DEFVAR_LISP ("load-path", &Vload_path
,
2647 "*List of directories to search for files to load.\n\
2648 Each element is a string (directory name) or nil (try default directory).\n\
2649 Initialized based on EMACSLOADPATH environment variable, if any,\n\
2650 otherwise to default specified by file `paths.h' when Emacs was built.");
2652 DEFVAR_BOOL ("load-in-progress", &load_in_progress
,
2653 "Non-nil iff inside of `load'.");
2655 DEFVAR_LISP ("after-load-alist", &Vafter_load_alist
,
2656 "An alist of expressions to be evalled when particular files are loaded.\n\
2657 Each element looks like (FILENAME FORMS...).\n\
2658 When `load' is run and the file-name argument is FILENAME,\n\
2659 the FORMS in the corresponding element are executed at the end of loading.\n\n\
2660 FILENAME must match exactly! Normally FILENAME is the name of a library,\n\
2661 with no directory specified, since that is how `load' is normally called.\n\
2662 An error in FORMS does not undo the load,\n\
2663 but does prevent execution of the rest of the FORMS.");
2664 Vafter_load_alist
= Qnil
;
2666 DEFVAR_LISP ("load-history", &Vload_history
,
2667 "Alist mapping source file names to symbols and features.\n\
2668 Each alist element is a list that starts with a file name,\n\
2669 except for one element (optional) that starts with nil and describes\n\
2670 definitions evaluated from buffers not visiting files.\n\
2671 The remaining elements of each list are symbols defined as functions\n\
2672 or variables, and cons cells `(provide . FEATURE)' and `(require . FEATURE)'.");
2673 Vload_history
= Qnil
;
2675 DEFVAR_LISP ("load-file-name", &Vload_file_name
,
2676 "Full name of file being loaded by `load'.");
2677 Vload_file_name
= Qnil
;
2679 DEFVAR_LISP ("current-load-list", &Vcurrent_load_list
,
2680 "Used for internal purposes by `load'.");
2681 Vcurrent_load_list
= Qnil
;
2683 DEFVAR_LISP ("load-read-function", &Vload_read_function
,
2684 "Function used by `load' and `eval-region' for reading expressions.\n\
2685 The default is nil, which means use the function `read'.");
2686 Vload_read_function
= Qnil
;
2688 DEFVAR_LISP ("load-source-file-function", &Vload_source_file_function
,
2689 "Function called in `load' for loading an Emacs lisp source file.\n\
2690 This function is for doing code conversion before reading the source file.\n\
2691 If nil, loading is done without any code conversion.\n\
2692 Arguments are FULLNAME, FILE, NOERROR, NOMESSAGE, where\n\
2693 FULLNAME is the full name of FILE.\n\
2694 See `load' for the meaning of the remaining arguments.");
2695 Vload_source_file_function
= Qnil
;
2697 DEFVAR_BOOL ("load-force-doc-strings", &load_force_doc_strings
,
2698 "Non-nil means `load' should force-load all dynamic doc strings.\n\
2699 This is useful when the file being loaded is a temporary copy.");
2700 load_force_doc_strings
= 0;
2702 DEFVAR_LISP ("source-directory", &Vsource_directory
,
2703 "Directory in which Emacs sources were found when Emacs was built.\n\
2704 You cannot count on them to still be there!");
2706 = Fexpand_file_name (build_string ("../"),
2707 Fcar (decode_env_path (0, PATH_DUMPLOADSEARCH
)));
2709 /* Vsource_directory was initialized in init_lread. */
2711 load_descriptor_list
= Qnil
;
2712 staticpro (&load_descriptor_list
);
2714 Qcurrent_load_list
= intern ("current-load-list");
2715 staticpro (&Qcurrent_load_list
);
2717 Qstandard_input
= intern ("standard-input");
2718 staticpro (&Qstandard_input
);
2720 Qread_char
= intern ("read-char");
2721 staticpro (&Qread_char
);
2723 Qget_file_char
= intern ("get-file-char");
2724 staticpro (&Qget_file_char
);
2726 Qbackquote
= intern ("`");
2727 staticpro (&Qbackquote
);
2728 Qcomma
= intern (",");
2729 staticpro (&Qcomma
);
2730 Qcomma_at
= intern (",@");
2731 staticpro (&Qcomma_at
);
2732 Qcomma_dot
= intern (",.");
2733 staticpro (&Qcomma_dot
);
2735 Qinhibit_file_name_operation
= intern ("inhibit-file-name-operation");
2736 staticpro (&Qinhibit_file_name_operation
);
2738 Qascii_character
= intern ("ascii-character");
2739 staticpro (&Qascii_character
);
2741 Qfunction
= intern ("function");
2742 staticpro (&Qfunction
);
2744 Qload
= intern ("load");
2747 Qload_file_name
= intern ("load-file-name");
2748 staticpro (&Qload_file_name
);
2750 staticpro (&dump_path
);
2752 staticpro (&read_objects
);
2753 read_objects
= Qnil
;