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, 675 Mass Ave, Cambridge, MA 02139, USA. */
24 #include <sys/types.h>
35 #include "termhooks.h"
39 #include <sys/inode.h>
46 #ifdef LISP_FLOAT_TYPE
56 #endif /* LISP_FLOAT_TYPE */
64 Lisp_Object Qread_char
, Qget_file_char
, Qstandard_input
, Qcurrent_load_list
;
65 Lisp_Object Qvariable_documentation
, Vvalues
, Vstandard_input
, Vafter_load_alist
;
66 Lisp_Object Qascii_character
, Qload
, Qload_file_name
;
67 Lisp_Object Qbackquote
, Qcomma
, Qcomma_at
, Qcomma_dot
, Qfunction
;
69 extern Lisp_Object Qevent_symbol_element_mask
;
71 /* non-zero if inside `load' */
74 /* Search path for files to be loaded. */
75 Lisp_Object Vload_path
;
77 /* This is the user-visible association list that maps features to
78 lists of defs in their load files. */
79 Lisp_Object Vload_history
;
81 /* This is used to build the load history. */
82 Lisp_Object Vcurrent_load_list
;
84 /* Name of file actually being read by `load'. */
85 Lisp_Object Vload_file_name
;
87 /* Function to use for reading, in `load' and friends. */
88 Lisp_Object Vload_read_function
;
90 /* Nonzero means load should forcibly load all dynamic doc strings. */
91 static int load_force_doc_strings
;
93 /* List of descriptors now open for Fload. */
94 static Lisp_Object load_descriptor_list
;
96 /* File for get_file_char to read from. Use by load. */
97 static FILE *instream
;
99 /* When nonzero, read conses in pure space */
100 static int read_pure
;
102 /* For use within read-from-string (this reader is non-reentrant!!) */
103 static int read_from_string_index
;
104 static int read_from_string_limit
;
106 /* This contains the last string skipped with #@. */
107 static char *saved_doc_string
;
108 /* Length of buffer allocated in saved_doc_string. */
109 static int saved_doc_string_size
;
110 /* Length of actual data in saved_doc_string. */
111 static int saved_doc_string_length
;
112 /* This is the file position that string came from. */
113 static int saved_doc_string_position
;
115 /* Nonzero means inside a new-style backquote
116 with no surrounding parentheses.
117 Fread initializes this to zero, so we need not specbind it
118 or worry about what happens to it when there is an error. */
119 static int new_backquote_flag
;
121 /* Handle unreading and rereading of characters.
122 Write READCHAR to read a character,
123 UNREAD(c) to unread c to be read again. */
125 #define READCHAR readchar (readcharfun)
126 #define UNREAD(c) unreadchar (readcharfun, c)
129 readchar (readcharfun
)
130 Lisp_Object readcharfun
;
133 register struct buffer
*inbuffer
;
134 register int c
, mpos
;
136 if (BUFFERP (readcharfun
))
138 inbuffer
= XBUFFER (readcharfun
);
140 if (BUF_PT (inbuffer
) >= BUF_ZV (inbuffer
))
142 c
= *(unsigned char *) BUF_CHAR_ADDRESS (inbuffer
, BUF_PT (inbuffer
));
143 SET_BUF_PT (inbuffer
, BUF_PT (inbuffer
) + 1);
147 if (MARKERP (readcharfun
))
149 inbuffer
= XMARKER (readcharfun
)->buffer
;
151 mpos
= marker_position (readcharfun
);
153 if (mpos
> BUF_ZV (inbuffer
) - 1)
155 c
= *(unsigned char *) BUF_CHAR_ADDRESS (inbuffer
, mpos
);
156 if (mpos
!= BUF_GPT (inbuffer
))
157 XMARKER (readcharfun
)->bufpos
++;
159 Fset_marker (readcharfun
, make_number (mpos
+ 1),
160 Fmarker_buffer (readcharfun
));
163 if (EQ (readcharfun
, Qget_file_char
))
167 /* Interrupted reads have been observed while reading over the network */
168 while (c
== EOF
&& ferror (instream
) && errno
== EINTR
)
177 if (STRINGP (readcharfun
))
180 /* This used to be return of a conditional expression,
181 but that truncated -1 to a char on VMS. */
182 if (read_from_string_index
< read_from_string_limit
)
183 c
= XSTRING (readcharfun
)->data
[read_from_string_index
++];
189 tem
= call0 (readcharfun
);
196 /* Unread the character C in the way appropriate for the stream READCHARFUN.
197 If the stream is a user function, call it with the char as argument. */
200 unreadchar (readcharfun
, c
)
201 Lisp_Object readcharfun
;
205 /* Don't back up the pointer if we're unreading the end-of-input mark,
206 since readchar didn't advance it when we read it. */
208 else if (BUFFERP (readcharfun
))
210 if (XBUFFER (readcharfun
) == current_buffer
)
213 SET_BUF_PT (XBUFFER (readcharfun
), BUF_PT (XBUFFER (readcharfun
)) - 1);
215 else if (MARKERP (readcharfun
))
216 XMARKER (readcharfun
)->bufpos
--;
217 else if (STRINGP (readcharfun
))
218 read_from_string_index
--;
219 else if (EQ (readcharfun
, Qget_file_char
))
220 ungetc (c
, instream
);
222 call1 (readcharfun
, make_number (c
));
225 static Lisp_Object
read0 (), read1 (), read_list (), read_vector ();
227 /* get a character from the tty */
229 extern Lisp_Object
read_char ();
231 /* Read input events until we get one that's acceptable for our purposes.
233 If NO_SWITCH_FRAME is non-zero, switch-frame events are stashed
234 until we get a character we like, and then stuffed into
237 If ASCII_REQUIRED is non-zero, we check function key events to see
238 if the unmodified version of the symbol has a Qascii_character
239 property, and use that character, if present.
241 If ERROR_NONASCII is non-zero, we signal an error if the input we
242 get isn't an ASCII character with modifiers. If it's zero but
243 ASCII_REQUIRED is non-zero, we just re-read until we get an ASCII
246 read_filtered_event (no_switch_frame
, ascii_required
, error_nonascii
)
247 int no_switch_frame
, ascii_required
, error_nonascii
;
250 return make_number (getchar ());
252 register Lisp_Object val
, delayed_switch_frame
;
254 delayed_switch_frame
= Qnil
;
256 /* Read until we get an acceptable event. */
258 val
= read_char (0, 0, 0, Qnil
, 0);
263 /* switch-frame events are put off until after the next ASCII
264 character. This is better than signalling an error just because
265 the last characters were typed to a separate minibuffer frame,
266 for example. Eventually, some code which can deal with
267 switch-frame events will read it and process it. */
269 && EVENT_HAS_PARAMETERS (val
)
270 && EQ (EVENT_HEAD (val
), Qswitch_frame
))
272 delayed_switch_frame
= val
;
278 /* Convert certain symbols to their ASCII equivalents. */
281 Lisp_Object tem
, tem1
, tem2
;
282 tem
= Fget (val
, Qevent_symbol_element_mask
);
285 tem1
= Fget (Fcar (tem
), Qascii_character
);
286 /* Merge this symbol's modifier bits
287 with the ASCII equivalent of its basic code. */
289 XSETFASTINT (val
, XINT (tem1
) | XINT (Fcar (Fcdr (tem
))));
293 /* If we don't have a character now, deal with it appropriately. */
298 Vunread_command_events
= Fcons (val
, Qnil
);
299 error ("Non-character input-event");
306 if (! NILP (delayed_switch_frame
))
307 unread_switch_frame
= delayed_switch_frame
;
313 DEFUN ("read-char", Fread_char
, Sread_char
, 0, 0, 0,
314 "Read a character from the command input (keyboard or macro).\n\
315 It is returned as a number.\n\
316 If the user generates an event which is not a character (i.e. a mouse\n\
317 click or function key event), `read-char' signals an error. As an\n\
318 exception, switch-frame events are put off until non-ASCII events can\n\
320 If you want to read non-character events, or ignore them, call\n\
321 `read-event' or `read-char-exclusive' instead.")
324 return read_filtered_event (1, 1, 1);
327 DEFUN ("read-event", Fread_event
, Sread_event
, 0, 0, 0,
328 "Read an event object from the input stream.")
331 return read_filtered_event (0, 0, 0);
334 DEFUN ("read-char-exclusive", Fread_char_exclusive
, Sread_char_exclusive
, 0, 0, 0,
335 "Read a character from the command input (keyboard or macro).\n\
336 It is returned as a number. Non character events are ignored.")
339 return read_filtered_event (1, 1, 0);
342 DEFUN ("get-file-char", Fget_file_char
, Sget_file_char
, 0, 0, 0,
343 "Don't use this yourself.")
346 register Lisp_Object val
;
347 XSETINT (val
, getc (instream
));
351 static void readevalloop ();
352 static Lisp_Object
load_unwind ();
353 static Lisp_Object
load_descriptor_unwind ();
355 DEFUN ("load", Fload
, Sload
, 1, 4, 0,
356 "Execute a file of Lisp code named FILE.\n\
357 First try FILE with `.elc' appended, then try with `.el',\n\
358 then try FILE unmodified.\n\
359 This function searches the directories in `load-path'.\n\
360 If optional second arg NOERROR is non-nil,\n\
361 report no error if FILE doesn't exist.\n\
362 Print messages at start and end of loading unless\n\
363 optional third arg NOMESSAGE is non-nil.\n\
364 If optional fourth arg NOSUFFIX is non-nil, don't try adding\n\
365 suffixes `.elc' or `.el' to the specified name FILE.\n\
366 Return t if file exists.")
367 (file
, noerror
, nomessage
, nosuffix
)
368 Lisp_Object file
, noerror
, nomessage
, nosuffix
;
370 register FILE *stream
;
371 register int fd
= -1;
372 register Lisp_Object lispstream
;
373 int count
= specpdl_ptr
- specpdl
;
377 /* 1 means inhibit the message at the beginning. */
381 char *dosmode
= "rt";
384 CHECK_STRING (file
, 0);
386 /* If file name is magic, call the handler. */
387 handler
= Ffind_file_name_handler (file
, Qload
);
389 return call5 (handler
, Qload
, file
, noerror
, nomessage
, nosuffix
);
391 /* Do this after the handler to avoid
392 the need to gcpro noerror, nomessage and nosuffix.
393 (Below here, we care only whether they are nil or not.) */
394 file
= Fsubstitute_in_file_name (file
);
396 /* Avoid weird lossage with null string as arg,
397 since it would try to load a directory as a Lisp file */
398 if (XSTRING (file
)->size
> 0)
401 fd
= openp (Vload_path
, file
, !NILP (nosuffix
) ? "" : ".elc:.el:",
410 Fsignal (Qfile_error
, Fcons (build_string ("Cannot open load file"),
411 Fcons (file
, Qnil
)));
416 if (!bcmp (&(XSTRING (found
)->data
[XSTRING (found
)->size
- 4]),
425 stat ((char *)XSTRING (found
)->data
, &s1
);
426 XSTRING (found
)->data
[XSTRING (found
)->size
- 1] = 0;
427 result
= stat ((char *)XSTRING (found
)->data
, &s2
);
428 if (result
>= 0 && (unsigned) s1
.st_mtime
< (unsigned) s2
.st_mtime
)
430 message ("Source file `%s' newer than byte-compiled file",
431 XSTRING (found
)->data
);
432 /* Don't immediately overwrite this message. */
436 XSTRING (found
)->data
[XSTRING (found
)->size
- 1] = 'c';
441 stream
= fopen ((char *) XSTRING (found
)->data
, dosmode
);
442 #else /* not DOS_NT */
443 stream
= fdopen (fd
, "r");
444 #endif /* not DOS_NT */
448 error ("Failure to create stdio stream for %s", XSTRING (file
)->data
);
451 if (NILP (nomessage
) && !nomessage1
)
452 message ("Loading %s...", XSTRING (file
)->data
);
455 lispstream
= Fcons (Qnil
, Qnil
);
456 XSETFASTINT (XCONS (lispstream
)->car
, (EMACS_UINT
)stream
>> 16);
457 XSETFASTINT (XCONS (lispstream
)->cdr
, (EMACS_UINT
)stream
& 0xffff);
458 record_unwind_protect (load_unwind
, lispstream
);
459 record_unwind_protect (load_descriptor_unwind
, load_descriptor_list
);
460 specbind (Qload_file_name
, found
);
462 = Fcons (make_number (fileno (stream
)), load_descriptor_list
);
464 readevalloop (Qget_file_char
, stream
, file
, Feval
, 0);
465 unbind_to (count
, Qnil
);
467 /* Run any load-hooks for this file. */
468 temp
= Fassoc (file
, Vafter_load_alist
);
470 Fprogn (Fcdr (temp
));
473 if (saved_doc_string
)
474 free (saved_doc_string
);
475 saved_doc_string
= 0;
476 saved_doc_string_size
= 0;
478 if (!noninteractive
&& NILP (nomessage
))
479 message ("Loading %s...done", XSTRING (file
)->data
);
484 load_unwind (stream
) /* used as unwind-protect function in load */
487 fclose ((FILE *) (XFASTINT (XCONS (stream
)->car
) << 16
488 | XFASTINT (XCONS (stream
)->cdr
)));
489 if (--load_in_progress
< 0) load_in_progress
= 0;
494 load_descriptor_unwind (oldlist
)
497 load_descriptor_list
= oldlist
;
501 /* Close all descriptors in use for Floads.
502 This is used when starting a subprocess. */
508 for (tail
= load_descriptor_list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
509 close (XFASTINT (XCONS (tail
)->car
));
513 complete_filename_p (pathname
)
514 Lisp_Object pathname
;
516 register unsigned char *s
= XSTRING (pathname
)->data
;
517 return (IS_DIRECTORY_SEP (s
[0])
518 || (XSTRING (pathname
)->size
> 2
519 && IS_DEVICE_SEP (s
[1]) && IS_DIRECTORY_SEP (s
[2]))
529 /* Search for a file whose name is STR, looking in directories
530 in the Lisp list PATH, and trying suffixes from SUFFIX.
531 SUFFIX is a string containing possible suffixes separated by colons.
532 On success, returns a file descriptor. On failure, returns -1.
534 EXEC_ONLY nonzero means don't open the files,
535 just look for one that is executable. In this case,
536 returns 1 on success.
538 If STOREPTR is nonzero, it points to a slot where the name of
539 the file actually found should be stored as a Lisp string.
540 Nil is stored there on failure. */
543 openp (path
, str
, suffix
, storeptr
, exec_only
)
544 Lisp_Object path
, str
;
546 Lisp_Object
*storeptr
;
552 register char *fn
= buf
;
555 register Lisp_Object filename
;
563 if (complete_filename_p (str
))
566 for (; !NILP (path
); path
= Fcdr (path
))
570 filename
= Fexpand_file_name (str
, Fcar (path
));
571 if (!complete_filename_p (filename
))
572 /* If there are non-absolute elts in PATH (eg ".") */
573 /* Of course, this could conceivably lose if luser sets
574 default-directory to be something non-absolute... */
576 filename
= Fexpand_file_name (filename
, current_buffer
->directory
);
577 if (!complete_filename_p (filename
))
578 /* Give up on this path element! */
582 /* Calculate maximum size of any filename made from
583 this path element/specified file name and any possible suffix. */
584 want_size
= strlen (suffix
) + XSTRING (filename
)->size
+ 1;
585 if (fn_size
< want_size
)
586 fn
= (char *) alloca (fn_size
= 100 + want_size
);
590 /* Loop over suffixes. */
593 char *esuffix
= (char *) index (nsuffix
, ':');
594 int lsuffix
= esuffix
? esuffix
- nsuffix
: strlen (nsuffix
);
596 /* Concatenate path element/specified name with the suffix. */
597 strncpy (fn
, XSTRING (filename
)->data
, XSTRING (filename
)->size
);
598 fn
[XSTRING (filename
)->size
] = 0;
599 if (lsuffix
!= 0) /* Bug happens on CCI if lsuffix is 0. */
600 strncat (fn
, nsuffix
, lsuffix
);
602 /* Ignore file if it's a directory. */
603 if (stat (fn
, &st
) >= 0
604 && (st
.st_mode
& S_IFMT
) != S_IFDIR
)
606 /* Check that we can access or open it. */
608 fd
= (access (fn
, X_OK
) == 0) ? 1 : -1;
610 fd
= open (fn
, O_RDONLY
, 0);
614 /* We succeeded; return this descriptor and filename. */
616 *storeptr
= build_string (fn
);
622 /* Advance to next suffix. */
625 nsuffix
+= lsuffix
+ 1;
636 /* Merge the list we've accumulated of globals from the current input source
637 into the load_history variable. The details depend on whether
638 the source has an associated file name or not. */
641 build_load_history (stream
, source
)
645 register Lisp_Object tail
, prev
, newelt
;
646 register Lisp_Object tem
, tem2
;
647 register int foundit
, loading
;
649 /* Don't bother recording anything for preloaded files. */
650 if (!NILP (Vpurify_flag
))
653 loading
= stream
|| !NARROWED
;
655 tail
= Vload_history
;
662 /* Find the feature's previous assoc list... */
663 if (!NILP (Fequal (source
, Fcar (tem
))))
667 /* If we're loading, remove it. */
671 Vload_history
= Fcdr (tail
);
673 Fsetcdr (prev
, Fcdr (tail
));
676 /* Otherwise, cons on new symbols that are not already members. */
679 tem2
= Vcurrent_load_list
;
683 newelt
= Fcar (tem2
);
685 if (NILP (Fmemq (newelt
, tem
)))
686 Fsetcar (tail
, Fcons (Fcar (tem
),
687 Fcons (newelt
, Fcdr (tem
))));
700 /* If we're loading, cons the new assoc onto the front of load-history,
701 the most-recently-loaded position. Also do this if we didn't find
702 an existing member for the current source. */
703 if (loading
|| !foundit
)
704 Vload_history
= Fcons (Fnreverse (Vcurrent_load_list
),
709 unreadpure () /* Used as unwind-protect function in readevalloop */
716 readevalloop (readcharfun
, stream
, sourcename
, evalfun
, printflag
)
717 Lisp_Object readcharfun
;
719 Lisp_Object sourcename
;
720 Lisp_Object (*evalfun
) ();
724 register Lisp_Object val
;
725 int count
= specpdl_ptr
- specpdl
;
727 struct buffer
*b
= 0;
729 if (BUFFERP (readcharfun
))
730 b
= XBUFFER (readcharfun
);
731 else if (MARKERP (readcharfun
))
732 b
= XMARKER (readcharfun
)->buffer
;
734 specbind (Qstandard_input
, readcharfun
);
735 specbind (Qcurrent_load_list
, Qnil
);
739 LOADHIST_ATTACH (sourcename
);
743 if (b
!= 0 && NILP (b
->name
))
744 error ("Reading from killed buffer");
750 while ((c
= READCHAR
) != '\n' && c
!= -1);
755 /* Ignore whitespace here, so we can detect eof. */
756 if (c
== ' ' || c
== '\t' || c
== '\n' || c
== '\f' || c
== '\r')
759 if (!NILP (Vpurify_flag
) && c
== '(')
761 int count1
= specpdl_ptr
- specpdl
;
762 record_unwind_protect (unreadpure
, Qnil
);
763 val
= read_list (-1, readcharfun
);
764 unbind_to (count1
, Qnil
);
769 if (NILP (Vload_read_function
))
770 val
= read0 (readcharfun
);
772 val
= call1 (Vload_read_function
, readcharfun
);
775 val
= (*evalfun
) (val
);
778 Vvalues
= Fcons (val
, Vvalues
);
779 if (EQ (Vstandard_output
, Qt
))
786 build_load_history (stream
, sourcename
);
789 unbind_to (count
, Qnil
);
794 DEFUN ("eval-buffer", Feval_buffer
, Seval_buffer
, 0, 2, "",
795 "Execute the current buffer as Lisp code.\n\
796 Programs can pass two arguments, BUFFER and PRINTFLAG.\n\
797 BUFFER is the buffer to evaluate (nil means use current buffer).\n\
798 PRINTFLAG controls printing of output:\n\
799 nil means discard it; anything else is stream for print.\n\
801 If there is no error, point does not move. If there is an error,\n\
802 point remains at the end of the last character read from the buffer.")
804 Lisp_Object bufname
, printflag
;
806 int count
= specpdl_ptr
- specpdl
;
807 Lisp_Object tem
, buf
;
810 buf
= Fcurrent_buffer ();
812 buf
= Fget_buffer (bufname
);
814 error ("No such buffer.");
816 if (NILP (printflag
))
820 specbind (Qstandard_output
, tem
);
821 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
822 BUF_SET_PT (XBUFFER (buf
), BUF_BEGV (XBUFFER (buf
)));
823 readevalloop (buf
, 0, XBUFFER (buf
)->filename
, Feval
, !NILP (printflag
));
824 unbind_to (count
, Qnil
);
830 DEFUN ("eval-current-buffer", Feval_current_buffer
, Seval_current_buffer
, 0, 1, "",
831 "Execute the current buffer as Lisp code.\n\
832 Programs can pass argument PRINTFLAG which controls printing of output:\n\
833 nil means discard it; anything else is stream for print.\n\
835 If there is no error, point does not move. If there is an error,\n\
836 point remains at the end of the last character read from the buffer.")
838 Lisp_Object printflag
;
840 int count
= specpdl_ptr
- specpdl
;
841 Lisp_Object tem
, cbuf
;
843 cbuf
= Fcurrent_buffer ()
845 if (NILP (printflag
))
849 specbind (Qstandard_output
, tem
);
850 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
852 readevalloop (cbuf
, 0, XBUFFER (cbuf
)->filename
, Feval
, !NILP (printflag
));
853 return unbind_to (count
, Qnil
);
857 DEFUN ("eval-region", Feval_region
, Seval_region
, 2, 3, "r",
858 "Execute the region as Lisp code.\n\
859 When called from programs, expects two arguments,\n\
860 giving starting and ending indices in the current buffer\n\
861 of the text to be executed.\n\
862 Programs can pass third argument PRINTFLAG which controls output:\n\
863 nil means discard it; anything else is stream for printing it.\n\
865 If there is no error, point does not move. If there is an error,\n\
866 point remains at the end of the last character read from the buffer.")
868 Lisp_Object b
, e
, printflag
;
870 int count
= specpdl_ptr
- specpdl
;
871 Lisp_Object tem
, cbuf
;
873 cbuf
= Fcurrent_buffer ();
875 if (NILP (printflag
))
879 specbind (Qstandard_output
, tem
);
881 if (NILP (printflag
))
882 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
883 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
885 /* This both uses b and checks its type. */
887 Fnarrow_to_region (make_number (BEGV
), e
);
888 readevalloop (cbuf
, 0, XBUFFER (cbuf
)->filename
, Feval
, !NILP (printflag
));
890 return unbind_to (count
, Qnil
);
893 #endif /* standalone */
895 DEFUN ("read", Fread
, Sread
, 0, 1, 0,
896 "Read one Lisp expression as text from STREAM, return as Lisp object.\n\
897 If STREAM is nil, use the value of `standard-input' (which see).\n\
898 STREAM or the value of `standard-input' may be:\n\
899 a buffer (read from point and advance it)\n\
900 a marker (read from where it points and advance it)\n\
901 a function (call it with no arguments for each character,\n\
902 call it with a char as argument to push a char back)\n\
903 a string (takes text from string, starting at the beginning)\n\
904 t (read text line using minibuffer and use it).")
908 extern Lisp_Object
Fread_minibuffer ();
911 stream
= Vstandard_input
;
915 new_backquote_flag
= 0;
918 if (EQ (stream
, Qread_char
))
919 return Fread_minibuffer (build_string ("Lisp expression: "), Qnil
);
922 if (STRINGP (stream
))
923 return Fcar (Fread_from_string (stream
, Qnil
, Qnil
));
925 return read0 (stream
);
928 DEFUN ("read-from-string", Fread_from_string
, Sread_from_string
, 1, 3, 0,
929 "Read one Lisp expression which is represented as text by STRING.\n\
930 Returns a cons: (OBJECT-READ . FINAL-STRING-INDEX).\n\
931 START and END optionally delimit a substring of STRING from which to read;\n\
932 they default to 0 and (length STRING) respectively.")
934 Lisp_Object string
, start
, end
;
936 int startval
, endval
;
939 CHECK_STRING (string
,0);
942 endval
= XSTRING (string
)->size
;
944 { CHECK_NUMBER (end
,2);
946 if (endval
< 0 || endval
> XSTRING (string
)->size
)
947 args_out_of_range (string
, end
);
953 { CHECK_NUMBER (start
,1);
954 startval
= XINT (start
);
955 if (startval
< 0 || startval
> endval
)
956 args_out_of_range (string
, start
);
959 read_from_string_index
= startval
;
960 read_from_string_limit
= endval
;
962 new_backquote_flag
= 0;
964 tem
= read0 (string
);
965 return Fcons (tem
, make_number (read_from_string_index
));
968 /* Use this for recursive reads, in contexts where internal tokens
972 Lisp_Object readcharfun
;
974 register Lisp_Object val
;
977 val
= read1 (readcharfun
, &c
, 0);
979 Fsignal (Qinvalid_read_syntax
, Fcons (make_string (&c
, 1), Qnil
));
984 static int read_buffer_size
;
985 static char *read_buffer
;
988 read_escape (readcharfun
)
989 Lisp_Object readcharfun
;
991 register int c
= READCHAR
;
1018 error ("Invalid escape character syntax");
1021 c
= read_escape (readcharfun
);
1022 return c
| meta_modifier
;
1027 error ("Invalid escape character syntax");
1030 c
= read_escape (readcharfun
);
1031 return c
| shift_modifier
;
1036 error ("Invalid escape character syntax");
1039 c
= read_escape (readcharfun
);
1040 return c
| hyper_modifier
;
1045 error ("Invalid escape character syntax");
1048 c
= read_escape (readcharfun
);
1049 return c
| alt_modifier
;
1054 error ("Invalid escape character syntax");
1057 c
= read_escape (readcharfun
);
1058 return c
| super_modifier
;
1063 error ("Invalid escape character syntax");
1067 c
= read_escape (readcharfun
);
1068 if ((c
& 0177) == '?')
1070 /* ASCII control chars are made from letters (both cases),
1071 as well as the non-letters within 0100...0137. */
1072 else if ((c
& 0137) >= 0101 && (c
& 0137) <= 0132)
1073 return (c
& (037 | ~0177));
1074 else if ((c
& 0177) >= 0100 && (c
& 0177) <= 0137)
1075 return (c
& (037 | ~0177));
1077 return c
| ctrl_modifier
;
1087 /* An octal escape, as in ANSI C. */
1089 register int i
= c
- '0';
1090 register int count
= 0;
1093 if ((c
= READCHAR
) >= '0' && c
<= '7')
1108 /* A hex escape, as in ANSI C. */
1114 if (c
>= '0' && c
<= '9')
1119 else if ((c
>= 'a' && c
<= 'f')
1120 || (c
>= 'A' && c
<= 'F'))
1123 if (c
>= 'a' && c
<= 'f')
1142 /* If the next token is ')' or ']' or '.', we store that character
1143 in *PCH and the return value is not interesting. Else, we store
1144 zero in *PCH and we read and return one lisp object.
1146 FIRST_IN_LIST is nonzero if this is the first element of a list. */
1149 read1 (readcharfun
, pch
, first_in_list
)
1150 register Lisp_Object readcharfun
;
1160 if (c
< 0) return Fsignal (Qend_of_file
, Qnil
);
1165 return read_list (0, readcharfun
);
1168 return read_vector (readcharfun
);
1185 tmp
= read_vector (readcharfun
);
1186 if (XVECTOR (tmp
)->size
< CHAR_TABLE_STANDARD_SLOTS
1187 || XVECTOR (tmp
)->size
> CHAR_TABLE_STANDARD_SLOTS
+ 10)
1188 error ("Invalid size char-table");
1189 XSETCHAR_TABLE (tmp
, XCHAR_TABLE (tmp
));
1192 Fsignal (Qinvalid_read_syntax
, Fcons (make_string ("#^", 2), Qnil
));
1197 length
= read1 (readcharfun
, pch
, first_in_list
);
1201 Lisp_Object tmp
, val
;
1202 int size_in_chars
= ((XFASTINT (length
) + BITS_PER_CHAR
)
1206 tmp
= read1 (readcharfun
, pch
, first_in_list
);
1207 if (size_in_chars
!= XSTRING (tmp
)->size
)
1208 Fsignal (Qinvalid_read_syntax
,
1209 Fcons (make_string ("#&", 2), Qnil
));
1211 val
= Fmake_bool_vector (length
, Qnil
);
1212 bcopy (XSTRING (tmp
)->data
, XBOOL_VECTOR (val
)->data
,
1216 Fsignal (Qinvalid_read_syntax
, Fcons (make_string ("#&", 2), Qnil
));
1220 /* Accept compiled functions at read-time so that we don't have to
1221 build them using function calls. */
1223 tmp
= read_vector (readcharfun
);
1224 return Fmake_byte_code (XVECTOR (tmp
)->size
,
1225 XVECTOR (tmp
)->contents
);
1227 #ifdef USE_TEXT_PROPERTIES
1231 struct gcpro gcpro1
;
1234 /* Read the string itself. */
1235 tmp
= read1 (readcharfun
, &ch
, 0);
1236 if (ch
!= 0 || !STRINGP (tmp
))
1237 Fsignal (Qinvalid_read_syntax
, Fcons (make_string ("#", 1), Qnil
));
1239 /* Read the intervals and their properties. */
1242 Lisp_Object beg
, end
, plist
;
1244 beg
= read1 (readcharfun
, &ch
, 0);
1248 end
= read1 (readcharfun
, &ch
, 0);
1250 plist
= read1 (readcharfun
, &ch
, 0);
1252 Fsignal (Qinvalid_read_syntax
,
1253 Fcons (build_string ("invalid string property list"),
1255 Fset_text_properties (beg
, end
, plist
, tmp
);
1261 /* #@NUMBER is used to skip NUMBER following characters.
1262 That's used in .elc files to skip over doc strings
1263 and function definitions. */
1268 /* Read a decimal integer. */
1269 while ((c
= READCHAR
) >= 0
1270 && c
>= '0' && c
<= '9')
1278 #ifndef DOS_NT /* I don't know if filepos works right on MSDOS and Windoze. */
1279 if (load_force_doc_strings
&& EQ (readcharfun
, Qget_file_char
))
1281 /* If we are supposed to force doc strings into core right now,
1282 record the last string that we skipped,
1283 and record where in the file it comes from. */
1284 if (saved_doc_string_size
== 0)
1286 saved_doc_string_size
= nskip
+ 100;
1287 saved_doc_string
= (char *) malloc (saved_doc_string_size
);
1289 if (nskip
> saved_doc_string_size
)
1291 saved_doc_string_size
= nskip
+ 100;
1292 saved_doc_string
= (char *) realloc (saved_doc_string
,
1293 saved_doc_string_size
);
1296 saved_doc_string_position
= ftell (instream
);
1298 /* Copy that many characters into saved_doc_string. */
1299 for (i
= 0; i
< nskip
&& c
>= 0; i
++)
1300 saved_doc_string
[i
] = c
= READCHAR
;
1302 saved_doc_string_length
= i
;
1305 #endif /* not DOS_NT */
1307 /* Skip that many characters. */
1308 for (i
= 0; i
< nskip
&& c
>= 0; i
++)
1314 return Vload_file_name
;
1316 return Fcons (Qfunction
, Fcons (read0 (readcharfun
), Qnil
));
1320 Fsignal (Qinvalid_read_syntax
, Fcons (make_string ("#", 1), Qnil
));
1323 while ((c
= READCHAR
) >= 0 && c
!= '\n');
1328 return Fcons (Qquote
, Fcons (read0 (readcharfun
), Qnil
));
1338 new_backquote_flag
= 1;
1339 value
= read0 (readcharfun
);
1340 new_backquote_flag
= 0;
1342 return Fcons (Qbackquote
, Fcons (value
, Qnil
));
1346 if (new_backquote_flag
)
1348 Lisp_Object comma_type
= Qnil
;
1353 comma_type
= Qcomma_at
;
1355 comma_type
= Qcomma_dot
;
1358 if (ch
>= 0) UNREAD (ch
);
1359 comma_type
= Qcomma
;
1362 new_backquote_flag
= 0;
1363 value
= read0 (readcharfun
);
1364 new_backquote_flag
= 1;
1365 return Fcons (comma_type
, Fcons (value
, Qnil
));
1372 register Lisp_Object val
;
1375 if (c
< 0) return Fsignal (Qend_of_file
, Qnil
);
1378 XSETINT (val
, read_escape (readcharfun
));
1387 register char *p
= read_buffer
;
1388 register char *end
= read_buffer
+ read_buffer_size
;
1392 while ((c
= READCHAR
) >= 0
1397 char *new = (char *) xrealloc (read_buffer
, read_buffer_size
*= 2);
1398 p
+= new - read_buffer
;
1399 read_buffer
+= new - read_buffer
;
1400 end
= read_buffer
+ read_buffer_size
;
1403 c
= read_escape (readcharfun
);
1404 /* c is -1 if \ newline has just been seen */
1407 if (p
== read_buffer
)
1412 /* Allow `\C- ' and `\C-?'. */
1413 if (c
== (CHAR_CTL
| ' '))
1415 else if (c
== (CHAR_CTL
| '?'))
1419 /* Move the meta bit to the right place for a string. */
1420 c
= (c
& ~CHAR_META
) | 0x80;
1422 error ("Invalid modifier in string");
1426 if (c
< 0) return Fsignal (Qend_of_file
, Qnil
);
1428 /* If purifying, and string starts with \ newline,
1429 return zero instead. This is for doc strings
1430 that we are really going to find in etc/DOC.nn.nn */
1431 if (!NILP (Vpurify_flag
) && NILP (Vdoc_file_name
) && cancel
)
1432 return make_number (0);
1435 return make_pure_string (read_buffer
, p
- read_buffer
);
1437 return make_string (read_buffer
, p
- read_buffer
);
1442 #ifdef LISP_FLOAT_TYPE
1443 /* If a period is followed by a number, then we should read it
1444 as a floating point number. Otherwise, it denotes a dotted
1446 int next_char
= READCHAR
;
1449 if (! (next_char
>= '0' && next_char
<= '9'))
1456 /* Otherwise, we fall through! Note that the atom-reading loop
1457 below will now loop at least once, assuring that we will not
1458 try to UNREAD two characters in a row. */
1462 if (c
<= 040) goto retry
;
1464 register char *p
= read_buffer
;
1468 register char *end
= read_buffer
+ read_buffer_size
;
1471 !(c
== '\"' || c
== '\'' || c
== ';' || c
== '?'
1472 || c
== '(' || c
== ')'
1473 #ifndef LISP_FLOAT_TYPE
1474 /* If we have floating-point support, then we need
1475 to allow <digits><dot><digits>. */
1477 #endif /* not LISP_FLOAT_TYPE */
1478 || c
== '[' || c
== ']' || c
== '#'
1483 register char *new = (char *) xrealloc (read_buffer
, read_buffer_size
*= 2);
1484 p
+= new - read_buffer
;
1485 read_buffer
+= new - read_buffer
;
1486 end
= read_buffer
+ read_buffer_size
;
1499 char *new = (char *) xrealloc (read_buffer
, read_buffer_size
*= 2);
1500 p
+= new - read_buffer
;
1501 read_buffer
+= new - read_buffer
;
1502 /* end = read_buffer + read_buffer_size; */
1512 register Lisp_Object val
;
1514 if (*p1
== '+' || *p1
== '-') p1
++;
1515 /* Is it an integer? */
1518 while (p1
!= p
&& (c
= *p1
) >= '0' && c
<= '9') p1
++;
1519 #ifdef LISP_FLOAT_TYPE
1520 /* Integers can have trailing decimal points. */
1521 if (p1
> read_buffer
&& p1
< p
&& *p1
== '.') p1
++;
1524 /* It is an integer. */
1526 #ifdef LISP_FLOAT_TYPE
1530 if (sizeof (int) == sizeof (EMACS_INT
))
1531 XSETINT (val
, atoi (read_buffer
));
1532 else if (sizeof (long) == sizeof (EMACS_INT
))
1533 XSETINT (val
, atol (read_buffer
));
1539 #ifdef LISP_FLOAT_TYPE
1540 if (isfloat_string (read_buffer
))
1541 return make_float (atof (read_buffer
));
1545 return intern (read_buffer
);
1550 #ifdef LISP_FLOAT_TYPE
1565 if (*cp
== '+' || *cp
== '-')
1568 if (*cp
>= '0' && *cp
<= '9')
1571 while (*cp
>= '0' && *cp
<= '9')
1579 if (*cp
>= '0' && *cp
<= '9')
1582 while (*cp
>= '0' && *cp
<= '9')
1589 if (*cp
== '+' || *cp
== '-')
1593 if (*cp
>= '0' && *cp
<= '9')
1596 while (*cp
>= '0' && *cp
<= '9')
1599 return (((*cp
== 0) || (*cp
== ' ') || (*cp
== '\t') || (*cp
== '\n') || (*cp
== '\r') || (*cp
== '\f'))
1600 && (state
== (LEAD_INT
|DOT_CHAR
|TRAIL_INT
)
1601 || state
== (DOT_CHAR
|TRAIL_INT
)
1602 || state
== (LEAD_INT
|E_CHAR
|EXP_INT
)
1603 || state
== (LEAD_INT
|DOT_CHAR
|TRAIL_INT
|E_CHAR
|EXP_INT
)
1604 || state
== (DOT_CHAR
|TRAIL_INT
|E_CHAR
|EXP_INT
)));
1606 #endif /* LISP_FLOAT_TYPE */
1609 read_vector (readcharfun
)
1610 Lisp_Object readcharfun
;
1614 register Lisp_Object
*ptr
;
1615 register Lisp_Object tem
, vector
;
1616 register struct Lisp_Cons
*otem
;
1619 tem
= read_list (1, readcharfun
);
1620 len
= Flength (tem
);
1621 vector
= (read_pure
? make_pure_vector (XINT (len
)) : Fmake_vector (len
, Qnil
));
1624 size
= XVECTOR (vector
)->size
;
1625 ptr
= XVECTOR (vector
)->contents
;
1626 for (i
= 0; i
< size
; i
++)
1628 ptr
[i
] = read_pure
? Fpurecopy (Fcar (tem
)) : Fcar (tem
);
1636 /* flag = 1 means check for ] to terminate rather than ) and .
1637 flag = -1 means check for starting with defun
1638 and make structure pure. */
1641 read_list (flag
, readcharfun
)
1643 register Lisp_Object readcharfun
;
1645 /* -1 means check next element for defun,
1646 0 means don't check,
1647 1 means already checked and found defun. */
1648 int defunflag
= flag
< 0 ? -1 : 0;
1649 Lisp_Object val
, tail
;
1650 register Lisp_Object elt
, tem
;
1651 struct gcpro gcpro1
, gcpro2
;
1652 /* 0 is the normal case.
1653 1 means this list is a doc reference; replace it with the number 0.
1654 2 means this list is a doc reference; replace it with the doc string. */
1655 int doc_reference
= 0;
1657 /* Initialize this to 1 if we are reading a list. */
1658 int first_in_list
= flag
<= 0;
1667 elt
= read1 (readcharfun
, &ch
, first_in_list
);
1672 /* While building, if the list starts with #$, treat it specially. */
1673 if (EQ (elt
, Vload_file_name
)
1674 && !NILP (Vpurify_flag
))
1676 if (NILP (Vdoc_file_name
))
1677 /* We have not yet called Snarf-documentation, so assume
1678 this file is described in the DOC-MM.NN file
1679 and Snarf-documentation will fill in the right value later.
1680 For now, replace the whole list with 0. */
1683 /* We have already called Snarf-documentation, so make a relative
1684 file name for this file, so it can be found properly
1685 in the installed Lisp directory.
1686 We don't use Fexpand_file_name because that would make
1687 the directory absolute now. */
1688 elt
= concat2 (build_string ("../lisp/"),
1689 Ffile_name_nondirectory (elt
));
1691 else if (EQ (elt
, Vload_file_name
)
1692 && load_force_doc_strings
)
1701 Fsignal (Qinvalid_read_syntax
,
1702 Fcons (make_string (") or . in a vector", 18), Qnil
));
1710 XCONS (tail
)->cdr
= read0 (readcharfun
);
1712 val
= read0 (readcharfun
);
1713 read1 (readcharfun
, &ch
, 0);
1717 if (doc_reference
== 1)
1718 return make_number (0);
1719 if (doc_reference
== 2)
1721 /* Get a doc string from the file we are loading.
1722 If it's in saved_doc_string, get it from there. */
1723 int pos
= XINT (XCONS (val
)->cdr
);
1724 if (pos
>= saved_doc_string_position
1725 && pos
< (saved_doc_string_position
1726 + saved_doc_string_length
))
1728 int start
= pos
- saved_doc_string_position
;
1731 /* Process quoting with ^A,
1732 and find the end of the string,
1733 which is marked with ^_ (037). */
1734 for (from
= start
, to
= start
;
1735 saved_doc_string
[from
] != 037;)
1737 int c
= saved_doc_string
[from
++];
1740 c
= saved_doc_string
[from
++];
1742 saved_doc_string
[to
++] = c
;
1744 saved_doc_string
[to
++] = 0;
1746 saved_doc_string
[to
++] = 037;
1749 saved_doc_string
[to
++] = c
;
1752 return make_string (saved_doc_string
+ start
,
1756 return read_doc_string (val
);
1761 return Fsignal (Qinvalid_read_syntax
, Fcons (make_string (". in wrong context", 18), Qnil
));
1763 return Fsignal (Qinvalid_read_syntax
, Fcons (make_string ("] in a list", 11), Qnil
));
1765 tem
= (read_pure
&& flag
<= 0
1766 ? pure_cons (elt
, Qnil
)
1767 : Fcons (elt
, Qnil
));
1769 XCONS (tail
)->cdr
= tem
;
1774 defunflag
= EQ (elt
, Qdefun
);
1775 else if (defunflag
> 0)
1780 Lisp_Object Vobarray
;
1781 Lisp_Object initial_obarray
;
1783 /* oblookup stores the bucket number here, for the sake of Funintern. */
1785 int oblookup_last_bucket_number
;
1787 static int hash_string ();
1788 Lisp_Object
oblookup ();
1790 /* Get an error if OBARRAY is not an obarray.
1791 If it is one, return it. */
1794 check_obarray (obarray
)
1795 Lisp_Object obarray
;
1797 while (!VECTORP (obarray
) || XVECTOR (obarray
)->size
== 0)
1799 /* If Vobarray is now invalid, force it to be valid. */
1800 if (EQ (Vobarray
, obarray
)) Vobarray
= initial_obarray
;
1802 obarray
= wrong_type_argument (Qvectorp
, obarray
);
1807 /* Intern the C string STR: return a symbol with that name,
1808 interned in the current obarray. */
1815 int len
= strlen (str
);
1816 Lisp_Object obarray
;
1819 if (!VECTORP (obarray
) || XVECTOR (obarray
)->size
== 0)
1820 obarray
= check_obarray (obarray
);
1821 tem
= oblookup (obarray
, str
, len
);
1824 return Fintern ((!NILP (Vpurify_flag
)
1825 ? make_pure_string (str
, len
)
1826 : make_string (str
, len
)),
1830 DEFUN ("intern", Fintern
, Sintern
, 1, 2, 0,
1831 "Return the canonical symbol whose name is STRING.\n\
1832 If there is none, one is created by this function and returned.\n\
1833 A second optional argument specifies the obarray to use;\n\
1834 it defaults to the value of `obarray'.")
1836 Lisp_Object str
, obarray
;
1838 register Lisp_Object tem
, sym
, *ptr
;
1840 if (NILP (obarray
)) obarray
= Vobarray
;
1841 obarray
= check_obarray (obarray
);
1843 CHECK_STRING (str
, 0);
1845 tem
= oblookup (obarray
, XSTRING (str
)->data
, XSTRING (str
)->size
);
1846 if (!INTEGERP (tem
))
1849 if (!NILP (Vpurify_flag
))
1850 str
= Fpurecopy (str
);
1851 sym
= Fmake_symbol (str
);
1853 ptr
= &XVECTOR (obarray
)->contents
[XINT (tem
)];
1855 XSYMBOL (sym
)->next
= XSYMBOL (*ptr
);
1857 XSYMBOL (sym
)->next
= 0;
1862 DEFUN ("intern-soft", Fintern_soft
, Sintern_soft
, 1, 2, 0,
1863 "Return the canonical symbol whose name is STRING, or nil if none exists.\n\
1864 A second optional argument specifies the obarray to use;\n\
1865 it defaults to the value of `obarray'.")
1867 Lisp_Object str
, obarray
;
1869 register Lisp_Object tem
;
1871 if (NILP (obarray
)) obarray
= Vobarray
;
1872 obarray
= check_obarray (obarray
);
1874 CHECK_STRING (str
, 0);
1876 tem
= oblookup (obarray
, XSTRING (str
)->data
, XSTRING (str
)->size
);
1877 if (!INTEGERP (tem
))
1882 DEFUN ("unintern", Funintern
, Sunintern
, 1, 2, 0,
1883 "Delete the symbol named NAME, if any, from OBARRAY.\n\
1884 The value is t if a symbol was found and deleted, nil otherwise.\n\
1885 NAME may be a string or a symbol. If it is a symbol, that symbol\n\
1886 is deleted, if it belongs to OBARRAY--no other symbol is deleted.\n\
1887 OBARRAY defaults to the value of the variable `obarray'.")
1889 Lisp_Object name
, obarray
;
1891 register Lisp_Object string
, tem
;
1894 if (NILP (obarray
)) obarray
= Vobarray
;
1895 obarray
= check_obarray (obarray
);
1898 XSETSTRING (string
, XSYMBOL (name
)->name
);
1901 CHECK_STRING (name
, 0);
1905 tem
= oblookup (obarray
, XSTRING (string
)->data
, XSTRING (string
)->size
);
1908 /* If arg was a symbol, don't delete anything but that symbol itself. */
1909 if (SYMBOLP (name
) && !EQ (name
, tem
))
1912 hash
= oblookup_last_bucket_number
;
1914 if (EQ (XVECTOR (obarray
)->contents
[hash
], tem
))
1916 if (XSYMBOL (tem
)->next
)
1917 XSETSYMBOL (XVECTOR (obarray
)->contents
[hash
], XSYMBOL (tem
)->next
);
1919 XSETINT (XVECTOR (obarray
)->contents
[hash
], 0);
1923 Lisp_Object tail
, following
;
1925 for (tail
= XVECTOR (obarray
)->contents
[hash
];
1926 XSYMBOL (tail
)->next
;
1929 XSETSYMBOL (following
, XSYMBOL (tail
)->next
);
1930 if (EQ (following
, tem
))
1932 XSYMBOL (tail
)->next
= XSYMBOL (following
)->next
;
1941 /* Return the symbol in OBARRAY whose names matches the string
1942 of SIZE characters at PTR. If there is no such symbol in OBARRAY,
1945 Also store the bucket number in oblookup_last_bucket_number. */
1948 oblookup (obarray
, ptr
, size
)
1949 Lisp_Object obarray
;
1955 register Lisp_Object tail
;
1956 Lisp_Object bucket
, tem
;
1958 if (!VECTORP (obarray
)
1959 || (obsize
= XVECTOR (obarray
)->size
) == 0)
1961 obarray
= check_obarray (obarray
);
1962 obsize
= XVECTOR (obarray
)->size
;
1964 /* This is sometimes needed in the middle of GC. */
1965 obsize
&= ~ARRAY_MARK_FLAG
;
1966 /* Combining next two lines breaks VMS C 2.3. */
1967 hash
= hash_string (ptr
, size
);
1969 bucket
= XVECTOR (obarray
)->contents
[hash
];
1970 oblookup_last_bucket_number
= hash
;
1971 if (XFASTINT (bucket
) == 0)
1973 else if (!SYMBOLP (bucket
))
1974 error ("Bad data in guts of obarray"); /* Like CADR error message */
1976 for (tail
= bucket
; ; XSETSYMBOL (tail
, XSYMBOL (tail
)->next
))
1978 if (XSYMBOL (tail
)->name
->size
== size
1979 && !bcmp (XSYMBOL (tail
)->name
->data
, ptr
, size
))
1981 else if (XSYMBOL (tail
)->next
== 0)
1984 XSETINT (tem
, hash
);
1989 hash_string (ptr
, len
)
1993 register unsigned char *p
= ptr
;
1994 register unsigned char *end
= p
+ len
;
1995 register unsigned char c
;
1996 register int hash
= 0;
2001 if (c
>= 0140) c
-= 40;
2002 hash
= ((hash
<<3) + (hash
>>28) + c
);
2004 return hash
& 07777777777;
2008 map_obarray (obarray
, fn
, arg
)
2009 Lisp_Object obarray
;
2014 register Lisp_Object tail
;
2015 CHECK_VECTOR (obarray
, 1);
2016 for (i
= XVECTOR (obarray
)->size
- 1; i
>= 0; i
--)
2018 tail
= XVECTOR (obarray
)->contents
[i
];
2019 if (XFASTINT (tail
) != 0)
2023 if (XSYMBOL (tail
)->next
== 0)
2025 XSETSYMBOL (tail
, XSYMBOL (tail
)->next
);
2030 mapatoms_1 (sym
, function
)
2031 Lisp_Object sym
, function
;
2033 call1 (function
, sym
);
2036 DEFUN ("mapatoms", Fmapatoms
, Smapatoms
, 1, 2, 0,
2037 "Call FUNCTION on every symbol in OBARRAY.\n\
2038 OBARRAY defaults to the value of `obarray'.")
2040 Lisp_Object function
, obarray
;
2044 if (NILP (obarray
)) obarray
= Vobarray
;
2045 obarray
= check_obarray (obarray
);
2047 map_obarray (obarray
, mapatoms_1
, function
);
2051 #define OBARRAY_SIZE 1511
2056 Lisp_Object oblength
;
2060 XSETFASTINT (oblength
, OBARRAY_SIZE
);
2062 Qnil
= Fmake_symbol (make_pure_string ("nil", 3));
2063 Vobarray
= Fmake_vector (oblength
, make_number (0));
2064 initial_obarray
= Vobarray
;
2065 staticpro (&initial_obarray
);
2066 /* Intern nil in the obarray */
2067 /* These locals are to kludge around a pyramid compiler bug. */
2068 hash
= hash_string ("nil", 3);
2069 /* Separate statement here to avoid VAXC bug. */
2070 hash
%= OBARRAY_SIZE
;
2071 tem
= &XVECTOR (Vobarray
)->contents
[hash
];
2074 Qunbound
= Fmake_symbol (make_pure_string ("unbound", 7));
2075 XSYMBOL (Qnil
)->function
= Qunbound
;
2076 XSYMBOL (Qunbound
)->value
= Qunbound
;
2077 XSYMBOL (Qunbound
)->function
= Qunbound
;
2080 XSYMBOL (Qnil
)->value
= Qnil
;
2081 XSYMBOL (Qnil
)->plist
= Qnil
;
2082 XSYMBOL (Qt
)->value
= Qt
;
2084 /* Qt is correct even if CANNOT_DUMP. loadup.el will set to nil at end. */
2087 Qvariable_documentation
= intern ("variable-documentation");
2089 read_buffer_size
= 100;
2090 read_buffer
= (char *) malloc (read_buffer_size
);
2095 struct Lisp_Subr
*sname
;
2098 sym
= intern (sname
->symbol_name
);
2099 XSETSUBR (XSYMBOL (sym
)->function
, sname
);
2102 #ifdef NOTDEF /* use fset in subr.el now */
2104 defalias (sname
, string
)
2105 struct Lisp_Subr
*sname
;
2109 sym
= intern (string
);
2110 XSETSUBR (XSYMBOL (sym
)->function
, sname
);
2114 /* Define an "integer variable"; a symbol whose value is forwarded
2115 to a C variable of type int. Sample call: */
2116 /* DEFVAR_INT ("indent-tabs-mode", &indent_tabs_mode, "Documentation"); */
2118 defvar_int (namestring
, address
)
2122 Lisp_Object sym
, val
;
2123 sym
= intern (namestring
);
2124 val
= allocate_misc ();
2125 XMISCTYPE (val
) = Lisp_Misc_Intfwd
;
2126 XINTFWD (val
)->intvar
= address
;
2127 XSYMBOL (sym
)->value
= val
;
2130 /* Similar but define a variable whose value is T if address contains 1,
2131 NIL if address contains 0 */
2133 defvar_bool (namestring
, address
)
2137 Lisp_Object sym
, val
;
2138 sym
= intern (namestring
);
2139 val
= allocate_misc ();
2140 XMISCTYPE (val
) = Lisp_Misc_Boolfwd
;
2141 XBOOLFWD (val
)->boolvar
= address
;
2142 XSYMBOL (sym
)->value
= val
;
2145 /* Similar but define a variable whose value is the Lisp Object stored
2146 at address. Two versions: with and without gc-marking of the C
2147 variable. The nopro version is used when that variable will be
2148 gc-marked for some other reason, since marking the same slot twice
2149 can cause trouble with strings. */
2151 defvar_lisp_nopro (namestring
, address
)
2153 Lisp_Object
*address
;
2155 Lisp_Object sym
, val
;
2156 sym
= intern (namestring
);
2157 val
= allocate_misc ();
2158 XMISCTYPE (val
) = Lisp_Misc_Objfwd
;
2159 XOBJFWD (val
)->objvar
= address
;
2160 XSYMBOL (sym
)->value
= val
;
2164 defvar_lisp (namestring
, address
)
2166 Lisp_Object
*address
;
2168 defvar_lisp_nopro (namestring
, address
);
2169 staticpro (address
);
2174 /* Similar but define a variable whose value is the Lisp Object stored in
2175 the current buffer. address is the address of the slot in the buffer
2176 that is current now. */
2179 defvar_per_buffer (namestring
, address
, type
, doc
)
2181 Lisp_Object
*address
;
2185 Lisp_Object sym
, val
;
2187 extern struct buffer buffer_local_symbols
;
2189 sym
= intern (namestring
);
2190 val
= allocate_misc ();
2191 offset
= (char *)address
- (char *)current_buffer
;
2193 XMISCTYPE (val
) = Lisp_Misc_Buffer_Objfwd
;
2194 XBUFFER_OBJFWD (val
)->offset
= offset
;
2195 XSYMBOL (sym
)->value
= val
;
2196 *(Lisp_Object
*)(offset
+ (char *)&buffer_local_symbols
) = sym
;
2197 *(Lisp_Object
*)(offset
+ (char *)&buffer_local_types
) = type
;
2198 if (XINT (*(Lisp_Object
*)(offset
+ (char *)&buffer_local_flags
)) == 0)
2199 /* Did a DEFVAR_PER_BUFFER without initializing the corresponding
2200 slot of buffer_local_flags */
2204 #endif /* standalone */
2206 /* Similar but define a variable whose value is the Lisp Object stored
2207 at a particular offset in the current kboard object. */
2210 defvar_kboard (namestring
, offset
)
2214 Lisp_Object sym
, val
;
2215 sym
= intern (namestring
);
2216 val
= allocate_misc ();
2217 XMISCTYPE (val
) = Lisp_Misc_Kboard_Objfwd
;
2218 XKBOARD_OBJFWD (val
)->offset
= offset
;
2219 XSYMBOL (sym
)->value
= val
;
2225 int turn_off_warning
= 0;
2227 /* Compute the default load-path. */
2229 normal
= PATH_LOADSEARCH
;
2230 Vload_path
= decode_env_path (0, normal
);
2232 if (NILP (Vpurify_flag
))
2233 normal
= PATH_LOADSEARCH
;
2235 normal
= PATH_DUMPLOADSEARCH
;
2237 /* In a dumped Emacs, we normally have to reset the value of
2238 Vload_path from PATH_LOADSEARCH, since the value that was dumped
2239 uses ../lisp, instead of the path of the installed elisp
2240 libraries. However, if it appears that Vload_path was changed
2241 from the default before dumping, don't override that value. */
2244 Lisp_Object dump_path
;
2246 dump_path
= decode_env_path (0, PATH_DUMPLOADSEARCH
);
2247 if (! NILP (Fequal (dump_path
, Vload_path
)))
2249 Vload_path
= decode_env_path (0, normal
);
2250 if (!NILP (Vinstallation_directory
))
2252 /* Add to the path the lisp subdir of the
2253 installation dir, if it exists. */
2254 Lisp_Object tem
, tem1
;
2255 tem
= Fexpand_file_name (build_string ("lisp"),
2256 Vinstallation_directory
);
2257 tem1
= Ffile_exists_p (tem
);
2260 if (NILP (Fmember (tem
, Vload_path
)))
2262 turn_off_warning
= 1;
2263 Vload_path
= nconc2 (Vload_path
, Fcons (tem
, Qnil
));
2267 /* That dir doesn't exist, so add the build-time
2268 Lisp dirs instead. */
2269 Vload_path
= nconc2 (Vload_path
, dump_path
);
2271 /* Add site-list under the installation dir, if it exists. */
2272 tem
= Fexpand_file_name (build_string ("site-lisp"),
2273 Vinstallation_directory
);
2274 tem1
= Ffile_exists_p (tem
);
2277 if (NILP (Fmember (tem
, Vload_path
)))
2278 Vload_path
= nconc2 (Vload_path
, Fcons (tem
, Qnil
));
2284 Vload_path
= decode_env_path (0, normal
);
2288 /* When Emacs is invoked over network shares on NT, PATH_LOADSEARCH is
2289 almost never correct, thereby causing a warning to be printed out that
2290 confuses users. Since PATH_LOADSEARCH is always overriden by the
2291 EMACSLOADPATH environment variable below, disable the warning on NT. */
2293 /* Warn if dirs in the *standard* path don't exist. */
2294 if (!turn_off_warning
)
2296 Lisp_Object path_tail
;
2298 for (path_tail
= Vload_path
;
2300 path_tail
= XCONS (path_tail
)->cdr
)
2302 Lisp_Object dirfile
;
2303 dirfile
= Fcar (path_tail
);
2304 if (STRINGP (dirfile
))
2306 dirfile
= Fdirectory_file_name (dirfile
);
2307 if (access (XSTRING (dirfile
)->data
, 0) < 0)
2309 "Warning: Lisp directory `%s' does not exist.\n",
2310 XSTRING (Fcar (path_tail
))->data
);
2314 #endif /* WINDOWSNT */
2316 /* If the EMACSLOADPATH environment variable is set, use its value.
2317 This doesn't apply if we're dumping. */
2319 if (NILP (Vpurify_flag
)
2320 && egetenv ("EMACSLOADPATH"))
2322 Vload_path
= decode_env_path ("EMACSLOADPATH", normal
);
2326 load_in_progress
= 0;
2328 load_descriptor_list
= Qnil
;
2335 defsubr (&Sread_from_string
);
2337 defsubr (&Sintern_soft
);
2338 defsubr (&Sunintern
);
2340 defsubr (&Seval_buffer
);
2341 defsubr (&Seval_region
);
2342 defsubr (&Sread_char
);
2343 defsubr (&Sread_char_exclusive
);
2344 defsubr (&Sread_event
);
2345 defsubr (&Sget_file_char
);
2346 defsubr (&Smapatoms
);
2348 DEFVAR_LISP ("obarray", &Vobarray
,
2349 "Symbol table for use by `intern' and `read'.\n\
2350 It is a vector whose length ought to be prime for best results.\n\
2351 The vector's contents don't make sense if examined from Lisp programs;\n\
2352 to find all the symbols in an obarray, use `mapatoms'.");
2354 DEFVAR_LISP ("values", &Vvalues
,
2355 "List of values of all expressions which were read, evaluated and printed.\n\
2356 Order is reverse chronological.");
2358 DEFVAR_LISP ("standard-input", &Vstandard_input
,
2359 "Stream for read to get input from.\n\
2360 See documentation of `read' for possible values.");
2361 Vstandard_input
= Qt
;
2363 DEFVAR_LISP ("load-path", &Vload_path
,
2364 "*List of directories to search for files to load.\n\
2365 Each element is a string (directory name) or nil (try default directory).\n\
2366 Initialized based on EMACSLOADPATH environment variable, if any,\n\
2367 otherwise to default specified by file `paths.h' when Emacs was built.");
2369 DEFVAR_BOOL ("load-in-progress", &load_in_progress
,
2370 "Non-nil iff inside of `load'.");
2372 DEFVAR_LISP ("after-load-alist", &Vafter_load_alist
,
2373 "An alist of expressions to be evalled when particular files are loaded.\n\
2374 Each element looks like (FILENAME FORMS...).\n\
2375 When `load' is run and the file-name argument is FILENAME,\n\
2376 the FORMS in the corresponding element are executed at the end of loading.\n\n\
2377 FILENAME must match exactly! Normally FILENAME is the name of a library,\n\
2378 with no directory specified, since that is how `load' is normally called.\n\
2379 An error in FORMS does not undo the load,\n\
2380 but does prevent execution of the rest of the FORMS.");
2381 Vafter_load_alist
= Qnil
;
2383 DEFVAR_LISP ("load-history", &Vload_history
,
2384 "Alist mapping source file names to symbols and features.\n\
2385 Each alist element is a list that starts with a file name,\n\
2386 except for one element (optional) that starts with nil and describes\n\
2387 definitions evaluated from buffers not visiting files.\n\
2388 The remaining elements of each list are symbols defined as functions\n\
2389 or variables, and cons cells `(provide . FEATURE)' and `(require . FEATURE)'.");
2390 Vload_history
= Qnil
;
2392 DEFVAR_LISP ("load-file-name", &Vload_file_name
,
2393 "Full name of file being loaded by `load'.");
2394 Vload_file_name
= Qnil
;
2396 DEFVAR_LISP ("current-load-list", &Vcurrent_load_list
,
2397 "Used for internal purposes by `load'.");
2398 Vcurrent_load_list
= Qnil
;
2400 DEFVAR_LISP ("load-read-function", &Vload_read_function
,
2401 "Function used by `load' and `eval-region' for reading expressions.\n\
2402 The default is nil, which means use the function `read'.");
2403 Vload_read_function
= Qnil
;
2405 DEFVAR_BOOL ("load-force-doc-strings", &load_force_doc_strings
,
2406 "Non-nil means `load' should force-load all dynamic doc strings.\n\
2407 This is useful when the file being loaded is a temporary copy.");
2408 load_force_doc_strings
= 0;
2410 load_descriptor_list
= Qnil
;
2411 staticpro (&load_descriptor_list
);
2413 Qcurrent_load_list
= intern ("current-load-list");
2414 staticpro (&Qcurrent_load_list
);
2416 Qstandard_input
= intern ("standard-input");
2417 staticpro (&Qstandard_input
);
2419 Qread_char
= intern ("read-char");
2420 staticpro (&Qread_char
);
2422 Qget_file_char
= intern ("get-file-char");
2423 staticpro (&Qget_file_char
);
2425 Qbackquote
= intern ("`");
2426 staticpro (&Qbackquote
);
2427 Qcomma
= intern (",");
2428 staticpro (&Qcomma
);
2429 Qcomma_at
= intern (",@");
2430 staticpro (&Qcomma_at
);
2431 Qcomma_dot
= intern (",.");
2432 staticpro (&Qcomma_dot
);
2434 Qascii_character
= intern ("ascii-character");
2435 staticpro (&Qascii_character
);
2437 Qfunction
= intern ("function");
2438 staticpro (&Qfunction
);
2440 Qload
= intern ("load");
2443 Qload_file_name
= intern ("load-file-name");
2444 staticpro (&Qload_file_name
);