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>
47 #ifdef LISP_FLOAT_TYPE
57 #endif /* LISP_FLOAT_TYPE */
61 #endif /* HAVE_SETLOCALE */
69 Lisp_Object Qread_char
, Qget_file_char
, Qstandard_input
, Qcurrent_load_list
;
70 Lisp_Object Qvariable_documentation
, Vvalues
, Vstandard_input
, Vafter_load_alist
;
71 Lisp_Object Qascii_character
, Qload
, Qload_file_name
;
72 Lisp_Object Qbackquote
, Qcomma
, Qcomma_at
, Qcomma_dot
, Qfunction
;
74 extern Lisp_Object Qevent_symbol_element_mask
;
76 /* non-zero if inside `load' */
79 /* Directory in which the sources were found. */
80 Lisp_Object Vsource_directory
;
82 /* Search path for files to be loaded. */
83 Lisp_Object Vload_path
;
85 /* This is the user-visible association list that maps features to
86 lists of defs in their load files. */
87 Lisp_Object Vload_history
;
89 /* This is used to build the load history. */
90 Lisp_Object Vcurrent_load_list
;
92 /* Name of file actually being read by `load'. */
93 Lisp_Object Vload_file_name
;
95 /* Function to use for reading, in `load' and friends. */
96 Lisp_Object Vload_read_function
;
98 /* Nonzero means load should forcibly load all dynamic doc strings. */
99 static int load_force_doc_strings
;
101 /* List of descriptors now open for Fload. */
102 static Lisp_Object load_descriptor_list
;
104 /* File for get_file_char to read from. Use by load. */
105 static FILE *instream
;
107 /* When nonzero, read conses in pure space */
108 static int read_pure
;
110 /* For use within read-from-string (this reader is non-reentrant!!) */
111 static int read_from_string_index
;
112 static int read_from_string_limit
;
114 /* This contains the last string skipped with #@. */
115 static char *saved_doc_string
;
116 /* Length of buffer allocated in saved_doc_string. */
117 static int saved_doc_string_size
;
118 /* Length of actual data in saved_doc_string. */
119 static int saved_doc_string_length
;
120 /* This is the file position that string came from. */
121 static int saved_doc_string_position
;
123 /* Nonzero means inside a new-style backquote
124 with no surrounding parentheses.
125 Fread initializes this to zero, so we need not specbind it
126 or worry about what happens to it when there is an error. */
127 static int new_backquote_flag
;
129 /* Handle unreading and rereading of characters.
130 Write READCHAR to read a character,
131 UNREAD(c) to unread c to be read again. */
133 #define READCHAR readchar (readcharfun)
134 #define UNREAD(c) unreadchar (readcharfun, c)
137 readchar (readcharfun
)
138 Lisp_Object readcharfun
;
141 register struct buffer
*inbuffer
;
142 register int c
, mpos
;
144 if (BUFFERP (readcharfun
))
146 inbuffer
= XBUFFER (readcharfun
);
148 if (BUF_PT (inbuffer
) >= BUF_ZV (inbuffer
))
150 c
= *(unsigned char *) BUF_CHAR_ADDRESS (inbuffer
, BUF_PT (inbuffer
));
151 SET_BUF_PT (inbuffer
, BUF_PT (inbuffer
) + 1);
155 if (MARKERP (readcharfun
))
157 inbuffer
= XMARKER (readcharfun
)->buffer
;
159 mpos
= marker_position (readcharfun
);
161 if (mpos
> BUF_ZV (inbuffer
) - 1)
163 c
= *(unsigned char *) BUF_CHAR_ADDRESS (inbuffer
, mpos
);
164 if (mpos
!= BUF_GPT (inbuffer
))
165 XMARKER (readcharfun
)->bufpos
++;
167 Fset_marker (readcharfun
, make_number (mpos
+ 1),
168 Fmarker_buffer (readcharfun
));
171 if (EQ (readcharfun
, Qget_file_char
))
175 /* Interrupted reads have been observed while reading over the network */
176 while (c
== EOF
&& ferror (instream
) && errno
== EINTR
)
185 if (STRINGP (readcharfun
))
188 /* This used to be return of a conditional expression,
189 but that truncated -1 to a char on VMS. */
190 if (read_from_string_index
< read_from_string_limit
)
191 c
= XSTRING (readcharfun
)->data
[read_from_string_index
++];
197 tem
= call0 (readcharfun
);
204 /* Unread the character C in the way appropriate for the stream READCHARFUN.
205 If the stream is a user function, call it with the char as argument. */
208 unreadchar (readcharfun
, c
)
209 Lisp_Object readcharfun
;
213 /* Don't back up the pointer if we're unreading the end-of-input mark,
214 since readchar didn't advance it when we read it. */
216 else if (BUFFERP (readcharfun
))
218 if (XBUFFER (readcharfun
) == current_buffer
)
221 SET_BUF_PT (XBUFFER (readcharfun
), BUF_PT (XBUFFER (readcharfun
)) - 1);
223 else if (MARKERP (readcharfun
))
224 XMARKER (readcharfun
)->bufpos
--;
225 else if (STRINGP (readcharfun
))
226 read_from_string_index
--;
227 else if (EQ (readcharfun
, Qget_file_char
))
228 ungetc (c
, instream
);
230 call1 (readcharfun
, make_number (c
));
233 static Lisp_Object
read0 (), read1 (), read_list (), read_vector ();
235 /* get a character from the tty */
237 extern Lisp_Object
read_char ();
239 /* Read input events until we get one that's acceptable for our purposes.
241 If NO_SWITCH_FRAME is non-zero, switch-frame events are stashed
242 until we get a character we like, and then stuffed into
245 If ASCII_REQUIRED is non-zero, we check function key events to see
246 if the unmodified version of the symbol has a Qascii_character
247 property, and use that character, if present.
249 If ERROR_NONASCII is non-zero, we signal an error if the input we
250 get isn't an ASCII character with modifiers. If it's zero but
251 ASCII_REQUIRED is non-zero, we just re-read until we get an ASCII
255 read_filtered_event (no_switch_frame
, ascii_required
, error_nonascii
)
256 int no_switch_frame
, ascii_required
, error_nonascii
;
259 return make_number (getchar ());
261 register Lisp_Object val
, delayed_switch_frame
;
263 delayed_switch_frame
= Qnil
;
265 /* Read until we get an acceptable event. */
267 val
= read_char (0, 0, 0, Qnil
, 0);
272 /* switch-frame events are put off until after the next ASCII
273 character. This is better than signaling an error just because
274 the last characters were typed to a separate minibuffer frame,
275 for example. Eventually, some code which can deal with
276 switch-frame events will read it and process it. */
278 && EVENT_HAS_PARAMETERS (val
)
279 && EQ (EVENT_HEAD (val
), Qswitch_frame
))
281 delayed_switch_frame
= val
;
287 /* Convert certain symbols to their ASCII equivalents. */
290 Lisp_Object tem
, tem1
, tem2
;
291 tem
= Fget (val
, Qevent_symbol_element_mask
);
294 tem1
= Fget (Fcar (tem
), Qascii_character
);
295 /* Merge this symbol's modifier bits
296 with the ASCII equivalent of its basic code. */
298 XSETFASTINT (val
, XINT (tem1
) | XINT (Fcar (Fcdr (tem
))));
302 /* If we don't have a character now, deal with it appropriately. */
307 Vunread_command_events
= Fcons (val
, Qnil
);
308 error ("Non-character input-event");
315 if (! NILP (delayed_switch_frame
))
316 unread_switch_frame
= delayed_switch_frame
;
322 DEFUN ("read-char", Fread_char
, Sread_char
, 0, 0, 0,
323 "Read a character from the command input (keyboard or macro).\n\
324 It is returned as a number.\n\
325 If the user generates an event which is not a character (i.e. a mouse\n\
326 click or function key event), `read-char' signals an error. As an\n\
327 exception, switch-frame events are put off until non-ASCII events can\n\
329 If you want to read non-character events, or ignore them, call\n\
330 `read-event' or `read-char-exclusive' instead.")
333 return read_filtered_event (1, 1, 1);
336 DEFUN ("read-event", Fread_event
, Sread_event
, 0, 0, 0,
337 "Read an event object from the input stream.")
340 return read_filtered_event (0, 0, 0);
343 DEFUN ("read-char-exclusive", Fread_char_exclusive
, Sread_char_exclusive
, 0, 0, 0,
344 "Read a character from the command input (keyboard or macro).\n\
345 It is returned as a number. Non-character events are ignored.")
348 return read_filtered_event (1, 1, 0);
351 DEFUN ("get-file-char", Fget_file_char
, Sget_file_char
, 0, 0, 0,
352 "Don't use this yourself.")
355 register Lisp_Object val
;
356 XSETINT (val
, getc (instream
));
360 static void readevalloop ();
361 static Lisp_Object
load_unwind ();
362 static Lisp_Object
load_descriptor_unwind ();
364 DEFUN ("load", Fload
, Sload
, 1, 4, 0,
365 "Execute a file of Lisp code named FILE.\n\
366 First try FILE with `.elc' appended, then try with `.el',\n\
367 then try FILE unmodified.\n\
368 This function searches the directories in `load-path'.\n\
369 If optional second arg NOERROR is non-nil,\n\
370 report no error if FILE doesn't exist.\n\
371 Print messages at start and end of loading unless\n\
372 optional third arg NOMESSAGE is non-nil.\n\
373 If optional fourth arg NOSUFFIX is non-nil, don't try adding\n\
374 suffixes `.elc' or `.el' to the specified name FILE.\n\
375 Return t if file exists.")
376 (file
, noerror
, nomessage
, nosuffix
)
377 Lisp_Object file
, noerror
, nomessage
, nosuffix
;
379 register FILE *stream
;
380 register int fd
= -1;
381 register Lisp_Object lispstream
;
382 int count
= specpdl_ptr
- specpdl
;
386 /* 1 means inhibit the message at the beginning. */
390 char *dosmode
= "rt";
393 CHECK_STRING (file
, 0);
395 /* If file name is magic, call the handler. */
396 handler
= Ffind_file_name_handler (file
, Qload
);
398 return call5 (handler
, Qload
, file
, noerror
, nomessage
, nosuffix
);
400 /* Do this after the handler to avoid
401 the need to gcpro noerror, nomessage and nosuffix.
402 (Below here, we care only whether they are nil or not.) */
403 file
= Fsubstitute_in_file_name (file
);
405 /* Avoid weird lossage with null string as arg,
406 since it would try to load a directory as a Lisp file */
407 if (XSTRING (file
)->size
> 0)
410 fd
= openp (Vload_path
, file
, !NILP (nosuffix
) ? "" : ".elc:.el:",
419 Fsignal (Qfile_error
, Fcons (build_string ("Cannot open load file"),
420 Fcons (file
, Qnil
)));
425 if (!bcmp (&(XSTRING (found
)->data
[XSTRING (found
)->size
- 4]),
434 stat ((char *)XSTRING (found
)->data
, &s1
);
435 XSTRING (found
)->data
[XSTRING (found
)->size
- 1] = 0;
436 result
= stat ((char *)XSTRING (found
)->data
, &s2
);
437 if (result
>= 0 && (unsigned) s1
.st_mtime
< (unsigned) s2
.st_mtime
)
439 message ("Source file `%s' newer than byte-compiled file",
440 XSTRING (found
)->data
);
441 /* Don't immediately overwrite this message. */
445 XSTRING (found
)->data
[XSTRING (found
)->size
- 1] = 'c';
450 stream
= fopen ((char *) XSTRING (found
)->data
, dosmode
);
451 #else /* not DOS_NT */
452 stream
= fdopen (fd
, "r");
453 #endif /* not DOS_NT */
457 error ("Failure to create stdio stream for %s", XSTRING (file
)->data
);
460 if (NILP (nomessage
) && !nomessage1
)
461 message ("Loading %s...", XSTRING (file
)->data
);
464 lispstream
= Fcons (Qnil
, Qnil
);
465 XSETFASTINT (XCONS (lispstream
)->car
, (EMACS_UINT
)stream
>> 16);
466 XSETFASTINT (XCONS (lispstream
)->cdr
, (EMACS_UINT
)stream
& 0xffff);
467 record_unwind_protect (load_unwind
, lispstream
);
468 record_unwind_protect (load_descriptor_unwind
, load_descriptor_list
);
469 specbind (Qload_file_name
, found
);
471 = Fcons (make_number (fileno (stream
)), load_descriptor_list
);
473 readevalloop (Qget_file_char
, stream
, file
, Feval
, 0);
474 unbind_to (count
, Qnil
);
476 /* Run any load-hooks for this file. */
477 temp
= Fassoc (file
, Vafter_load_alist
);
479 Fprogn (Fcdr (temp
));
482 if (saved_doc_string
)
483 free (saved_doc_string
);
484 saved_doc_string
= 0;
485 saved_doc_string_size
= 0;
487 if (!noninteractive
&& NILP (nomessage
))
488 message ("Loading %s...done", XSTRING (file
)->data
);
493 load_unwind (stream
) /* used as unwind-protect function in load */
496 fclose ((FILE *) (XFASTINT (XCONS (stream
)->car
) << 16
497 | XFASTINT (XCONS (stream
)->cdr
)));
498 if (--load_in_progress
< 0) load_in_progress
= 0;
503 load_descriptor_unwind (oldlist
)
506 load_descriptor_list
= oldlist
;
510 /* Close all descriptors in use for Floads.
511 This is used when starting a subprocess. */
517 for (tail
= load_descriptor_list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
518 close (XFASTINT (XCONS (tail
)->car
));
522 complete_filename_p (pathname
)
523 Lisp_Object pathname
;
525 register unsigned char *s
= XSTRING (pathname
)->data
;
526 return (IS_DIRECTORY_SEP (s
[0])
527 || (XSTRING (pathname
)->size
> 2
528 && IS_DEVICE_SEP (s
[1]) && IS_DIRECTORY_SEP (s
[2]))
538 /* Search for a file whose name is STR, looking in directories
539 in the Lisp list PATH, and trying suffixes from SUFFIX.
540 SUFFIX is a string containing possible suffixes separated by colons.
541 On success, returns a file descriptor. On failure, returns -1.
543 EXEC_ONLY nonzero means don't open the files,
544 just look for one that is executable. In this case,
545 returns 1 on success.
547 If STOREPTR is nonzero, it points to a slot where the name of
548 the file actually found should be stored as a Lisp string.
549 Nil is stored there on failure. */
552 openp (path
, str
, suffix
, storeptr
, exec_only
)
553 Lisp_Object path
, str
;
555 Lisp_Object
*storeptr
;
561 register char *fn
= buf
;
564 register Lisp_Object filename
;
572 if (complete_filename_p (str
))
575 for (; !NILP (path
); path
= Fcdr (path
))
579 filename
= Fexpand_file_name (str
, Fcar (path
));
580 if (!complete_filename_p (filename
))
581 /* If there are non-absolute elts in PATH (eg ".") */
582 /* Of course, this could conceivably lose if luser sets
583 default-directory to be something non-absolute... */
585 filename
= Fexpand_file_name (filename
, current_buffer
->directory
);
586 if (!complete_filename_p (filename
))
587 /* Give up on this path element! */
591 /* Calculate maximum size of any filename made from
592 this path element/specified file name and any possible suffix. */
593 want_size
= strlen (suffix
) + XSTRING (filename
)->size
+ 1;
594 if (fn_size
< want_size
)
595 fn
= (char *) alloca (fn_size
= 100 + want_size
);
599 /* Loop over suffixes. */
602 char *esuffix
= (char *) index (nsuffix
, ':');
603 int lsuffix
= esuffix
? esuffix
- nsuffix
: strlen (nsuffix
);
605 /* Concatenate path element/specified name with the suffix. */
606 strncpy (fn
, XSTRING (filename
)->data
, XSTRING (filename
)->size
);
607 fn
[XSTRING (filename
)->size
] = 0;
608 if (lsuffix
!= 0) /* Bug happens on CCI if lsuffix is 0. */
609 strncat (fn
, nsuffix
, lsuffix
);
611 /* Ignore file if it's a directory. */
612 if (stat (fn
, &st
) >= 0
613 && (st
.st_mode
& S_IFMT
) != S_IFDIR
)
615 /* Check that we can access or open it. */
617 fd
= (access (fn
, X_OK
) == 0) ? 1 : -1;
619 fd
= open (fn
, O_RDONLY
, 0);
623 /* We succeeded; return this descriptor and filename. */
625 *storeptr
= build_string (fn
);
631 /* Advance to next suffix. */
634 nsuffix
+= lsuffix
+ 1;
645 /* Merge the list we've accumulated of globals from the current input source
646 into the load_history variable. The details depend on whether
647 the source has an associated file name or not. */
650 build_load_history (stream
, source
)
654 register Lisp_Object tail
, prev
, newelt
;
655 register Lisp_Object tem
, tem2
;
656 register int foundit
, loading
;
658 /* Don't bother recording anything for preloaded files. */
659 if (!NILP (Vpurify_flag
))
662 loading
= stream
|| !NARROWED
;
664 tail
= Vload_history
;
671 /* Find the feature's previous assoc list... */
672 if (!NILP (Fequal (source
, Fcar (tem
))))
676 /* If we're loading, remove it. */
680 Vload_history
= Fcdr (tail
);
682 Fsetcdr (prev
, Fcdr (tail
));
685 /* Otherwise, cons on new symbols that are not already members. */
688 tem2
= Vcurrent_load_list
;
692 newelt
= Fcar (tem2
);
694 if (NILP (Fmemq (newelt
, tem
)))
695 Fsetcar (tail
, Fcons (Fcar (tem
),
696 Fcons (newelt
, Fcdr (tem
))));
709 /* If we're loading, cons the new assoc onto the front of load-history,
710 the most-recently-loaded position. Also do this if we didn't find
711 an existing member for the current source. */
712 if (loading
|| !foundit
)
713 Vload_history
= Fcons (Fnreverse (Vcurrent_load_list
),
718 unreadpure () /* Used as unwind-protect function in readevalloop */
725 readevalloop (readcharfun
, stream
, sourcename
, evalfun
, printflag
)
726 Lisp_Object readcharfun
;
728 Lisp_Object sourcename
;
729 Lisp_Object (*evalfun
) ();
733 register Lisp_Object val
;
734 int count
= specpdl_ptr
- specpdl
;
736 struct buffer
*b
= 0;
738 if (BUFFERP (readcharfun
))
739 b
= XBUFFER (readcharfun
);
740 else if (MARKERP (readcharfun
))
741 b
= XMARKER (readcharfun
)->buffer
;
743 specbind (Qstandard_input
, readcharfun
);
744 specbind (Qcurrent_load_list
, Qnil
);
748 LOADHIST_ATTACH (sourcename
);
752 if (b
!= 0 && NILP (b
->name
))
753 error ("Reading from killed buffer");
759 while ((c
= READCHAR
) != '\n' && c
!= -1);
764 /* Ignore whitespace here, so we can detect eof. */
765 if (c
== ' ' || c
== '\t' || c
== '\n' || c
== '\f' || c
== '\r')
768 if (!NILP (Vpurify_flag
) && c
== '(')
770 int count1
= specpdl_ptr
- specpdl
;
771 record_unwind_protect (unreadpure
, Qnil
);
772 val
= read_list (-1, readcharfun
);
773 unbind_to (count1
, Qnil
);
778 if (NILP (Vload_read_function
))
779 val
= read0 (readcharfun
);
781 val
= call1 (Vload_read_function
, readcharfun
);
784 val
= (*evalfun
) (val
);
787 Vvalues
= Fcons (val
, Vvalues
);
788 if (EQ (Vstandard_output
, Qt
))
795 build_load_history (stream
, sourcename
);
798 unbind_to (count
, Qnil
);
803 DEFUN ("eval-buffer", Feval_buffer
, Seval_buffer
, 0, 2, "",
804 "Execute the current buffer as Lisp code.\n\
805 Programs can pass two arguments, BUFFER and PRINTFLAG.\n\
806 BUFFER is the buffer to evaluate (nil means use current buffer).\n\
807 PRINTFLAG controls printing of output:\n\
808 nil means discard it; anything else is stream for print.\n\
810 If there is no error, point does not move. If there is an error,\n\
811 point remains at the end of the last character read from the buffer.")
813 Lisp_Object buffer
, printflag
;
815 int count
= specpdl_ptr
- specpdl
;
816 Lisp_Object tem
, buf
;
819 buf
= Fcurrent_buffer ();
821 buf
= Fget_buffer (buffer
);
823 error ("No such buffer.");
825 if (NILP (printflag
))
829 specbind (Qstandard_output
, tem
);
830 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
831 BUF_SET_PT (XBUFFER (buf
), BUF_BEGV (XBUFFER (buf
)));
832 readevalloop (buf
, 0, XBUFFER (buf
)->filename
, Feval
, !NILP (printflag
));
833 unbind_to (count
, Qnil
);
839 DEFUN ("eval-current-buffer", Feval_current_buffer
, Seval_current_buffer
, 0, 1, "",
840 "Execute the current buffer as Lisp code.\n\
841 Programs can pass argument PRINTFLAG which controls printing of output:\n\
842 nil means discard it; anything else is stream for print.\n\
844 If there is no error, point does not move. If there is an error,\n\
845 point remains at the end of the last character read from the buffer.")
847 Lisp_Object printflag
;
849 int count
= specpdl_ptr
- specpdl
;
850 Lisp_Object tem
, cbuf
;
852 cbuf
= Fcurrent_buffer ()
854 if (NILP (printflag
))
858 specbind (Qstandard_output
, tem
);
859 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
861 readevalloop (cbuf
, 0, XBUFFER (cbuf
)->filename
, Feval
, !NILP (printflag
));
862 return unbind_to (count
, Qnil
);
866 DEFUN ("eval-region", Feval_region
, Seval_region
, 2, 3, "r",
867 "Execute the region as Lisp code.\n\
868 When called from programs, expects two arguments,\n\
869 giving starting and ending indices in the current buffer\n\
870 of the text to be executed.\n\
871 Programs can pass third argument PRINTFLAG which controls output:\n\
872 nil means discard it; anything else is stream for printing it.\n\
874 If there is no error, point does not move. If there is an error,\n\
875 point remains at the end of the last character read from the buffer.")
876 (start
, end
, printflag
)
877 Lisp_Object start
, end
, printflag
;
879 int count
= specpdl_ptr
- specpdl
;
880 Lisp_Object tem
, cbuf
;
882 cbuf
= Fcurrent_buffer ();
884 if (NILP (printflag
))
888 specbind (Qstandard_output
, tem
);
890 if (NILP (printflag
))
891 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
892 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
894 /* This both uses start and checks its type. */
896 Fnarrow_to_region (make_number (BEGV
), end
);
897 readevalloop (cbuf
, 0, XBUFFER (cbuf
)->filename
, Feval
, !NILP (printflag
));
899 return unbind_to (count
, Qnil
);
902 #endif /* standalone */
904 DEFUN ("read", Fread
, Sread
, 0, 1, 0,
905 "Read one Lisp expression as text from STREAM, return as Lisp object.\n\
906 If STREAM is nil, use the value of `standard-input' (which see).\n\
907 STREAM or the value of `standard-input' may be:\n\
908 a buffer (read from point and advance it)\n\
909 a marker (read from where it points and advance it)\n\
910 a function (call it with no arguments for each character,\n\
911 call it with a char as argument to push a char back)\n\
912 a string (takes text from string, starting at the beginning)\n\
913 t (read text line using minibuffer and use it).")
917 extern Lisp_Object
Fread_minibuffer ();
920 stream
= Vstandard_input
;
924 new_backquote_flag
= 0;
927 if (EQ (stream
, Qread_char
))
928 return Fread_minibuffer (build_string ("Lisp expression: "), Qnil
);
931 if (STRINGP (stream
))
932 return Fcar (Fread_from_string (stream
, Qnil
, Qnil
));
934 return read0 (stream
);
937 DEFUN ("read-from-string", Fread_from_string
, Sread_from_string
, 1, 3, 0,
938 "Read one Lisp expression which is represented as text by STRING.\n\
939 Returns a cons: (OBJECT-READ . FINAL-STRING-INDEX).\n\
940 START and END optionally delimit a substring of STRING from which to read;\n\
941 they default to 0 and (length STRING) respectively.")
943 Lisp_Object string
, start
, end
;
945 int startval
, endval
;
948 CHECK_STRING (string
,0);
951 endval
= XSTRING (string
)->size
;
953 { CHECK_NUMBER (end
,2);
955 if (endval
< 0 || endval
> XSTRING (string
)->size
)
956 args_out_of_range (string
, end
);
962 { CHECK_NUMBER (start
,1);
963 startval
= XINT (start
);
964 if (startval
< 0 || startval
> endval
)
965 args_out_of_range (string
, start
);
968 read_from_string_index
= startval
;
969 read_from_string_limit
= endval
;
971 new_backquote_flag
= 0;
973 tem
= read0 (string
);
974 return Fcons (tem
, make_number (read_from_string_index
));
977 /* Use this for recursive reads, in contexts where internal tokens
981 Lisp_Object readcharfun
;
983 register Lisp_Object val
;
986 val
= read1 (readcharfun
, &c
, 0);
988 Fsignal (Qinvalid_read_syntax
, Fcons (make_string (&c
, 1), Qnil
));
993 static int read_buffer_size
;
994 static char *read_buffer
;
997 read_escape (readcharfun
)
998 Lisp_Object readcharfun
;
1000 register int c
= READCHAR
;
1027 error ("Invalid escape character syntax");
1030 c
= read_escape (readcharfun
);
1031 return c
| meta_modifier
;
1036 error ("Invalid escape character syntax");
1039 c
= read_escape (readcharfun
);
1040 return c
| shift_modifier
;
1045 error ("Invalid escape character syntax");
1048 c
= read_escape (readcharfun
);
1049 return c
| hyper_modifier
;
1054 error ("Invalid escape character syntax");
1057 c
= read_escape (readcharfun
);
1058 return c
| alt_modifier
;
1063 error ("Invalid escape character syntax");
1066 c
= read_escape (readcharfun
);
1067 return c
| super_modifier
;
1072 error ("Invalid escape character syntax");
1076 c
= read_escape (readcharfun
);
1077 if ((c
& 0177) == '?')
1079 /* ASCII control chars are made from letters (both cases),
1080 as well as the non-letters within 0100...0137. */
1081 else if ((c
& 0137) >= 0101 && (c
& 0137) <= 0132)
1082 return (c
& (037 | ~0177));
1083 else if ((c
& 0177) >= 0100 && (c
& 0177) <= 0137)
1084 return (c
& (037 | ~0177));
1086 return c
| ctrl_modifier
;
1096 /* An octal escape, as in ANSI C. */
1098 register int i
= c
- '0';
1099 register int count
= 0;
1102 if ((c
= READCHAR
) >= '0' && c
<= '7')
1117 /* A hex escape, as in ANSI C. */
1123 if (c
>= '0' && c
<= '9')
1128 else if ((c
>= 'a' && c
<= 'f')
1129 || (c
>= 'A' && c
<= 'F'))
1132 if (c
>= 'a' && c
<= 'f')
1151 /* If the next token is ')' or ']' or '.', we store that character
1152 in *PCH and the return value is not interesting. Else, we store
1153 zero in *PCH and we read and return one lisp object.
1155 FIRST_IN_LIST is nonzero if this is the first element of a list. */
1158 read1 (readcharfun
, pch
, first_in_list
)
1159 register Lisp_Object readcharfun
;
1169 if (c
< 0) return Fsignal (Qend_of_file
, Qnil
);
1174 return read_list (0, readcharfun
);
1177 return read_vector (readcharfun
);
1194 tmp
= read_vector (readcharfun
);
1195 if (XVECTOR (tmp
)->size
< CHAR_TABLE_STANDARD_SLOTS
1196 || XVECTOR (tmp
)->size
> CHAR_TABLE_STANDARD_SLOTS
+ 10)
1197 error ("Invalid size char-table");
1198 XSETCHAR_TABLE (tmp
, XCHAR_TABLE (tmp
));
1201 Fsignal (Qinvalid_read_syntax
, Fcons (make_string ("#^", 2), Qnil
));
1206 length
= read1 (readcharfun
, pch
, first_in_list
);
1210 Lisp_Object tmp
, val
;
1211 int size_in_chars
= ((XFASTINT (length
) + BITS_PER_CHAR
)
1215 tmp
= read1 (readcharfun
, pch
, first_in_list
);
1216 if (size_in_chars
!= XSTRING (tmp
)->size
)
1217 Fsignal (Qinvalid_read_syntax
,
1218 Fcons (make_string ("#&", 2), Qnil
));
1220 val
= Fmake_bool_vector (length
, Qnil
);
1221 bcopy (XSTRING (tmp
)->data
, XBOOL_VECTOR (val
)->data
,
1225 Fsignal (Qinvalid_read_syntax
, Fcons (make_string ("#&", 2), Qnil
));
1229 /* Accept compiled functions at read-time so that we don't have to
1230 build them using function calls. */
1232 tmp
= read_vector (readcharfun
);
1233 return Fmake_byte_code (XVECTOR (tmp
)->size
,
1234 XVECTOR (tmp
)->contents
);
1236 #ifdef USE_TEXT_PROPERTIES
1240 struct gcpro gcpro1
;
1243 /* Read the string itself. */
1244 tmp
= read1 (readcharfun
, &ch
, 0);
1245 if (ch
!= 0 || !STRINGP (tmp
))
1246 Fsignal (Qinvalid_read_syntax
, Fcons (make_string ("#", 1), Qnil
));
1248 /* Read the intervals and their properties. */
1251 Lisp_Object beg
, end
, plist
;
1253 beg
= read1 (readcharfun
, &ch
, 0);
1257 end
= read1 (readcharfun
, &ch
, 0);
1259 plist
= read1 (readcharfun
, &ch
, 0);
1261 Fsignal (Qinvalid_read_syntax
,
1262 Fcons (build_string ("invalid string property list"),
1264 Fset_text_properties (beg
, end
, plist
, tmp
);
1270 /* #@NUMBER is used to skip NUMBER following characters.
1271 That's used in .elc files to skip over doc strings
1272 and function definitions. */
1277 /* Read a decimal integer. */
1278 while ((c
= READCHAR
) >= 0
1279 && c
>= '0' && c
<= '9')
1287 #ifndef DOS_NT /* I don't know if filepos works right on MSDOS and Windoze. */
1288 if (load_force_doc_strings
&& EQ (readcharfun
, Qget_file_char
))
1290 /* If we are supposed to force doc strings into core right now,
1291 record the last string that we skipped,
1292 and record where in the file it comes from. */
1293 if (saved_doc_string_size
== 0)
1295 saved_doc_string_size
= nskip
+ 100;
1296 saved_doc_string
= (char *) xmalloc (saved_doc_string_size
);
1298 if (nskip
> saved_doc_string_size
)
1300 saved_doc_string_size
= nskip
+ 100;
1301 saved_doc_string
= (char *) xrealloc (saved_doc_string
,
1302 saved_doc_string_size
);
1305 saved_doc_string_position
= ftell (instream
);
1307 /* Copy that many characters into saved_doc_string. */
1308 for (i
= 0; i
< nskip
&& c
>= 0; i
++)
1309 saved_doc_string
[i
] = c
= READCHAR
;
1311 saved_doc_string_length
= i
;
1314 #endif /* not DOS_NT */
1316 /* Skip that many characters. */
1317 for (i
= 0; i
< nskip
&& c
>= 0; i
++)
1323 return Vload_file_name
;
1325 return Fcons (Qfunction
, Fcons (read0 (readcharfun
), Qnil
));
1329 Fsignal (Qinvalid_read_syntax
, Fcons (make_string ("#", 1), Qnil
));
1332 while ((c
= READCHAR
) >= 0 && c
!= '\n');
1337 return Fcons (Qquote
, Fcons (read0 (readcharfun
), Qnil
));
1347 new_backquote_flag
= 1;
1348 value
= read0 (readcharfun
);
1349 new_backquote_flag
= 0;
1351 return Fcons (Qbackquote
, Fcons (value
, Qnil
));
1355 if (new_backquote_flag
)
1357 Lisp_Object comma_type
= Qnil
;
1362 comma_type
= Qcomma_at
;
1364 comma_type
= Qcomma_dot
;
1367 if (ch
>= 0) UNREAD (ch
);
1368 comma_type
= Qcomma
;
1371 new_backquote_flag
= 0;
1372 value
= read0 (readcharfun
);
1373 new_backquote_flag
= 1;
1374 return Fcons (comma_type
, Fcons (value
, Qnil
));
1381 register Lisp_Object val
;
1384 if (c
< 0) return Fsignal (Qend_of_file
, Qnil
);
1387 XSETINT (val
, read_escape (readcharfun
));
1396 register char *p
= read_buffer
;
1397 register char *end
= read_buffer
+ read_buffer_size
;
1401 while ((c
= READCHAR
) >= 0
1406 char *new = (char *) xrealloc (read_buffer
, read_buffer_size
*= 2);
1407 p
+= new - read_buffer
;
1408 read_buffer
+= new - read_buffer
;
1409 end
= read_buffer
+ read_buffer_size
;
1412 c
= read_escape (readcharfun
);
1413 /* c is -1 if \ newline has just been seen */
1416 if (p
== read_buffer
)
1421 /* Allow `\C- ' and `\C-?'. */
1422 if (c
== (CHAR_CTL
| ' '))
1424 else if (c
== (CHAR_CTL
| '?'))
1428 /* Move the meta bit to the right place for a string. */
1429 c
= (c
& ~CHAR_META
) | 0x80;
1431 error ("Invalid modifier in string");
1435 if (c
< 0) return Fsignal (Qend_of_file
, Qnil
);
1437 /* If purifying, and string starts with \ newline,
1438 return zero instead. This is for doc strings
1439 that we are really going to find in etc/DOC.nn.nn */
1440 if (!NILP (Vpurify_flag
) && NILP (Vdoc_file_name
) && cancel
)
1441 return make_number (0);
1444 return make_pure_string (read_buffer
, p
- read_buffer
);
1446 return make_string (read_buffer
, p
- read_buffer
);
1451 #ifdef LISP_FLOAT_TYPE
1452 /* If a period is followed by a number, then we should read it
1453 as a floating point number. Otherwise, it denotes a dotted
1455 int next_char
= READCHAR
;
1458 if (! (next_char
>= '0' && next_char
<= '9'))
1465 /* Otherwise, we fall through! Note that the atom-reading loop
1466 below will now loop at least once, assuring that we will not
1467 try to UNREAD two characters in a row. */
1471 if (c
<= 040) goto retry
;
1473 register char *p
= read_buffer
;
1477 register char *end
= read_buffer
+ read_buffer_size
;
1480 !(c
== '\"' || c
== '\'' || c
== ';' || c
== '?'
1481 || c
== '(' || c
== ')'
1482 #ifndef LISP_FLOAT_TYPE
1483 /* If we have floating-point support, then we need
1484 to allow <digits><dot><digits>. */
1486 #endif /* not LISP_FLOAT_TYPE */
1487 || c
== '[' || c
== ']' || c
== '#'
1492 register char *new = (char *) xrealloc (read_buffer
, read_buffer_size
*= 2);
1493 p
+= new - read_buffer
;
1494 read_buffer
+= new - read_buffer
;
1495 end
= read_buffer
+ read_buffer_size
;
1508 char *new = (char *) xrealloc (read_buffer
, read_buffer_size
*= 2);
1509 p
+= new - read_buffer
;
1510 read_buffer
+= new - read_buffer
;
1511 /* end = read_buffer + read_buffer_size; */
1521 register Lisp_Object val
;
1523 if (*p1
== '+' || *p1
== '-') p1
++;
1524 /* Is it an integer? */
1527 while (p1
!= p
&& (c
= *p1
) >= '0' && c
<= '9') p1
++;
1528 #ifdef LISP_FLOAT_TYPE
1529 /* Integers can have trailing decimal points. */
1530 if (p1
> read_buffer
&& p1
< p
&& *p1
== '.') p1
++;
1533 /* It is an integer. */
1535 #ifdef LISP_FLOAT_TYPE
1539 if (sizeof (int) == sizeof (EMACS_INT
))
1540 XSETINT (val
, atoi (read_buffer
));
1541 else if (sizeof (long) == sizeof (EMACS_INT
))
1542 XSETINT (val
, atol (read_buffer
));
1548 #ifdef LISP_FLOAT_TYPE
1549 if (isfloat_string (read_buffer
))
1550 return make_float (atof (read_buffer
));
1554 return intern (read_buffer
);
1559 #ifdef LISP_FLOAT_TYPE
1574 if (*cp
== '+' || *cp
== '-')
1577 if (*cp
>= '0' && *cp
<= '9')
1580 while (*cp
>= '0' && *cp
<= '9')
1588 if (*cp
>= '0' && *cp
<= '9')
1591 while (*cp
>= '0' && *cp
<= '9')
1598 if (*cp
== '+' || *cp
== '-')
1602 if (*cp
>= '0' && *cp
<= '9')
1605 while (*cp
>= '0' && *cp
<= '9')
1608 return (((*cp
== 0) || (*cp
== ' ') || (*cp
== '\t') || (*cp
== '\n') || (*cp
== '\r') || (*cp
== '\f'))
1609 && (state
== (LEAD_INT
|DOT_CHAR
|TRAIL_INT
)
1610 || state
== (DOT_CHAR
|TRAIL_INT
)
1611 || state
== (LEAD_INT
|E_CHAR
|EXP_INT
)
1612 || state
== (LEAD_INT
|DOT_CHAR
|TRAIL_INT
|E_CHAR
|EXP_INT
)
1613 || state
== (DOT_CHAR
|TRAIL_INT
|E_CHAR
|EXP_INT
)));
1615 #endif /* LISP_FLOAT_TYPE */
1618 read_vector (readcharfun
)
1619 Lisp_Object readcharfun
;
1623 register Lisp_Object
*ptr
;
1624 register Lisp_Object tem
, vector
;
1625 register struct Lisp_Cons
*otem
;
1628 tem
= read_list (1, readcharfun
);
1629 len
= Flength (tem
);
1630 vector
= (read_pure
? make_pure_vector (XINT (len
)) : Fmake_vector (len
, Qnil
));
1633 size
= XVECTOR (vector
)->size
;
1634 ptr
= XVECTOR (vector
)->contents
;
1635 for (i
= 0; i
< size
; i
++)
1637 ptr
[i
] = read_pure
? Fpurecopy (Fcar (tem
)) : Fcar (tem
);
1645 /* flag = 1 means check for ] to terminate rather than ) and .
1646 flag = -1 means check for starting with defun
1647 and make structure pure. */
1650 read_list (flag
, readcharfun
)
1652 register Lisp_Object readcharfun
;
1654 /* -1 means check next element for defun,
1655 0 means don't check,
1656 1 means already checked and found defun. */
1657 int defunflag
= flag
< 0 ? -1 : 0;
1658 Lisp_Object val
, tail
;
1659 register Lisp_Object elt
, tem
;
1660 struct gcpro gcpro1
, gcpro2
;
1661 /* 0 is the normal case.
1662 1 means this list is a doc reference; replace it with the number 0.
1663 2 means this list is a doc reference; replace it with the doc string. */
1664 int doc_reference
= 0;
1666 /* Initialize this to 1 if we are reading a list. */
1667 int first_in_list
= flag
<= 0;
1676 elt
= read1 (readcharfun
, &ch
, first_in_list
);
1681 /* While building, if the list starts with #$, treat it specially. */
1682 if (EQ (elt
, Vload_file_name
)
1683 && !NILP (Vpurify_flag
))
1685 if (NILP (Vdoc_file_name
))
1686 /* We have not yet called Snarf-documentation, so assume
1687 this file is described in the DOC-MM.NN file
1688 and Snarf-documentation will fill in the right value later.
1689 For now, replace the whole list with 0. */
1692 /* We have already called Snarf-documentation, so make a relative
1693 file name for this file, so it can be found properly
1694 in the installed Lisp directory.
1695 We don't use Fexpand_file_name because that would make
1696 the directory absolute now. */
1697 elt
= concat2 (build_string ("../lisp/"),
1698 Ffile_name_nondirectory (elt
));
1700 else if (EQ (elt
, Vload_file_name
)
1701 && load_force_doc_strings
)
1710 Fsignal (Qinvalid_read_syntax
,
1711 Fcons (make_string (") or . in a vector", 18), Qnil
));
1719 XCONS (tail
)->cdr
= read0 (readcharfun
);
1721 val
= read0 (readcharfun
);
1722 read1 (readcharfun
, &ch
, 0);
1726 if (doc_reference
== 1)
1727 return make_number (0);
1728 if (doc_reference
== 2)
1730 /* Get a doc string from the file we are loading.
1731 If it's in saved_doc_string, get it from there. */
1732 int pos
= XINT (XCONS (val
)->cdr
);
1733 if (pos
>= saved_doc_string_position
1734 && pos
< (saved_doc_string_position
1735 + saved_doc_string_length
))
1737 int start
= pos
- saved_doc_string_position
;
1740 /* Process quoting with ^A,
1741 and find the end of the string,
1742 which is marked with ^_ (037). */
1743 for (from
= start
, to
= start
;
1744 saved_doc_string
[from
] != 037;)
1746 int c
= saved_doc_string
[from
++];
1749 c
= saved_doc_string
[from
++];
1751 saved_doc_string
[to
++] = c
;
1753 saved_doc_string
[to
++] = 0;
1755 saved_doc_string
[to
++] = 037;
1758 saved_doc_string
[to
++] = c
;
1761 return make_string (saved_doc_string
+ start
,
1765 return read_doc_string (val
);
1770 return Fsignal (Qinvalid_read_syntax
, Fcons (make_string (". in wrong context", 18), Qnil
));
1772 return Fsignal (Qinvalid_read_syntax
, Fcons (make_string ("] in a list", 11), Qnil
));
1774 tem
= (read_pure
&& flag
<= 0
1775 ? pure_cons (elt
, Qnil
)
1776 : Fcons (elt
, Qnil
));
1778 XCONS (tail
)->cdr
= tem
;
1783 defunflag
= EQ (elt
, Qdefun
);
1784 else if (defunflag
> 0)
1789 Lisp_Object Vobarray
;
1790 Lisp_Object initial_obarray
;
1792 /* oblookup stores the bucket number here, for the sake of Funintern. */
1794 int oblookup_last_bucket_number
;
1796 static int hash_string ();
1797 Lisp_Object
oblookup ();
1799 /* Get an error if OBARRAY is not an obarray.
1800 If it is one, return it. */
1803 check_obarray (obarray
)
1804 Lisp_Object obarray
;
1806 while (!VECTORP (obarray
) || XVECTOR (obarray
)->size
== 0)
1808 /* If Vobarray is now invalid, force it to be valid. */
1809 if (EQ (Vobarray
, obarray
)) Vobarray
= initial_obarray
;
1811 obarray
= wrong_type_argument (Qvectorp
, obarray
);
1816 /* Intern the C string STR: return a symbol with that name,
1817 interned in the current obarray. */
1824 int len
= strlen (str
);
1825 Lisp_Object obarray
;
1828 if (!VECTORP (obarray
) || XVECTOR (obarray
)->size
== 0)
1829 obarray
= check_obarray (obarray
);
1830 tem
= oblookup (obarray
, str
, len
);
1833 return Fintern ((!NILP (Vpurify_flag
)
1834 ? make_pure_string (str
, len
)
1835 : make_string (str
, len
)),
1839 DEFUN ("intern", Fintern
, Sintern
, 1, 2, 0,
1840 "Return the canonical symbol whose name is STRING.\n\
1841 If there is none, one is created by this function and returned.\n\
1842 A second optional argument specifies the obarray to use;\n\
1843 it defaults to the value of `obarray'.")
1845 Lisp_Object string
, obarray
;
1847 register Lisp_Object tem
, sym
, *ptr
;
1849 if (NILP (obarray
)) obarray
= Vobarray
;
1850 obarray
= check_obarray (obarray
);
1852 CHECK_STRING (string
, 0);
1854 tem
= oblookup (obarray
, XSTRING (string
)->data
, XSTRING (string
)->size
);
1855 if (!INTEGERP (tem
))
1858 if (!NILP (Vpurify_flag
))
1859 string
= Fpurecopy (string
);
1860 sym
= Fmake_symbol (string
);
1862 ptr
= &XVECTOR (obarray
)->contents
[XINT (tem
)];
1864 XSYMBOL (sym
)->next
= XSYMBOL (*ptr
);
1866 XSYMBOL (sym
)->next
= 0;
1871 DEFUN ("intern-soft", Fintern_soft
, Sintern_soft
, 1, 2, 0,
1872 "Return the canonical symbol whose name is STRING, or nil if none exists.\n\
1873 A second optional argument specifies the obarray to use;\n\
1874 it defaults to the value of `obarray'.")
1876 Lisp_Object string
, obarray
;
1878 register Lisp_Object tem
;
1880 if (NILP (obarray
)) obarray
= Vobarray
;
1881 obarray
= check_obarray (obarray
);
1883 CHECK_STRING (string
, 0);
1885 tem
= oblookup (obarray
, XSTRING (string
)->data
, XSTRING (string
)->size
);
1886 if (!INTEGERP (tem
))
1891 DEFUN ("unintern", Funintern
, Sunintern
, 1, 2, 0,
1892 "Delete the symbol named NAME, if any, from OBARRAY.\n\
1893 The value is t if a symbol was found and deleted, nil otherwise.\n\
1894 NAME may be a string or a symbol. If it is a symbol, that symbol\n\
1895 is deleted, if it belongs to OBARRAY--no other symbol is deleted.\n\
1896 OBARRAY defaults to the value of the variable `obarray'.")
1898 Lisp_Object name
, obarray
;
1900 register Lisp_Object string
, tem
;
1903 if (NILP (obarray
)) obarray
= Vobarray
;
1904 obarray
= check_obarray (obarray
);
1907 XSETSTRING (string
, XSYMBOL (name
)->name
);
1910 CHECK_STRING (name
, 0);
1914 tem
= oblookup (obarray
, XSTRING (string
)->data
, XSTRING (string
)->size
);
1917 /* If arg was a symbol, don't delete anything but that symbol itself. */
1918 if (SYMBOLP (name
) && !EQ (name
, tem
))
1921 hash
= oblookup_last_bucket_number
;
1923 if (EQ (XVECTOR (obarray
)->contents
[hash
], tem
))
1925 if (XSYMBOL (tem
)->next
)
1926 XSETSYMBOL (XVECTOR (obarray
)->contents
[hash
], XSYMBOL (tem
)->next
);
1928 XSETINT (XVECTOR (obarray
)->contents
[hash
], 0);
1932 Lisp_Object tail
, following
;
1934 for (tail
= XVECTOR (obarray
)->contents
[hash
];
1935 XSYMBOL (tail
)->next
;
1938 XSETSYMBOL (following
, XSYMBOL (tail
)->next
);
1939 if (EQ (following
, tem
))
1941 XSYMBOL (tail
)->next
= XSYMBOL (following
)->next
;
1950 /* Return the symbol in OBARRAY whose names matches the string
1951 of SIZE characters at PTR. If there is no such symbol in OBARRAY,
1954 Also store the bucket number in oblookup_last_bucket_number. */
1957 oblookup (obarray
, ptr
, size
)
1958 Lisp_Object obarray
;
1964 register Lisp_Object tail
;
1965 Lisp_Object bucket
, tem
;
1967 if (!VECTORP (obarray
)
1968 || (obsize
= XVECTOR (obarray
)->size
) == 0)
1970 obarray
= check_obarray (obarray
);
1971 obsize
= XVECTOR (obarray
)->size
;
1973 /* This is sometimes needed in the middle of GC. */
1974 obsize
&= ~ARRAY_MARK_FLAG
;
1975 /* Combining next two lines breaks VMS C 2.3. */
1976 hash
= hash_string (ptr
, size
);
1978 bucket
= XVECTOR (obarray
)->contents
[hash
];
1979 oblookup_last_bucket_number
= hash
;
1980 if (XFASTINT (bucket
) == 0)
1982 else if (!SYMBOLP (bucket
))
1983 error ("Bad data in guts of obarray"); /* Like CADR error message */
1985 for (tail
= bucket
; ; XSETSYMBOL (tail
, XSYMBOL (tail
)->next
))
1987 if (XSYMBOL (tail
)->name
->size
== size
1988 && !bcmp (XSYMBOL (tail
)->name
->data
, ptr
, size
))
1990 else if (XSYMBOL (tail
)->next
== 0)
1993 XSETINT (tem
, hash
);
1998 hash_string (ptr
, len
)
2002 register unsigned char *p
= ptr
;
2003 register unsigned char *end
= p
+ len
;
2004 register unsigned char c
;
2005 register int hash
= 0;
2010 if (c
>= 0140) c
-= 40;
2011 hash
= ((hash
<<3) + (hash
>>28) + c
);
2013 return hash
& 07777777777;
2017 map_obarray (obarray
, fn
, arg
)
2018 Lisp_Object obarray
;
2023 register Lisp_Object tail
;
2024 CHECK_VECTOR (obarray
, 1);
2025 for (i
= XVECTOR (obarray
)->size
- 1; i
>= 0; i
--)
2027 tail
= XVECTOR (obarray
)->contents
[i
];
2028 if (XFASTINT (tail
) != 0)
2032 if (XSYMBOL (tail
)->next
== 0)
2034 XSETSYMBOL (tail
, XSYMBOL (tail
)->next
);
2039 mapatoms_1 (sym
, function
)
2040 Lisp_Object sym
, function
;
2042 call1 (function
, sym
);
2045 DEFUN ("mapatoms", Fmapatoms
, Smapatoms
, 1, 2, 0,
2046 "Call FUNCTION on every symbol in OBARRAY.\n\
2047 OBARRAY defaults to the value of `obarray'.")
2049 Lisp_Object function
, obarray
;
2053 if (NILP (obarray
)) obarray
= Vobarray
;
2054 obarray
= check_obarray (obarray
);
2056 map_obarray (obarray
, mapatoms_1
, function
);
2060 #define OBARRAY_SIZE 1511
2065 Lisp_Object oblength
;
2069 XSETFASTINT (oblength
, OBARRAY_SIZE
);
2071 Qnil
= Fmake_symbol (make_pure_string ("nil", 3));
2072 Vobarray
= Fmake_vector (oblength
, make_number (0));
2073 initial_obarray
= Vobarray
;
2074 staticpro (&initial_obarray
);
2075 /* Intern nil in the obarray */
2076 /* These locals are to kludge around a pyramid compiler bug. */
2077 hash
= hash_string ("nil", 3);
2078 /* Separate statement here to avoid VAXC bug. */
2079 hash
%= OBARRAY_SIZE
;
2080 tem
= &XVECTOR (Vobarray
)->contents
[hash
];
2083 Qunbound
= Fmake_symbol (make_pure_string ("unbound", 7));
2084 XSYMBOL (Qnil
)->function
= Qunbound
;
2085 XSYMBOL (Qunbound
)->value
= Qunbound
;
2086 XSYMBOL (Qunbound
)->function
= Qunbound
;
2089 XSYMBOL (Qnil
)->value
= Qnil
;
2090 XSYMBOL (Qnil
)->plist
= Qnil
;
2091 XSYMBOL (Qt
)->value
= Qt
;
2093 /* Qt is correct even if CANNOT_DUMP. loadup.el will set to nil at end. */
2096 Qvariable_documentation
= intern ("variable-documentation");
2098 read_buffer_size
= 100;
2099 read_buffer
= (char *) malloc (read_buffer_size
);
2104 struct Lisp_Subr
*sname
;
2107 sym
= intern (sname
->symbol_name
);
2108 XSETSUBR (XSYMBOL (sym
)->function
, sname
);
2111 #ifdef NOTDEF /* use fset in subr.el now */
2113 defalias (sname
, string
)
2114 struct Lisp_Subr
*sname
;
2118 sym
= intern (string
);
2119 XSETSUBR (XSYMBOL (sym
)->function
, sname
);
2123 /* Define an "integer variable"; a symbol whose value is forwarded
2124 to a C variable of type int. Sample call: */
2125 /* DEFVAR_INT ("indent-tabs-mode", &indent_tabs_mode, "Documentation"); */
2127 defvar_int (namestring
, address
)
2131 Lisp_Object sym
, val
;
2132 sym
= intern (namestring
);
2133 val
= allocate_misc ();
2134 XMISCTYPE (val
) = Lisp_Misc_Intfwd
;
2135 XINTFWD (val
)->intvar
= address
;
2136 XSYMBOL (sym
)->value
= val
;
2139 /* Similar but define a variable whose value is T if address contains 1,
2140 NIL if address contains 0 */
2142 defvar_bool (namestring
, address
)
2146 Lisp_Object sym
, val
;
2147 sym
= intern (namestring
);
2148 val
= allocate_misc ();
2149 XMISCTYPE (val
) = Lisp_Misc_Boolfwd
;
2150 XBOOLFWD (val
)->boolvar
= address
;
2151 XSYMBOL (sym
)->value
= val
;
2154 /* Similar but define a variable whose value is the Lisp Object stored
2155 at address. Two versions: with and without gc-marking of the C
2156 variable. The nopro version is used when that variable will be
2157 gc-marked for some other reason, since marking the same slot twice
2158 can cause trouble with strings. */
2160 defvar_lisp_nopro (namestring
, address
)
2162 Lisp_Object
*address
;
2164 Lisp_Object sym
, val
;
2165 sym
= intern (namestring
);
2166 val
= allocate_misc ();
2167 XMISCTYPE (val
) = Lisp_Misc_Objfwd
;
2168 XOBJFWD (val
)->objvar
= address
;
2169 XSYMBOL (sym
)->value
= val
;
2173 defvar_lisp (namestring
, address
)
2175 Lisp_Object
*address
;
2177 defvar_lisp_nopro (namestring
, address
);
2178 staticpro (address
);
2183 /* Similar but define a variable whose value is the Lisp Object stored in
2184 the current buffer. address is the address of the slot in the buffer
2185 that is current now. */
2188 defvar_per_buffer (namestring
, address
, type
, doc
)
2190 Lisp_Object
*address
;
2194 Lisp_Object sym
, val
;
2196 extern struct buffer buffer_local_symbols
;
2198 sym
= intern (namestring
);
2199 val
= allocate_misc ();
2200 offset
= (char *)address
- (char *)current_buffer
;
2202 XMISCTYPE (val
) = Lisp_Misc_Buffer_Objfwd
;
2203 XBUFFER_OBJFWD (val
)->offset
= offset
;
2204 XSYMBOL (sym
)->value
= val
;
2205 *(Lisp_Object
*)(offset
+ (char *)&buffer_local_symbols
) = sym
;
2206 *(Lisp_Object
*)(offset
+ (char *)&buffer_local_types
) = type
;
2207 if (XINT (*(Lisp_Object
*)(offset
+ (char *)&buffer_local_flags
)) == 0)
2208 /* Did a DEFVAR_PER_BUFFER without initializing the corresponding
2209 slot of buffer_local_flags */
2213 #endif /* standalone */
2215 /* Similar but define a variable whose value is the Lisp Object stored
2216 at a particular offset in the current kboard object. */
2219 defvar_kboard (namestring
, offset
)
2223 Lisp_Object sym
, val
;
2224 sym
= intern (namestring
);
2225 val
= allocate_misc ();
2226 XMISCTYPE (val
) = Lisp_Misc_Kboard_Objfwd
;
2227 XKBOARD_OBJFWD (val
)->offset
= offset
;
2228 XSYMBOL (sym
)->value
= val
;
2231 /* Record the value of load-path used at the start of dumping
2232 so we can see if the site changed it later during dumping. */
2233 static Lisp_Object dump_path
;
2238 int turn_off_warning
= 0;
2240 #ifdef HAVE_SETLOCALE
2241 /* Make sure numbers are parsed as we expect. */
2242 setlocale (LC_NUMERIC
, "C");
2243 #endif /* HAVE_SETLOCALE */
2245 /* Compute the default load-path. */
2247 normal
= PATH_LOADSEARCH
;
2248 Vload_path
= decode_env_path (0, normal
);
2250 if (NILP (Vpurify_flag
))
2251 normal
= PATH_LOADSEARCH
;
2253 normal
= PATH_DUMPLOADSEARCH
;
2255 /* In a dumped Emacs, we normally have to reset the value of
2256 Vload_path from PATH_LOADSEARCH, since the value that was dumped
2257 uses ../lisp, instead of the path of the installed elisp
2258 libraries. However, if it appears that Vload_path was changed
2259 from the default before dumping, don't override that value. */
2262 if (! NILP (Fequal (dump_path
, Vload_path
)))
2264 Vload_path
= decode_env_path (0, normal
);
2265 if (!NILP (Vinstallation_directory
))
2267 /* Add to the path the lisp subdir of the
2268 installation dir, if it exists. */
2269 Lisp_Object tem
, tem1
;
2270 tem
= Fexpand_file_name (build_string ("lisp"),
2271 Vinstallation_directory
);
2272 tem1
= Ffile_exists_p (tem
);
2275 if (NILP (Fmember (tem
, Vload_path
)))
2277 turn_off_warning
= 1;
2278 Vload_path
= nconc2 (Vload_path
, Fcons (tem
, Qnil
));
2282 /* That dir doesn't exist, so add the build-time
2283 Lisp dirs instead. */
2284 Vload_path
= nconc2 (Vload_path
, dump_path
);
2286 /* Add site-list under the installation dir, if it exists. */
2287 tem
= Fexpand_file_name (build_string ("site-lisp"),
2288 Vinstallation_directory
);
2289 tem1
= Ffile_exists_p (tem
);
2292 if (NILP (Fmember (tem
, Vload_path
)))
2293 Vload_path
= nconc2 (Vload_path
, Fcons (tem
, Qnil
));
2300 /* ../lisp refers to the build directory.
2301 NORMAL refers to the lisp dir in the source directory. */
2302 Vload_path
= Fcons (build_string ("../lisp"),
2303 decode_env_path (0, normal
));
2304 dump_path
= Vload_path
;
2309 /* When Emacs is invoked over network shares on NT, PATH_LOADSEARCH is
2310 almost never correct, thereby causing a warning to be printed out that
2311 confuses users. Since PATH_LOADSEARCH is always overridden by the
2312 EMACSLOADPATH environment variable below, disable the warning on NT. */
2314 /* Warn if dirs in the *standard* path don't exist. */
2315 if (!turn_off_warning
)
2317 Lisp_Object path_tail
;
2319 for (path_tail
= Vload_path
;
2321 path_tail
= XCONS (path_tail
)->cdr
)
2323 Lisp_Object dirfile
;
2324 dirfile
= Fcar (path_tail
);
2325 if (STRINGP (dirfile
))
2327 dirfile
= Fdirectory_file_name (dirfile
);
2328 if (access (XSTRING (dirfile
)->data
, 0) < 0)
2330 "Warning: Lisp directory `%s' does not exist.\n",
2331 XSTRING (Fcar (path_tail
))->data
);
2335 #endif /* WINDOWSNT */
2337 /* If the EMACSLOADPATH environment variable is set, use its value.
2338 This doesn't apply if we're dumping. */
2340 if (NILP (Vpurify_flag
)
2341 && egetenv ("EMACSLOADPATH"))
2343 Vload_path
= decode_env_path ("EMACSLOADPATH", normal
);
2347 load_in_progress
= 0;
2349 load_descriptor_list
= Qnil
;
2356 defsubr (&Sread_from_string
);
2358 defsubr (&Sintern_soft
);
2359 defsubr (&Sunintern
);
2361 defsubr (&Seval_buffer
);
2362 defsubr (&Seval_region
);
2363 defsubr (&Sread_char
);
2364 defsubr (&Sread_char_exclusive
);
2365 defsubr (&Sread_event
);
2366 defsubr (&Sget_file_char
);
2367 defsubr (&Smapatoms
);
2369 DEFVAR_LISP ("obarray", &Vobarray
,
2370 "Symbol table for use by `intern' and `read'.\n\
2371 It is a vector whose length ought to be prime for best results.\n\
2372 The vector's contents don't make sense if examined from Lisp programs;\n\
2373 to find all the symbols in an obarray, use `mapatoms'.");
2375 DEFVAR_LISP ("values", &Vvalues
,
2376 "List of values of all expressions which were read, evaluated and printed.\n\
2377 Order is reverse chronological.");
2379 DEFVAR_LISP ("standard-input", &Vstandard_input
,
2380 "Stream for read to get input from.\n\
2381 See documentation of `read' for possible values.");
2382 Vstandard_input
= Qt
;
2384 DEFVAR_LISP ("load-path", &Vload_path
,
2385 "*List of directories to search for files to load.\n\
2386 Each element is a string (directory name) or nil (try default directory).\n\
2387 Initialized based on EMACSLOADPATH environment variable, if any,\n\
2388 otherwise to default specified by file `paths.h' when Emacs was built.");
2390 DEFVAR_BOOL ("load-in-progress", &load_in_progress
,
2391 "Non-nil iff inside of `load'.");
2393 DEFVAR_LISP ("after-load-alist", &Vafter_load_alist
,
2394 "An alist of expressions to be evalled when particular files are loaded.\n\
2395 Each element looks like (FILENAME FORMS...).\n\
2396 When `load' is run and the file-name argument is FILENAME,\n\
2397 the FORMS in the corresponding element are executed at the end of loading.\n\n\
2398 FILENAME must match exactly! Normally FILENAME is the name of a library,\n\
2399 with no directory specified, since that is how `load' is normally called.\n\
2400 An error in FORMS does not undo the load,\n\
2401 but does prevent execution of the rest of the FORMS.");
2402 Vafter_load_alist
= Qnil
;
2404 DEFVAR_LISP ("load-history", &Vload_history
,
2405 "Alist mapping source file names to symbols and features.\n\
2406 Each alist element is a list that starts with a file name,\n\
2407 except for one element (optional) that starts with nil and describes\n\
2408 definitions evaluated from buffers not visiting files.\n\
2409 The remaining elements of each list are symbols defined as functions\n\
2410 or variables, and cons cells `(provide . FEATURE)' and `(require . FEATURE)'.");
2411 Vload_history
= Qnil
;
2413 DEFVAR_LISP ("load-file-name", &Vload_file_name
,
2414 "Full name of file being loaded by `load'.");
2415 Vload_file_name
= Qnil
;
2417 DEFVAR_LISP ("current-load-list", &Vcurrent_load_list
,
2418 "Used for internal purposes by `load'.");
2419 Vcurrent_load_list
= Qnil
;
2421 DEFVAR_LISP ("load-read-function", &Vload_read_function
,
2422 "Function used by `load' and `eval-region' for reading expressions.\n\
2423 The default is nil, which means use the function `read'.");
2424 Vload_read_function
= Qnil
;
2426 DEFVAR_BOOL ("load-force-doc-strings", &load_force_doc_strings
,
2427 "Non-nil means `load' should force-load all dynamic doc strings.\n\
2428 This is useful when the file being loaded is a temporary copy.");
2429 load_force_doc_strings
= 0;
2431 DEFVAR_LISP ("source-directory", &Vsource_directory
,
2432 "Directory in which Emacs sources were found when Emacs was built.\n\
2433 You cannot count on them to still be there!");
2435 = Fexpand_file_name (build_string ("../"),
2436 Fcar (decode_env_path (0, PATH_DUMPLOADSEARCH
)));
2438 /* Vsource_directory was initialized in init_lread. */
2440 load_descriptor_list
= Qnil
;
2441 staticpro (&load_descriptor_list
);
2443 Qcurrent_load_list
= intern ("current-load-list");
2444 staticpro (&Qcurrent_load_list
);
2446 Qstandard_input
= intern ("standard-input");
2447 staticpro (&Qstandard_input
);
2449 Qread_char
= intern ("read-char");
2450 staticpro (&Qread_char
);
2452 Qget_file_char
= intern ("get-file-char");
2453 staticpro (&Qget_file_char
);
2455 Qbackquote
= intern ("`");
2456 staticpro (&Qbackquote
);
2457 Qcomma
= intern (",");
2458 staticpro (&Qcomma
);
2459 Qcomma_at
= intern (",@");
2460 staticpro (&Qcomma_at
);
2461 Qcomma_dot
= intern (",.");
2462 staticpro (&Qcomma_dot
);
2464 Qascii_character
= intern ("ascii-character");
2465 staticpro (&Qascii_character
);
2467 Qfunction
= intern ("function");
2468 staticpro (&Qfunction
);
2470 Qload
= intern ("load");
2473 Qload_file_name
= intern ("load-file-name");
2474 staticpro (&Qload_file_name
);
2476 staticpro (&dump_path
);