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>
36 #include "termhooks.h"
40 #include <sys/inode.h>
45 #include <unistd.h> /* to get X_OK */
54 #ifdef LISP_FLOAT_TYPE
60 #endif /* LISP_FLOAT_TYPE */
64 #endif /* HAVE_SETLOCALE */
72 Lisp_Object Qread_char
, Qget_file_char
, Qstandard_input
, Qcurrent_load_list
;
73 Lisp_Object Qvariable_documentation
, Vvalues
, Vstandard_input
, Vafter_load_alist
;
74 Lisp_Object Qascii_character
, Qload
, Qload_file_name
;
75 Lisp_Object Qbackquote
, Qcomma
, Qcomma_at
, Qcomma_dot
, Qfunction
;
77 extern Lisp_Object Qevent_symbol_element_mask
;
79 /* non-zero if inside `load' */
82 /* Directory in which the sources were found. */
83 Lisp_Object Vsource_directory
;
85 /* Search path for files to be loaded. */
86 Lisp_Object Vload_path
;
88 /* This is the user-visible association list that maps features to
89 lists of defs in their load files. */
90 Lisp_Object Vload_history
;
92 /* This is used to build the load history. */
93 Lisp_Object Vcurrent_load_list
;
95 /* Name of file actually being read by `load'. */
96 Lisp_Object Vload_file_name
;
98 /* Function to use for reading, in `load' and friends. */
99 Lisp_Object Vload_read_function
;
101 /* Nonzero means load should forcibly load all dynamic doc strings. */
102 static int load_force_doc_strings
;
104 /* List of descriptors now open for Fload. */
105 static Lisp_Object load_descriptor_list
;
107 /* File for get_file_char to read from. Use by load. */
108 static FILE *instream
;
110 /* When nonzero, read conses in pure space */
111 static int read_pure
;
113 /* For use within read-from-string (this reader is non-reentrant!!) */
114 static int read_from_string_index
;
115 static int read_from_string_limit
;
117 /* This contains the last string skipped with #@. */
118 static char *saved_doc_string
;
119 /* Length of buffer allocated in saved_doc_string. */
120 static int saved_doc_string_size
;
121 /* Length of actual data in saved_doc_string. */
122 static int saved_doc_string_length
;
123 /* This is the file position that string came from. */
124 static int saved_doc_string_position
;
126 /* Nonzero means inside a new-style backquote
127 with no surrounding parentheses.
128 Fread initializes this to zero, so we need not specbind it
129 or worry about what happens to it when there is an error. */
130 static int new_backquote_flag
;
132 /* Handle unreading and rereading of characters.
133 Write READCHAR to read a character,
134 UNREAD(c) to unread c to be read again. */
136 #define READCHAR readchar (readcharfun)
137 #define UNREAD(c) unreadchar (readcharfun, c)
140 readchar (readcharfun
)
141 Lisp_Object readcharfun
;
144 register struct buffer
*inbuffer
;
145 register int c
, mpos
;
147 if (BUFFERP (readcharfun
))
149 inbuffer
= XBUFFER (readcharfun
);
151 if (BUF_PT (inbuffer
) >= BUF_ZV (inbuffer
))
153 c
= *(unsigned char *) BUF_CHAR_ADDRESS (inbuffer
, BUF_PT (inbuffer
));
154 SET_BUF_PT (inbuffer
, BUF_PT (inbuffer
) + 1);
158 if (MARKERP (readcharfun
))
160 inbuffer
= XMARKER (readcharfun
)->buffer
;
162 mpos
= marker_position (readcharfun
);
164 if (mpos
> BUF_ZV (inbuffer
) - 1)
166 c
= *(unsigned char *) BUF_CHAR_ADDRESS (inbuffer
, mpos
);
167 if (mpos
!= BUF_GPT (inbuffer
))
168 XMARKER (readcharfun
)->bufpos
++;
170 Fset_marker (readcharfun
, make_number (mpos
+ 1),
171 Fmarker_buffer (readcharfun
));
174 if (EQ (readcharfun
, Qget_file_char
))
178 /* Interrupted reads have been observed while reading over the network */
179 while (c
== EOF
&& ferror (instream
) && errno
== EINTR
)
188 if (STRINGP (readcharfun
))
191 /* This used to be return of a conditional expression,
192 but that truncated -1 to a char on VMS. */
193 if (read_from_string_index
< read_from_string_limit
)
194 c
= XSTRING (readcharfun
)->data
[read_from_string_index
++];
200 tem
= call0 (readcharfun
);
207 /* Unread the character C in the way appropriate for the stream READCHARFUN.
208 If the stream is a user function, call it with the char as argument. */
211 unreadchar (readcharfun
, c
)
212 Lisp_Object readcharfun
;
216 /* Don't back up the pointer if we're unreading the end-of-input mark,
217 since readchar didn't advance it when we read it. */
219 else if (BUFFERP (readcharfun
))
221 if (XBUFFER (readcharfun
) == current_buffer
)
224 SET_BUF_PT (XBUFFER (readcharfun
), BUF_PT (XBUFFER (readcharfun
)) - 1);
226 else if (MARKERP (readcharfun
))
227 XMARKER (readcharfun
)->bufpos
--;
228 else if (STRINGP (readcharfun
))
229 read_from_string_index
--;
230 else if (EQ (readcharfun
, Qget_file_char
))
231 ungetc (c
, instream
);
233 call1 (readcharfun
, make_number (c
));
236 static Lisp_Object
read0 (), read1 (), read_list (), read_vector ();
238 /* get a character from the tty */
240 extern Lisp_Object
read_char ();
242 /* Read input events until we get one that's acceptable for our purposes.
244 If NO_SWITCH_FRAME is non-zero, switch-frame events are stashed
245 until we get a character we like, and then stuffed into
248 If ASCII_REQUIRED is non-zero, we check function key events to see
249 if the unmodified version of the symbol has a Qascii_character
250 property, and use that character, if present.
252 If ERROR_NONASCII is non-zero, we signal an error if the input we
253 get isn't an ASCII character with modifiers. If it's zero but
254 ASCII_REQUIRED is non-zero, we just re-read until we get an ASCII
258 read_filtered_event (no_switch_frame
, ascii_required
, error_nonascii
)
259 int no_switch_frame
, ascii_required
, error_nonascii
;
262 return make_number (getchar ());
264 register Lisp_Object val
, delayed_switch_frame
;
266 delayed_switch_frame
= Qnil
;
268 /* Read until we get an acceptable event. */
270 val
= read_char (0, 0, 0, Qnil
, 0);
275 /* switch-frame events are put off until after the next ASCII
276 character. This is better than signaling an error just because
277 the last characters were typed to a separate minibuffer frame,
278 for example. Eventually, some code which can deal with
279 switch-frame events will read it and process it. */
281 && EVENT_HAS_PARAMETERS (val
)
282 && EQ (EVENT_HEAD (val
), Qswitch_frame
))
284 delayed_switch_frame
= val
;
290 /* Convert certain symbols to their ASCII equivalents. */
293 Lisp_Object tem
, tem1
, tem2
;
294 tem
= Fget (val
, Qevent_symbol_element_mask
);
297 tem1
= Fget (Fcar (tem
), Qascii_character
);
298 /* Merge this symbol's modifier bits
299 with the ASCII equivalent of its basic code. */
301 XSETFASTINT (val
, XINT (tem1
) | XINT (Fcar (Fcdr (tem
))));
305 /* If we don't have a character now, deal with it appropriately. */
310 Vunread_command_events
= Fcons (val
, Qnil
);
311 error ("Non-character input-event");
318 if (! NILP (delayed_switch_frame
))
319 unread_switch_frame
= delayed_switch_frame
;
325 DEFUN ("read-char", Fread_char
, Sread_char
, 0, 0, 0,
326 "Read a character from the command input (keyboard or macro).\n\
327 It is returned as a number.\n\
328 If the user generates an event which is not a character (i.e. a mouse\n\
329 click or function key event), `read-char' signals an error. As an\n\
330 exception, switch-frame events are put off until non-ASCII events can\n\
332 If you want to read non-character events, or ignore them, call\n\
333 `read-event' or `read-char-exclusive' instead.")
336 return read_filtered_event (1, 1, 1);
339 DEFUN ("read-event", Fread_event
, Sread_event
, 0, 0, 0,
340 "Read an event object from the input stream.")
343 return read_filtered_event (0, 0, 0);
346 DEFUN ("read-char-exclusive", Fread_char_exclusive
, Sread_char_exclusive
, 0, 0, 0,
347 "Read a character from the command input (keyboard or macro).\n\
348 It is returned as a number. Non-character events are ignored.")
351 return read_filtered_event (1, 1, 0);
354 DEFUN ("get-file-char", Fget_file_char
, Sget_file_char
, 0, 0, 0,
355 "Don't use this yourself.")
358 register Lisp_Object val
;
359 XSETINT (val
, getc (instream
));
363 static void readevalloop ();
364 static Lisp_Object
load_unwind ();
365 static Lisp_Object
load_descriptor_unwind ();
367 DEFUN ("load", Fload
, Sload
, 1, 4, 0,
368 "Execute a file of Lisp code named FILE.\n\
369 First try FILE with `.elc' appended, then try with `.el',\n\
370 then try FILE unmodified.\n\
371 This function searches the directories in `load-path'.\n\
372 If optional second arg NOERROR is non-nil,\n\
373 report no error if FILE doesn't exist.\n\
374 Print messages at start and end of loading unless\n\
375 optional third arg NOMESSAGE is non-nil.\n\
376 If optional fourth arg NOSUFFIX is non-nil, don't try adding\n\
377 suffixes `.elc' or `.el' to the specified name FILE.\n\
378 Return t if file exists.")
379 (file
, noerror
, nomessage
, nosuffix
)
380 Lisp_Object file
, noerror
, nomessage
, nosuffix
;
382 register FILE *stream
;
383 register int fd
= -1;
384 register Lisp_Object lispstream
;
385 int count
= specpdl_ptr
- specpdl
;
389 /* 1 means inhibit the message at the beginning. */
393 char *dosmode
= "rt";
396 CHECK_STRING (file
, 0);
398 /* If file name is magic, call the handler. */
399 handler
= Ffind_file_name_handler (file
, Qload
);
401 return call5 (handler
, Qload
, file
, noerror
, nomessage
, nosuffix
);
403 /* Do this after the handler to avoid
404 the need to gcpro noerror, nomessage and nosuffix.
405 (Below here, we care only whether they are nil or not.) */
406 file
= Fsubstitute_in_file_name (file
);
408 /* Avoid weird lossage with null string as arg,
409 since it would try to load a directory as a Lisp file */
410 if (XSTRING (file
)->size
> 0)
413 fd
= openp (Vload_path
, file
, !NILP (nosuffix
) ? "" : ".elc:.el:",
422 Fsignal (Qfile_error
, Fcons (build_string ("Cannot open load file"),
423 Fcons (file
, Qnil
)));
428 if (!bcmp (&(XSTRING (found
)->data
[XSTRING (found
)->size
- 4]),
437 stat ((char *)XSTRING (found
)->data
, &s1
);
438 XSTRING (found
)->data
[XSTRING (found
)->size
- 1] = 0;
439 result
= stat ((char *)XSTRING (found
)->data
, &s2
);
440 if (result
>= 0 && (unsigned) s1
.st_mtime
< (unsigned) s2
.st_mtime
)
442 message ("Source file `%s' newer than byte-compiled file",
443 XSTRING (found
)->data
);
444 /* Don't immediately overwrite this message. */
448 XSTRING (found
)->data
[XSTRING (found
)->size
- 1] = 'c';
453 stream
= fopen ((char *) XSTRING (found
)->data
, dosmode
);
454 #else /* not DOS_NT */
455 stream
= fdopen (fd
, "r");
456 #endif /* not DOS_NT */
460 error ("Failure to create stdio stream for %s", XSTRING (file
)->data
);
463 if (NILP (nomessage
) && !nomessage1
)
464 message ("Loading %s...", XSTRING (file
)->data
);
467 lispstream
= Fcons (Qnil
, Qnil
);
468 XSETFASTINT (XCONS (lispstream
)->car
, (EMACS_UINT
)stream
>> 16);
469 XSETFASTINT (XCONS (lispstream
)->cdr
, (EMACS_UINT
)stream
& 0xffff);
470 record_unwind_protect (load_unwind
, lispstream
);
471 record_unwind_protect (load_descriptor_unwind
, load_descriptor_list
);
472 specbind (Qload_file_name
, found
);
474 = Fcons (make_number (fileno (stream
)), load_descriptor_list
);
476 readevalloop (Qget_file_char
, stream
, file
, Feval
, 0);
477 unbind_to (count
, Qnil
);
479 /* Run any load-hooks for this file. */
480 temp
= Fassoc (file
, Vafter_load_alist
);
482 Fprogn (Fcdr (temp
));
485 if (saved_doc_string
)
486 free (saved_doc_string
);
487 saved_doc_string
= 0;
488 saved_doc_string_size
= 0;
490 if (!noninteractive
&& NILP (nomessage
))
491 message ("Loading %s...done", XSTRING (file
)->data
);
496 load_unwind (stream
) /* used as unwind-protect function in load */
499 fclose ((FILE *) (XFASTINT (XCONS (stream
)->car
) << 16
500 | XFASTINT (XCONS (stream
)->cdr
)));
501 if (--load_in_progress
< 0) load_in_progress
= 0;
506 load_descriptor_unwind (oldlist
)
509 load_descriptor_list
= oldlist
;
513 /* Close all descriptors in use for Floads.
514 This is used when starting a subprocess. */
521 for (tail
= load_descriptor_list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
522 close (XFASTINT (XCONS (tail
)->car
));
527 complete_filename_p (pathname
)
528 Lisp_Object pathname
;
530 register unsigned char *s
= XSTRING (pathname
)->data
;
531 return (IS_DIRECTORY_SEP (s
[0])
532 || (XSTRING (pathname
)->size
> 2
533 && IS_DEVICE_SEP (s
[1]) && IS_DIRECTORY_SEP (s
[2]))
543 /* Search for a file whose name is STR, looking in directories
544 in the Lisp list PATH, and trying suffixes from SUFFIX.
545 SUFFIX is a string containing possible suffixes separated by colons.
546 On success, returns a file descriptor. On failure, returns -1.
548 EXEC_ONLY nonzero means don't open the files,
549 just look for one that is executable. In this case,
550 returns 1 on success.
552 If STOREPTR is nonzero, it points to a slot where the name of
553 the file actually found should be stored as a Lisp string.
554 Nil is stored there on failure. */
557 openp (path
, str
, suffix
, storeptr
, exec_only
)
558 Lisp_Object path
, str
;
560 Lisp_Object
*storeptr
;
566 register char *fn
= buf
;
569 register Lisp_Object filename
;
577 if (complete_filename_p (str
))
580 for (; !NILP (path
); path
= Fcdr (path
))
584 filename
= Fexpand_file_name (str
, Fcar (path
));
585 if (!complete_filename_p (filename
))
586 /* If there are non-absolute elts in PATH (eg ".") */
587 /* Of course, this could conceivably lose if luser sets
588 default-directory to be something non-absolute... */
590 filename
= Fexpand_file_name (filename
, current_buffer
->directory
);
591 if (!complete_filename_p (filename
))
592 /* Give up on this path element! */
596 /* Calculate maximum size of any filename made from
597 this path element/specified file name and any possible suffix. */
598 want_size
= strlen (suffix
) + XSTRING (filename
)->size
+ 1;
599 if (fn_size
< want_size
)
600 fn
= (char *) alloca (fn_size
= 100 + want_size
);
604 /* Loop over suffixes. */
607 char *esuffix
= (char *) index (nsuffix
, ':');
608 int lsuffix
= esuffix
? esuffix
- nsuffix
: strlen (nsuffix
);
610 /* Concatenate path element/specified name with the suffix. */
611 strncpy (fn
, XSTRING (filename
)->data
, XSTRING (filename
)->size
);
612 fn
[XSTRING (filename
)->size
] = 0;
613 if (lsuffix
!= 0) /* Bug happens on CCI if lsuffix is 0. */
614 strncat (fn
, nsuffix
, lsuffix
);
616 /* Ignore file if it's a directory. */
617 if (stat (fn
, &st
) >= 0
618 && (st
.st_mode
& S_IFMT
) != S_IFDIR
)
620 /* Check that we can access or open it. */
622 fd
= (access (fn
, X_OK
) == 0) ? 1 : -1;
624 fd
= open (fn
, O_RDONLY
, 0);
628 /* We succeeded; return this descriptor and filename. */
630 *storeptr
= build_string (fn
);
636 /* Advance to next suffix. */
639 nsuffix
+= lsuffix
+ 1;
650 /* Merge the list we've accumulated of globals from the current input source
651 into the load_history variable. The details depend on whether
652 the source has an associated file name or not. */
655 build_load_history (stream
, source
)
659 register Lisp_Object tail
, prev
, newelt
;
660 register Lisp_Object tem
, tem2
;
661 register int foundit
, loading
;
663 /* Don't bother recording anything for preloaded files. */
664 if (!NILP (Vpurify_flag
))
667 loading
= stream
|| !NARROWED
;
669 tail
= Vload_history
;
676 /* Find the feature's previous assoc list... */
677 if (!NILP (Fequal (source
, Fcar (tem
))))
681 /* If we're loading, remove it. */
685 Vload_history
= Fcdr (tail
);
687 Fsetcdr (prev
, Fcdr (tail
));
690 /* Otherwise, cons on new symbols that are not already members. */
693 tem2
= Vcurrent_load_list
;
697 newelt
= Fcar (tem2
);
699 if (NILP (Fmemq (newelt
, tem
)))
700 Fsetcar (tail
, Fcons (Fcar (tem
),
701 Fcons (newelt
, Fcdr (tem
))));
714 /* If we're loading, cons the new assoc onto the front of load-history,
715 the most-recently-loaded position. Also do this if we didn't find
716 an existing member for the current source. */
717 if (loading
|| !foundit
)
718 Vload_history
= Fcons (Fnreverse (Vcurrent_load_list
),
723 unreadpure () /* Used as unwind-protect function in readevalloop */
730 readevalloop (readcharfun
, stream
, sourcename
, evalfun
, printflag
)
731 Lisp_Object readcharfun
;
733 Lisp_Object sourcename
;
734 Lisp_Object (*evalfun
) ();
738 register Lisp_Object val
;
739 int count
= specpdl_ptr
- specpdl
;
741 struct buffer
*b
= 0;
743 if (BUFFERP (readcharfun
))
744 b
= XBUFFER (readcharfun
);
745 else if (MARKERP (readcharfun
))
746 b
= XMARKER (readcharfun
)->buffer
;
748 specbind (Qstandard_input
, readcharfun
);
749 specbind (Qcurrent_load_list
, Qnil
);
753 LOADHIST_ATTACH (sourcename
);
757 if (b
!= 0 && NILP (b
->name
))
758 error ("Reading from killed buffer");
764 while ((c
= READCHAR
) != '\n' && c
!= -1);
769 /* Ignore whitespace here, so we can detect eof. */
770 if (c
== ' ' || c
== '\t' || c
== '\n' || c
== '\f' || c
== '\r')
773 if (!NILP (Vpurify_flag
) && c
== '(')
775 int count1
= specpdl_ptr
- specpdl
;
776 record_unwind_protect (unreadpure
, Qnil
);
777 val
= read_list (-1, readcharfun
);
778 unbind_to (count1
, Qnil
);
783 if (NILP (Vload_read_function
))
784 val
= read0 (readcharfun
);
786 val
= call1 (Vload_read_function
, readcharfun
);
789 val
= (*evalfun
) (val
);
792 Vvalues
= Fcons (val
, Vvalues
);
793 if (EQ (Vstandard_output
, Qt
))
800 build_load_history (stream
, sourcename
);
803 unbind_to (count
, Qnil
);
808 DEFUN ("eval-buffer", Feval_buffer
, Seval_buffer
, 0, 2, "",
809 "Execute the current buffer as Lisp code.\n\
810 Programs can pass two arguments, BUFFER and PRINTFLAG.\n\
811 BUFFER is the buffer to evaluate (nil means use current buffer).\n\
812 PRINTFLAG controls printing of output:\n\
813 nil means discard it; anything else is stream for print.\n\
815 If there is no error, point does not move. If there is an error,\n\
816 point remains at the end of the last character read from the buffer.")
818 Lisp_Object buffer
, printflag
;
820 int count
= specpdl_ptr
- specpdl
;
821 Lisp_Object tem
, buf
;
824 buf
= Fcurrent_buffer ();
826 buf
= Fget_buffer (buffer
);
828 error ("No such buffer.");
830 if (NILP (printflag
))
834 specbind (Qstandard_output
, tem
);
835 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
836 BUF_SET_PT (XBUFFER (buf
), BUF_BEGV (XBUFFER (buf
)));
837 readevalloop (buf
, 0, XBUFFER (buf
)->filename
, Feval
, !NILP (printflag
));
838 unbind_to (count
, Qnil
);
844 DEFUN ("eval-current-buffer", Feval_current_buffer
, Seval_current_buffer
, 0, 1, "",
845 "Execute the current buffer as Lisp code.\n\
846 Programs can pass argument PRINTFLAG which controls printing of output:\n\
847 nil means discard it; anything else is stream for print.\n\
849 If there is no error, point does not move. If there is an error,\n\
850 point remains at the end of the last character read from the buffer.")
852 Lisp_Object printflag
;
854 int count
= specpdl_ptr
- specpdl
;
855 Lisp_Object tem
, cbuf
;
857 cbuf
= Fcurrent_buffer ()
859 if (NILP (printflag
))
863 specbind (Qstandard_output
, tem
);
864 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
866 readevalloop (cbuf
, 0, XBUFFER (cbuf
)->filename
, Feval
, !NILP (printflag
));
867 return unbind_to (count
, Qnil
);
871 DEFUN ("eval-region", Feval_region
, Seval_region
, 2, 3, "r",
872 "Execute the region as Lisp code.\n\
873 When called from programs, expects two arguments,\n\
874 giving starting and ending indices in the current buffer\n\
875 of the text to be executed.\n\
876 Programs can pass third argument PRINTFLAG which controls output:\n\
877 nil means discard it; anything else is stream for printing it.\n\
879 If there is no error, point does not move. If there is an error,\n\
880 point remains at the end of the last character read from the buffer.")
881 (start
, end
, printflag
)
882 Lisp_Object start
, end
, printflag
;
884 int count
= specpdl_ptr
- specpdl
;
885 Lisp_Object tem
, cbuf
;
887 cbuf
= Fcurrent_buffer ();
889 if (NILP (printflag
))
893 specbind (Qstandard_output
, tem
);
895 if (NILP (printflag
))
896 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
897 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
899 /* This both uses start and checks its type. */
901 Fnarrow_to_region (make_number (BEGV
), end
);
902 readevalloop (cbuf
, 0, XBUFFER (cbuf
)->filename
, Feval
, !NILP (printflag
));
904 return unbind_to (count
, Qnil
);
907 #endif /* standalone */
909 DEFUN ("read", Fread
, Sread
, 0, 1, 0,
910 "Read one Lisp expression as text from STREAM, return as Lisp object.\n\
911 If STREAM is nil, use the value of `standard-input' (which see).\n\
912 STREAM or the value of `standard-input' may be:\n\
913 a buffer (read from point and advance it)\n\
914 a marker (read from where it points and advance it)\n\
915 a function (call it with no arguments for each character,\n\
916 call it with a char as argument to push a char back)\n\
917 a string (takes text from string, starting at the beginning)\n\
918 t (read text line using minibuffer and use it).")
922 extern Lisp_Object
Fread_minibuffer ();
925 stream
= Vstandard_input
;
929 new_backquote_flag
= 0;
932 if (EQ (stream
, Qread_char
))
933 return Fread_minibuffer (build_string ("Lisp expression: "), Qnil
);
936 if (STRINGP (stream
))
937 return Fcar (Fread_from_string (stream
, Qnil
, Qnil
));
939 return read0 (stream
);
942 DEFUN ("read-from-string", Fread_from_string
, Sread_from_string
, 1, 3, 0,
943 "Read one Lisp expression which is represented as text by STRING.\n\
944 Returns a cons: (OBJECT-READ . FINAL-STRING-INDEX).\n\
945 START and END optionally delimit a substring of STRING from which to read;\n\
946 they default to 0 and (length STRING) respectively.")
948 Lisp_Object string
, start
, end
;
950 int startval
, endval
;
953 CHECK_STRING (string
,0);
956 endval
= XSTRING (string
)->size
;
958 { CHECK_NUMBER (end
,2);
960 if (endval
< 0 || endval
> XSTRING (string
)->size
)
961 args_out_of_range (string
, end
);
967 { CHECK_NUMBER (start
,1);
968 startval
= XINT (start
);
969 if (startval
< 0 || startval
> endval
)
970 args_out_of_range (string
, start
);
973 read_from_string_index
= startval
;
974 read_from_string_limit
= endval
;
976 new_backquote_flag
= 0;
978 tem
= read0 (string
);
979 return Fcons (tem
, make_number (read_from_string_index
));
982 /* Use this for recursive reads, in contexts where internal tokens
986 Lisp_Object readcharfun
;
988 register Lisp_Object val
;
991 val
= read1 (readcharfun
, &c
, 0);
993 Fsignal (Qinvalid_read_syntax
, Fcons (make_string (&c
, 1), Qnil
));
998 static int read_buffer_size
;
999 static char *read_buffer
;
1002 read_escape (readcharfun
)
1003 Lisp_Object readcharfun
;
1005 register int c
= READCHAR
;
1009 error ("End of file");
1035 error ("Invalid escape character syntax");
1038 c
= read_escape (readcharfun
);
1039 return c
| meta_modifier
;
1044 error ("Invalid escape character syntax");
1047 c
= read_escape (readcharfun
);
1048 return c
| shift_modifier
;
1053 error ("Invalid escape character syntax");
1056 c
= read_escape (readcharfun
);
1057 return c
| hyper_modifier
;
1062 error ("Invalid escape character syntax");
1065 c
= read_escape (readcharfun
);
1066 return c
| alt_modifier
;
1071 error ("Invalid escape character syntax");
1074 c
= read_escape (readcharfun
);
1075 return c
| super_modifier
;
1080 error ("Invalid escape character syntax");
1084 c
= read_escape (readcharfun
);
1085 if ((c
& 0177) == '?')
1087 /* ASCII control chars are made from letters (both cases),
1088 as well as the non-letters within 0100...0137. */
1089 else if ((c
& 0137) >= 0101 && (c
& 0137) <= 0132)
1090 return (c
& (037 | ~0177));
1091 else if ((c
& 0177) >= 0100 && (c
& 0177) <= 0137)
1092 return (c
& (037 | ~0177));
1094 return c
| ctrl_modifier
;
1104 /* An octal escape, as in ANSI C. */
1106 register int i
= c
- '0';
1107 register int count
= 0;
1110 if ((c
= READCHAR
) >= '0' && c
<= '7')
1125 /* A hex escape, as in ANSI C. */
1131 if (c
>= '0' && c
<= '9')
1136 else if ((c
>= 'a' && c
<= 'f')
1137 || (c
>= 'A' && c
<= 'F'))
1140 if (c
>= 'a' && c
<= 'f')
1159 /* If the next token is ')' or ']' or '.', we store that character
1160 in *PCH and the return value is not interesting. Else, we store
1161 zero in *PCH and we read and return one lisp object.
1163 FIRST_IN_LIST is nonzero if this is the first element of a list. */
1166 read1 (readcharfun
, pch
, first_in_list
)
1167 register Lisp_Object readcharfun
;
1177 if (c
< 0) return Fsignal (Qend_of_file
, Qnil
);
1182 return read_list (0, readcharfun
);
1185 return read_vector (readcharfun
);
1202 tmp
= read_vector (readcharfun
);
1203 if (XVECTOR (tmp
)->size
< CHAR_TABLE_STANDARD_SLOTS
1204 || XVECTOR (tmp
)->size
> CHAR_TABLE_STANDARD_SLOTS
+ 10)
1205 error ("Invalid size char-table");
1206 XSETCHAR_TABLE (tmp
, XCHAR_TABLE (tmp
));
1209 Fsignal (Qinvalid_read_syntax
, Fcons (make_string ("#^", 2), Qnil
));
1214 length
= read1 (readcharfun
, pch
, first_in_list
);
1218 Lisp_Object tmp
, val
;
1219 int size_in_chars
= ((XFASTINT (length
) + BITS_PER_CHAR
)
1223 tmp
= read1 (readcharfun
, pch
, first_in_list
);
1224 if (size_in_chars
!= XSTRING (tmp
)->size
)
1225 Fsignal (Qinvalid_read_syntax
,
1226 Fcons (make_string ("#&", 2), Qnil
));
1228 val
= Fmake_bool_vector (length
, Qnil
);
1229 bcopy (XSTRING (tmp
)->data
, XBOOL_VECTOR (val
)->data
,
1233 Fsignal (Qinvalid_read_syntax
, Fcons (make_string ("#&", 2), Qnil
));
1237 /* Accept compiled functions at read-time so that we don't have to
1238 build them using function calls. */
1240 tmp
= read_vector (readcharfun
);
1241 return Fmake_byte_code (XVECTOR (tmp
)->size
,
1242 XVECTOR (tmp
)->contents
);
1244 #ifdef USE_TEXT_PROPERTIES
1248 struct gcpro gcpro1
;
1251 /* Read the string itself. */
1252 tmp
= read1 (readcharfun
, &ch
, 0);
1253 if (ch
!= 0 || !STRINGP (tmp
))
1254 Fsignal (Qinvalid_read_syntax
, Fcons (make_string ("#", 1), Qnil
));
1256 /* Read the intervals and their properties. */
1259 Lisp_Object beg
, end
, plist
;
1261 beg
= read1 (readcharfun
, &ch
, 0);
1265 end
= read1 (readcharfun
, &ch
, 0);
1267 plist
= read1 (readcharfun
, &ch
, 0);
1269 Fsignal (Qinvalid_read_syntax
,
1270 Fcons (build_string ("invalid string property list"),
1272 Fset_text_properties (beg
, end
, plist
, tmp
);
1278 /* #@NUMBER is used to skip NUMBER following characters.
1279 That's used in .elc files to skip over doc strings
1280 and function definitions. */
1285 /* Read a decimal integer. */
1286 while ((c
= READCHAR
) >= 0
1287 && c
>= '0' && c
<= '9')
1295 #ifndef DOS_NT /* I don't know if filepos works right on MSDOS and Windoze. */
1296 if (load_force_doc_strings
&& EQ (readcharfun
, Qget_file_char
))
1298 /* If we are supposed to force doc strings into core right now,
1299 record the last string that we skipped,
1300 and record where in the file it comes from. */
1301 if (saved_doc_string_size
== 0)
1303 saved_doc_string_size
= nskip
+ 100;
1304 saved_doc_string
= (char *) xmalloc (saved_doc_string_size
);
1306 if (nskip
> saved_doc_string_size
)
1308 saved_doc_string_size
= nskip
+ 100;
1309 saved_doc_string
= (char *) xrealloc (saved_doc_string
,
1310 saved_doc_string_size
);
1313 saved_doc_string_position
= ftell (instream
);
1315 /* Copy that many characters into saved_doc_string. */
1316 for (i
= 0; i
< nskip
&& c
>= 0; i
++)
1317 saved_doc_string
[i
] = c
= READCHAR
;
1319 saved_doc_string_length
= i
;
1322 #endif /* not DOS_NT */
1324 /* Skip that many characters. */
1325 for (i
= 0; i
< nskip
&& c
>= 0; i
++)
1331 return Vload_file_name
;
1333 return Fcons (Qfunction
, Fcons (read0 (readcharfun
), Qnil
));
1337 Fsignal (Qinvalid_read_syntax
, Fcons (make_string ("#", 1), Qnil
));
1340 while ((c
= READCHAR
) >= 0 && c
!= '\n');
1345 return Fcons (Qquote
, Fcons (read0 (readcharfun
), Qnil
));
1355 new_backquote_flag
= 1;
1356 value
= read0 (readcharfun
);
1357 new_backquote_flag
= 0;
1359 return Fcons (Qbackquote
, Fcons (value
, Qnil
));
1363 if (new_backquote_flag
)
1365 Lisp_Object comma_type
= Qnil
;
1370 comma_type
= Qcomma_at
;
1372 comma_type
= Qcomma_dot
;
1375 if (ch
>= 0) UNREAD (ch
);
1376 comma_type
= Qcomma
;
1379 new_backquote_flag
= 0;
1380 value
= read0 (readcharfun
);
1381 new_backquote_flag
= 1;
1382 return Fcons (comma_type
, Fcons (value
, Qnil
));
1389 register Lisp_Object val
;
1392 if (c
< 0) return Fsignal (Qend_of_file
, Qnil
);
1395 XSETINT (val
, read_escape (readcharfun
));
1404 register char *p
= read_buffer
;
1405 register char *end
= read_buffer
+ read_buffer_size
;
1409 while ((c
= READCHAR
) >= 0
1414 char *new = (char *) xrealloc (read_buffer
, read_buffer_size
*= 2);
1415 p
+= new - read_buffer
;
1416 read_buffer
+= new - read_buffer
;
1417 end
= read_buffer
+ read_buffer_size
;
1420 c
= read_escape (readcharfun
);
1421 /* c is -1 if \ newline has just been seen */
1424 if (p
== read_buffer
)
1429 /* Allow `\C- ' and `\C-?'. */
1430 if (c
== (CHAR_CTL
| ' '))
1432 else if (c
== (CHAR_CTL
| '?'))
1436 /* Move the meta bit to the right place for a string. */
1437 c
= (c
& ~CHAR_META
) | 0x80;
1439 error ("Invalid modifier in string");
1443 if (c
< 0) return Fsignal (Qend_of_file
, Qnil
);
1445 /* If purifying, and string starts with \ newline,
1446 return zero instead. This is for doc strings
1447 that we are really going to find in etc/DOC.nn.nn */
1448 if (!NILP (Vpurify_flag
) && NILP (Vdoc_file_name
) && cancel
)
1449 return make_number (0);
1452 return make_pure_string (read_buffer
, p
- read_buffer
);
1454 return make_string (read_buffer
, p
- read_buffer
);
1459 #ifdef LISP_FLOAT_TYPE
1460 /* If a period is followed by a number, then we should read it
1461 as a floating point number. Otherwise, it denotes a dotted
1463 int next_char
= READCHAR
;
1466 if (! (next_char
>= '0' && next_char
<= '9'))
1473 /* Otherwise, we fall through! Note that the atom-reading loop
1474 below will now loop at least once, assuring that we will not
1475 try to UNREAD two characters in a row. */
1479 if (c
<= 040) goto retry
;
1481 register char *p
= read_buffer
;
1485 register char *end
= read_buffer
+ read_buffer_size
;
1488 !(c
== '\"' || c
== '\'' || c
== ';' || c
== '?'
1489 || c
== '(' || c
== ')'
1490 #ifndef LISP_FLOAT_TYPE
1491 /* If we have floating-point support, then we need
1492 to allow <digits><dot><digits>. */
1494 #endif /* not LISP_FLOAT_TYPE */
1495 || c
== '[' || c
== ']' || c
== '#'
1500 register char *new = (char *) xrealloc (read_buffer
, read_buffer_size
*= 2);
1501 p
+= new - read_buffer
;
1502 read_buffer
+= new - read_buffer
;
1503 end
= read_buffer
+ read_buffer_size
;
1516 char *new = (char *) xrealloc (read_buffer
, read_buffer_size
*= 2);
1517 p
+= new - read_buffer
;
1518 read_buffer
+= new - read_buffer
;
1519 /* end = read_buffer + read_buffer_size; */
1529 register Lisp_Object val
;
1531 if (*p1
== '+' || *p1
== '-') p1
++;
1532 /* Is it an integer? */
1535 while (p1
!= p
&& (c
= *p1
) >= '0' && c
<= '9') p1
++;
1536 #ifdef LISP_FLOAT_TYPE
1537 /* Integers can have trailing decimal points. */
1538 if (p1
> read_buffer
&& p1
< p
&& *p1
== '.') p1
++;
1541 /* It is an integer. */
1543 #ifdef LISP_FLOAT_TYPE
1547 if (sizeof (int) == sizeof (EMACS_INT
))
1548 XSETINT (val
, atoi (read_buffer
));
1549 else if (sizeof (long) == sizeof (EMACS_INT
))
1550 XSETINT (val
, atol (read_buffer
));
1556 #ifdef LISP_FLOAT_TYPE
1557 if (isfloat_string (read_buffer
))
1558 return make_float (atof (read_buffer
));
1562 return intern (read_buffer
);
1567 #ifdef LISP_FLOAT_TYPE
1582 if (*cp
== '+' || *cp
== '-')
1585 if (*cp
>= '0' && *cp
<= '9')
1588 while (*cp
>= '0' && *cp
<= '9')
1596 if (*cp
>= '0' && *cp
<= '9')
1599 while (*cp
>= '0' && *cp
<= '9')
1606 if (*cp
== '+' || *cp
== '-')
1610 if (*cp
>= '0' && *cp
<= '9')
1613 while (*cp
>= '0' && *cp
<= '9')
1616 return (((*cp
== 0) || (*cp
== ' ') || (*cp
== '\t') || (*cp
== '\n') || (*cp
== '\r') || (*cp
== '\f'))
1617 && (state
== (LEAD_INT
|DOT_CHAR
|TRAIL_INT
)
1618 || state
== (DOT_CHAR
|TRAIL_INT
)
1619 || state
== (LEAD_INT
|E_CHAR
|EXP_INT
)
1620 || state
== (LEAD_INT
|DOT_CHAR
|TRAIL_INT
|E_CHAR
|EXP_INT
)
1621 || state
== (DOT_CHAR
|TRAIL_INT
|E_CHAR
|EXP_INT
)));
1623 #endif /* LISP_FLOAT_TYPE */
1626 read_vector (readcharfun
)
1627 Lisp_Object readcharfun
;
1631 register Lisp_Object
*ptr
;
1632 register Lisp_Object tem
, vector
;
1633 register struct Lisp_Cons
*otem
;
1636 tem
= read_list (1, readcharfun
);
1637 len
= Flength (tem
);
1638 vector
= (read_pure
? make_pure_vector (XINT (len
)) : Fmake_vector (len
, Qnil
));
1641 size
= XVECTOR (vector
)->size
;
1642 ptr
= XVECTOR (vector
)->contents
;
1643 for (i
= 0; i
< size
; i
++)
1645 ptr
[i
] = read_pure
? Fpurecopy (Fcar (tem
)) : Fcar (tem
);
1653 /* flag = 1 means check for ] to terminate rather than ) and .
1654 flag = -1 means check for starting with defun
1655 and make structure pure. */
1658 read_list (flag
, readcharfun
)
1660 register Lisp_Object readcharfun
;
1662 /* -1 means check next element for defun,
1663 0 means don't check,
1664 1 means already checked and found defun. */
1665 int defunflag
= flag
< 0 ? -1 : 0;
1666 Lisp_Object val
, tail
;
1667 register Lisp_Object elt
, tem
;
1668 struct gcpro gcpro1
, gcpro2
;
1669 /* 0 is the normal case.
1670 1 means this list is a doc reference; replace it with the number 0.
1671 2 means this list is a doc reference; replace it with the doc string. */
1672 int doc_reference
= 0;
1674 /* Initialize this to 1 if we are reading a list. */
1675 int first_in_list
= flag
<= 0;
1684 elt
= read1 (readcharfun
, &ch
, first_in_list
);
1689 /* While building, if the list starts with #$, treat it specially. */
1690 if (EQ (elt
, Vload_file_name
)
1691 && !NILP (Vpurify_flag
))
1693 if (NILP (Vdoc_file_name
))
1694 /* We have not yet called Snarf-documentation, so assume
1695 this file is described in the DOC-MM.NN file
1696 and Snarf-documentation will fill in the right value later.
1697 For now, replace the whole list with 0. */
1700 /* We have already called Snarf-documentation, so make a relative
1701 file name for this file, so it can be found properly
1702 in the installed Lisp directory.
1703 We don't use Fexpand_file_name because that would make
1704 the directory absolute now. */
1705 elt
= concat2 (build_string ("../lisp/"),
1706 Ffile_name_nondirectory (elt
));
1708 else if (EQ (elt
, Vload_file_name
)
1709 && load_force_doc_strings
)
1718 Fsignal (Qinvalid_read_syntax
,
1719 Fcons (make_string (") or . in a vector", 18), Qnil
));
1727 XCONS (tail
)->cdr
= read0 (readcharfun
);
1729 val
= read0 (readcharfun
);
1730 read1 (readcharfun
, &ch
, 0);
1734 if (doc_reference
== 1)
1735 return make_number (0);
1736 if (doc_reference
== 2)
1738 /* Get a doc string from the file we are loading.
1739 If it's in saved_doc_string, get it from there. */
1740 int pos
= XINT (XCONS (val
)->cdr
);
1741 if (pos
>= saved_doc_string_position
1742 && pos
< (saved_doc_string_position
1743 + saved_doc_string_length
))
1745 int start
= pos
- saved_doc_string_position
;
1748 /* Process quoting with ^A,
1749 and find the end of the string,
1750 which is marked with ^_ (037). */
1751 for (from
= start
, to
= start
;
1752 saved_doc_string
[from
] != 037;)
1754 int c
= saved_doc_string
[from
++];
1757 c
= saved_doc_string
[from
++];
1759 saved_doc_string
[to
++] = c
;
1761 saved_doc_string
[to
++] = 0;
1763 saved_doc_string
[to
++] = 037;
1766 saved_doc_string
[to
++] = c
;
1769 return make_string (saved_doc_string
+ start
,
1773 return read_doc_string (val
);
1778 return Fsignal (Qinvalid_read_syntax
, Fcons (make_string (". in wrong context", 18), Qnil
));
1780 return Fsignal (Qinvalid_read_syntax
, Fcons (make_string ("] in a list", 11), Qnil
));
1782 tem
= (read_pure
&& flag
<= 0
1783 ? pure_cons (elt
, Qnil
)
1784 : Fcons (elt
, Qnil
));
1786 XCONS (tail
)->cdr
= tem
;
1791 defunflag
= EQ (elt
, Qdefun
);
1792 else if (defunflag
> 0)
1797 Lisp_Object Vobarray
;
1798 Lisp_Object initial_obarray
;
1800 /* oblookup stores the bucket number here, for the sake of Funintern. */
1802 int oblookup_last_bucket_number
;
1804 static int hash_string ();
1805 Lisp_Object
oblookup ();
1807 /* Get an error if OBARRAY is not an obarray.
1808 If it is one, return it. */
1811 check_obarray (obarray
)
1812 Lisp_Object obarray
;
1814 while (!VECTORP (obarray
) || XVECTOR (obarray
)->size
== 0)
1816 /* If Vobarray is now invalid, force it to be valid. */
1817 if (EQ (Vobarray
, obarray
)) Vobarray
= initial_obarray
;
1819 obarray
= wrong_type_argument (Qvectorp
, obarray
);
1824 /* Intern the C string STR: return a symbol with that name,
1825 interned in the current obarray. */
1832 int len
= strlen (str
);
1833 Lisp_Object obarray
;
1836 if (!VECTORP (obarray
) || XVECTOR (obarray
)->size
== 0)
1837 obarray
= check_obarray (obarray
);
1838 tem
= oblookup (obarray
, str
, len
);
1841 return Fintern ((!NILP (Vpurify_flag
)
1842 ? make_pure_string (str
, len
)
1843 : make_string (str
, len
)),
1847 DEFUN ("intern", Fintern
, Sintern
, 1, 2, 0,
1848 "Return the canonical symbol whose name is STRING.\n\
1849 If there is none, one is created by this function and returned.\n\
1850 A second optional argument specifies the obarray to use;\n\
1851 it defaults to the value of `obarray'.")
1853 Lisp_Object string
, obarray
;
1855 register Lisp_Object tem
, sym
, *ptr
;
1857 if (NILP (obarray
)) obarray
= Vobarray
;
1858 obarray
= check_obarray (obarray
);
1860 CHECK_STRING (string
, 0);
1862 tem
= oblookup (obarray
, XSTRING (string
)->data
, XSTRING (string
)->size
);
1863 if (!INTEGERP (tem
))
1866 if (!NILP (Vpurify_flag
))
1867 string
= Fpurecopy (string
);
1868 sym
= Fmake_symbol (string
);
1870 ptr
= &XVECTOR (obarray
)->contents
[XINT (tem
)];
1872 XSYMBOL (sym
)->next
= XSYMBOL (*ptr
);
1874 XSYMBOL (sym
)->next
= 0;
1879 DEFUN ("intern-soft", Fintern_soft
, Sintern_soft
, 1, 2, 0,
1880 "Return the canonical symbol whose name is STRING, or nil if none exists.\n\
1881 A second optional argument specifies the obarray to use;\n\
1882 it defaults to the value of `obarray'.")
1884 Lisp_Object string
, obarray
;
1886 register Lisp_Object tem
;
1888 if (NILP (obarray
)) obarray
= Vobarray
;
1889 obarray
= check_obarray (obarray
);
1891 CHECK_STRING (string
, 0);
1893 tem
= oblookup (obarray
, XSTRING (string
)->data
, XSTRING (string
)->size
);
1894 if (!INTEGERP (tem
))
1899 DEFUN ("unintern", Funintern
, Sunintern
, 1, 2, 0,
1900 "Delete the symbol named NAME, if any, from OBARRAY.\n\
1901 The value is t if a symbol was found and deleted, nil otherwise.\n\
1902 NAME may be a string or a symbol. If it is a symbol, that symbol\n\
1903 is deleted, if it belongs to OBARRAY--no other symbol is deleted.\n\
1904 OBARRAY defaults to the value of the variable `obarray'.")
1906 Lisp_Object name
, obarray
;
1908 register Lisp_Object string
, tem
;
1911 if (NILP (obarray
)) obarray
= Vobarray
;
1912 obarray
= check_obarray (obarray
);
1915 XSETSTRING (string
, XSYMBOL (name
)->name
);
1918 CHECK_STRING (name
, 0);
1922 tem
= oblookup (obarray
, XSTRING (string
)->data
, XSTRING (string
)->size
);
1925 /* If arg was a symbol, don't delete anything but that symbol itself. */
1926 if (SYMBOLP (name
) && !EQ (name
, tem
))
1929 hash
= oblookup_last_bucket_number
;
1931 if (EQ (XVECTOR (obarray
)->contents
[hash
], tem
))
1933 if (XSYMBOL (tem
)->next
)
1934 XSETSYMBOL (XVECTOR (obarray
)->contents
[hash
], XSYMBOL (tem
)->next
);
1936 XSETINT (XVECTOR (obarray
)->contents
[hash
], 0);
1940 Lisp_Object tail
, following
;
1942 for (tail
= XVECTOR (obarray
)->contents
[hash
];
1943 XSYMBOL (tail
)->next
;
1946 XSETSYMBOL (following
, XSYMBOL (tail
)->next
);
1947 if (EQ (following
, tem
))
1949 XSYMBOL (tail
)->next
= XSYMBOL (following
)->next
;
1958 /* Return the symbol in OBARRAY whose names matches the string
1959 of SIZE characters at PTR. If there is no such symbol in OBARRAY,
1962 Also store the bucket number in oblookup_last_bucket_number. */
1965 oblookup (obarray
, ptr
, size
)
1966 Lisp_Object obarray
;
1972 register Lisp_Object tail
;
1973 Lisp_Object bucket
, tem
;
1975 if (!VECTORP (obarray
)
1976 || (obsize
= XVECTOR (obarray
)->size
) == 0)
1978 obarray
= check_obarray (obarray
);
1979 obsize
= XVECTOR (obarray
)->size
;
1981 /* This is sometimes needed in the middle of GC. */
1982 obsize
&= ~ARRAY_MARK_FLAG
;
1983 /* Combining next two lines breaks VMS C 2.3. */
1984 hash
= hash_string (ptr
, size
);
1986 bucket
= XVECTOR (obarray
)->contents
[hash
];
1987 oblookup_last_bucket_number
= hash
;
1988 if (XFASTINT (bucket
) == 0)
1990 else if (!SYMBOLP (bucket
))
1991 error ("Bad data in guts of obarray"); /* Like CADR error message */
1993 for (tail
= bucket
; ; XSETSYMBOL (tail
, XSYMBOL (tail
)->next
))
1995 if (XSYMBOL (tail
)->name
->size
== size
1996 && !bcmp (XSYMBOL (tail
)->name
->data
, ptr
, size
))
1998 else if (XSYMBOL (tail
)->next
== 0)
2001 XSETINT (tem
, hash
);
2006 hash_string (ptr
, len
)
2010 register unsigned char *p
= ptr
;
2011 register unsigned char *end
= p
+ len
;
2012 register unsigned char c
;
2013 register int hash
= 0;
2018 if (c
>= 0140) c
-= 40;
2019 hash
= ((hash
<<3) + (hash
>>28) + c
);
2021 return hash
& 07777777777;
2025 map_obarray (obarray
, fn
, arg
)
2026 Lisp_Object obarray
;
2031 register Lisp_Object tail
;
2032 CHECK_VECTOR (obarray
, 1);
2033 for (i
= XVECTOR (obarray
)->size
- 1; i
>= 0; i
--)
2035 tail
= XVECTOR (obarray
)->contents
[i
];
2036 if (XFASTINT (tail
) != 0)
2040 if (XSYMBOL (tail
)->next
== 0)
2042 XSETSYMBOL (tail
, XSYMBOL (tail
)->next
);
2047 mapatoms_1 (sym
, function
)
2048 Lisp_Object sym
, function
;
2050 call1 (function
, sym
);
2053 DEFUN ("mapatoms", Fmapatoms
, Smapatoms
, 1, 2, 0,
2054 "Call FUNCTION on every symbol in OBARRAY.\n\
2055 OBARRAY defaults to the value of `obarray'.")
2057 Lisp_Object function
, obarray
;
2061 if (NILP (obarray
)) obarray
= Vobarray
;
2062 obarray
= check_obarray (obarray
);
2064 map_obarray (obarray
, mapatoms_1
, function
);
2068 #define OBARRAY_SIZE 1511
2073 Lisp_Object oblength
;
2077 XSETFASTINT (oblength
, OBARRAY_SIZE
);
2079 Qnil
= Fmake_symbol (make_pure_string ("nil", 3));
2080 Vobarray
= Fmake_vector (oblength
, make_number (0));
2081 initial_obarray
= Vobarray
;
2082 staticpro (&initial_obarray
);
2083 /* Intern nil in the obarray */
2084 /* These locals are to kludge around a pyramid compiler bug. */
2085 hash
= hash_string ("nil", 3);
2086 /* Separate statement here to avoid VAXC bug. */
2087 hash
%= OBARRAY_SIZE
;
2088 tem
= &XVECTOR (Vobarray
)->contents
[hash
];
2091 Qunbound
= Fmake_symbol (make_pure_string ("unbound", 7));
2092 XSYMBOL (Qnil
)->function
= Qunbound
;
2093 XSYMBOL (Qunbound
)->value
= Qunbound
;
2094 XSYMBOL (Qunbound
)->function
= Qunbound
;
2097 XSYMBOL (Qnil
)->value
= Qnil
;
2098 XSYMBOL (Qnil
)->plist
= Qnil
;
2099 XSYMBOL (Qt
)->value
= Qt
;
2101 /* Qt is correct even if CANNOT_DUMP. loadup.el will set to nil at end. */
2104 Qvariable_documentation
= intern ("variable-documentation");
2106 read_buffer_size
= 100;
2107 read_buffer
= (char *) malloc (read_buffer_size
);
2112 struct Lisp_Subr
*sname
;
2115 sym
= intern (sname
->symbol_name
);
2116 XSETSUBR (XSYMBOL (sym
)->function
, sname
);
2119 #ifdef NOTDEF /* use fset in subr.el now */
2121 defalias (sname
, string
)
2122 struct Lisp_Subr
*sname
;
2126 sym
= intern (string
);
2127 XSETSUBR (XSYMBOL (sym
)->function
, sname
);
2131 /* Define an "integer variable"; a symbol whose value is forwarded
2132 to a C variable of type int. Sample call: */
2133 /* DEFVAR_INT ("indent-tabs-mode", &indent_tabs_mode, "Documentation"); */
2135 defvar_int (namestring
, address
)
2139 Lisp_Object sym
, val
;
2140 sym
= intern (namestring
);
2141 val
= allocate_misc ();
2142 XMISCTYPE (val
) = Lisp_Misc_Intfwd
;
2143 XINTFWD (val
)->intvar
= address
;
2144 XSYMBOL (sym
)->value
= val
;
2147 /* Similar but define a variable whose value is T if address contains 1,
2148 NIL if address contains 0 */
2150 defvar_bool (namestring
, address
)
2154 Lisp_Object sym
, val
;
2155 sym
= intern (namestring
);
2156 val
= allocate_misc ();
2157 XMISCTYPE (val
) = Lisp_Misc_Boolfwd
;
2158 XBOOLFWD (val
)->boolvar
= address
;
2159 XSYMBOL (sym
)->value
= val
;
2162 /* Similar but define a variable whose value is the Lisp Object stored
2163 at address. Two versions: with and without gc-marking of the C
2164 variable. The nopro version is used when that variable will be
2165 gc-marked for some other reason, since marking the same slot twice
2166 can cause trouble with strings. */
2168 defvar_lisp_nopro (namestring
, address
)
2170 Lisp_Object
*address
;
2172 Lisp_Object sym
, val
;
2173 sym
= intern (namestring
);
2174 val
= allocate_misc ();
2175 XMISCTYPE (val
) = Lisp_Misc_Objfwd
;
2176 XOBJFWD (val
)->objvar
= address
;
2177 XSYMBOL (sym
)->value
= val
;
2181 defvar_lisp (namestring
, address
)
2183 Lisp_Object
*address
;
2185 defvar_lisp_nopro (namestring
, address
);
2186 staticpro (address
);
2191 /* Similar but define a variable whose value is the Lisp Object stored in
2192 the current buffer. address is the address of the slot in the buffer
2193 that is current now. */
2196 defvar_per_buffer (namestring
, address
, type
, doc
)
2198 Lisp_Object
*address
;
2202 Lisp_Object sym
, val
;
2204 extern struct buffer buffer_local_symbols
;
2206 sym
= intern (namestring
);
2207 val
= allocate_misc ();
2208 offset
= (char *)address
- (char *)current_buffer
;
2210 XMISCTYPE (val
) = Lisp_Misc_Buffer_Objfwd
;
2211 XBUFFER_OBJFWD (val
)->offset
= offset
;
2212 XSYMBOL (sym
)->value
= val
;
2213 *(Lisp_Object
*)(offset
+ (char *)&buffer_local_symbols
) = sym
;
2214 *(Lisp_Object
*)(offset
+ (char *)&buffer_local_types
) = type
;
2215 if (XINT (*(Lisp_Object
*)(offset
+ (char *)&buffer_local_flags
)) == 0)
2216 /* Did a DEFVAR_PER_BUFFER without initializing the corresponding
2217 slot of buffer_local_flags */
2221 #endif /* standalone */
2223 /* Similar but define a variable whose value is the Lisp Object stored
2224 at a particular offset in the current kboard object. */
2227 defvar_kboard (namestring
, offset
)
2231 Lisp_Object sym
, val
;
2232 sym
= intern (namestring
);
2233 val
= allocate_misc ();
2234 XMISCTYPE (val
) = Lisp_Misc_Kboard_Objfwd
;
2235 XKBOARD_OBJFWD (val
)->offset
= offset
;
2236 XSYMBOL (sym
)->value
= val
;
2239 /* Record the value of load-path used at the start of dumping
2240 so we can see if the site changed it later during dumping. */
2241 static Lisp_Object dump_path
;
2246 int turn_off_warning
= 0;
2248 #ifdef HAVE_SETLOCALE
2249 /* Make sure numbers are parsed as we expect. */
2250 setlocale (LC_NUMERIC
, "C");
2251 #endif /* HAVE_SETLOCALE */
2253 /* Compute the default load-path. */
2255 normal
= PATH_LOADSEARCH
;
2256 Vload_path
= decode_env_path (0, normal
);
2258 if (NILP (Vpurify_flag
))
2259 normal
= PATH_LOADSEARCH
;
2261 normal
= PATH_DUMPLOADSEARCH
;
2263 /* In a dumped Emacs, we normally have to reset the value of
2264 Vload_path from PATH_LOADSEARCH, since the value that was dumped
2265 uses ../lisp, instead of the path of the installed elisp
2266 libraries. However, if it appears that Vload_path was changed
2267 from the default before dumping, don't override that value. */
2270 if (! NILP (Fequal (dump_path
, Vload_path
)))
2272 Vload_path
= decode_env_path (0, normal
);
2273 if (!NILP (Vinstallation_directory
))
2275 /* Add to the path the lisp subdir of the
2276 installation dir, if it exists. */
2277 Lisp_Object tem
, tem1
;
2278 tem
= Fexpand_file_name (build_string ("lisp"),
2279 Vinstallation_directory
);
2280 tem1
= Ffile_exists_p (tem
);
2283 if (NILP (Fmember (tem
, Vload_path
)))
2285 turn_off_warning
= 1;
2286 Vload_path
= nconc2 (Vload_path
, Fcons (tem
, Qnil
));
2290 /* That dir doesn't exist, so add the build-time
2291 Lisp dirs instead. */
2292 Vload_path
= nconc2 (Vload_path
, dump_path
);
2294 /* Add site-list under the installation dir, if it exists. */
2295 tem
= Fexpand_file_name (build_string ("site-lisp"),
2296 Vinstallation_directory
);
2297 tem1
= Ffile_exists_p (tem
);
2300 if (NILP (Fmember (tem
, Vload_path
)))
2301 Vload_path
= nconc2 (Vload_path
, Fcons (tem
, Qnil
));
2308 /* ../lisp refers to the build directory.
2309 NORMAL refers to the lisp dir in the source directory. */
2310 Vload_path
= Fcons (build_string ("../lisp"),
2311 decode_env_path (0, normal
));
2312 dump_path
= Vload_path
;
2317 /* When Emacs is invoked over network shares on NT, PATH_LOADSEARCH is
2318 almost never correct, thereby causing a warning to be printed out that
2319 confuses users. Since PATH_LOADSEARCH is always overridden by the
2320 EMACSLOADPATH environment variable below, disable the warning on NT. */
2322 /* Warn if dirs in the *standard* path don't exist. */
2323 if (!turn_off_warning
)
2325 Lisp_Object path_tail
;
2327 for (path_tail
= Vload_path
;
2329 path_tail
= XCONS (path_tail
)->cdr
)
2331 Lisp_Object dirfile
;
2332 dirfile
= Fcar (path_tail
);
2333 if (STRINGP (dirfile
))
2335 dirfile
= Fdirectory_file_name (dirfile
);
2336 if (access (XSTRING (dirfile
)->data
, 0) < 0)
2338 "Warning: Lisp directory `%s' does not exist.\n",
2339 XSTRING (Fcar (path_tail
))->data
);
2343 #endif /* WINDOWSNT */
2345 /* If the EMACSLOADPATH environment variable is set, use its value.
2346 This doesn't apply if we're dumping. */
2348 if (NILP (Vpurify_flag
)
2349 && egetenv ("EMACSLOADPATH"))
2351 Vload_path
= decode_env_path ("EMACSLOADPATH", normal
);
2355 load_in_progress
= 0;
2356 Vload_file_name
= Qnil
;
2358 load_descriptor_list
= Qnil
;
2365 defsubr (&Sread_from_string
);
2367 defsubr (&Sintern_soft
);
2368 defsubr (&Sunintern
);
2370 defsubr (&Seval_buffer
);
2371 defsubr (&Seval_region
);
2372 defsubr (&Sread_char
);
2373 defsubr (&Sread_char_exclusive
);
2374 defsubr (&Sread_event
);
2375 defsubr (&Sget_file_char
);
2376 defsubr (&Smapatoms
);
2378 DEFVAR_LISP ("obarray", &Vobarray
,
2379 "Symbol table for use by `intern' and `read'.\n\
2380 It is a vector whose length ought to be prime for best results.\n\
2381 The vector's contents don't make sense if examined from Lisp programs;\n\
2382 to find all the symbols in an obarray, use `mapatoms'.");
2384 DEFVAR_LISP ("values", &Vvalues
,
2385 "List of values of all expressions which were read, evaluated and printed.\n\
2386 Order is reverse chronological.");
2388 DEFVAR_LISP ("standard-input", &Vstandard_input
,
2389 "Stream for read to get input from.\n\
2390 See documentation of `read' for possible values.");
2391 Vstandard_input
= Qt
;
2393 DEFVAR_LISP ("load-path", &Vload_path
,
2394 "*List of directories to search for files to load.\n\
2395 Each element is a string (directory name) or nil (try default directory).\n\
2396 Initialized based on EMACSLOADPATH environment variable, if any,\n\
2397 otherwise to default specified by file `paths.h' when Emacs was built.");
2399 DEFVAR_BOOL ("load-in-progress", &load_in_progress
,
2400 "Non-nil iff inside of `load'.");
2402 DEFVAR_LISP ("after-load-alist", &Vafter_load_alist
,
2403 "An alist of expressions to be evalled when particular files are loaded.\n\
2404 Each element looks like (FILENAME FORMS...).\n\
2405 When `load' is run and the file-name argument is FILENAME,\n\
2406 the FORMS in the corresponding element are executed at the end of loading.\n\n\
2407 FILENAME must match exactly! Normally FILENAME is the name of a library,\n\
2408 with no directory specified, since that is how `load' is normally called.\n\
2409 An error in FORMS does not undo the load,\n\
2410 but does prevent execution of the rest of the FORMS.");
2411 Vafter_load_alist
= Qnil
;
2413 DEFVAR_LISP ("load-history", &Vload_history
,
2414 "Alist mapping source file names to symbols and features.\n\
2415 Each alist element is a list that starts with a file name,\n\
2416 except for one element (optional) that starts with nil and describes\n\
2417 definitions evaluated from buffers not visiting files.\n\
2418 The remaining elements of each list are symbols defined as functions\n\
2419 or variables, and cons cells `(provide . FEATURE)' and `(require . FEATURE)'.");
2420 Vload_history
= Qnil
;
2422 DEFVAR_LISP ("load-file-name", &Vload_file_name
,
2423 "Full name of file being loaded by `load'.");
2424 Vload_file_name
= Qnil
;
2426 DEFVAR_LISP ("current-load-list", &Vcurrent_load_list
,
2427 "Used for internal purposes by `load'.");
2428 Vcurrent_load_list
= Qnil
;
2430 DEFVAR_LISP ("load-read-function", &Vload_read_function
,
2431 "Function used by `load' and `eval-region' for reading expressions.\n\
2432 The default is nil, which means use the function `read'.");
2433 Vload_read_function
= Qnil
;
2435 DEFVAR_BOOL ("load-force-doc-strings", &load_force_doc_strings
,
2436 "Non-nil means `load' should force-load all dynamic doc strings.\n\
2437 This is useful when the file being loaded is a temporary copy.");
2438 load_force_doc_strings
= 0;
2440 DEFVAR_LISP ("source-directory", &Vsource_directory
,
2441 "Directory in which Emacs sources were found when Emacs was built.\n\
2442 You cannot count on them to still be there!");
2444 = Fexpand_file_name (build_string ("../"),
2445 Fcar (decode_env_path (0, PATH_DUMPLOADSEARCH
)));
2447 /* Vsource_directory was initialized in init_lread. */
2449 load_descriptor_list
= Qnil
;
2450 staticpro (&load_descriptor_list
);
2452 Qcurrent_load_list
= intern ("current-load-list");
2453 staticpro (&Qcurrent_load_list
);
2455 Qstandard_input
= intern ("standard-input");
2456 staticpro (&Qstandard_input
);
2458 Qread_char
= intern ("read-char");
2459 staticpro (&Qread_char
);
2461 Qget_file_char
= intern ("get-file-char");
2462 staticpro (&Qget_file_char
);
2464 Qbackquote
= intern ("`");
2465 staticpro (&Qbackquote
);
2466 Qcomma
= intern (",");
2467 staticpro (&Qcomma
);
2468 Qcomma_at
= intern (",@");
2469 staticpro (&Qcomma_at
);
2470 Qcomma_dot
= intern (",.");
2471 staticpro (&Qcomma_dot
);
2473 Qascii_character
= intern ("ascii-character");
2474 staticpro (&Qascii_character
);
2476 Qfunction
= intern ("function");
2477 staticpro (&Qfunction
);
2479 Qload
= intern ("load");
2482 Qload_file_name
= intern ("load-file-name");
2483 staticpro (&Qload_file_name
);
2485 staticpro (&dump_path
);