1 /* Lisp parsing and input streams.
2 Copyright (C) 1985, 1986, 1987, 1988, 1989,
3 1992 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. */
23 #include <sys/types.h>
36 #include "termhooks.h"
40 #include <sys/inode.h>
47 #ifdef LISP_FLOAT_TYPE
49 #endif /* LISP_FLOAT_TYPE */
51 Lisp_Object Qread_char
, Qget_file_char
, Qstandard_input
;
52 Lisp_Object Qvariable_documentation
, Vvalues
, Vstandard_input
, Vafter_load_alist
;
53 Lisp_Object Qascii_character
;
55 extern Lisp_Object Qevent_symbol_element_mask
;
57 /* non-zero if inside `load' */
60 /* Search path for files to be loaded. */
61 Lisp_Object Vload_path
;
63 /* This is the user-visible association list that maps features to
64 lists of defs in their load files. */
65 Lisp_Object Vload_history
;
67 /* This is useud to build the load history. */
68 Lisp_Object Vcurrent_load_list
;
70 /* File for get_file_char to read from. Use by load */
71 static FILE *instream
;
73 /* When nonzero, read conses in pure space */
76 /* For use within read-from-string (this reader is non-reentrant!!) */
77 static int read_from_string_index
;
78 static int read_from_string_limit
;
80 /* Handle unreading and rereading of characters.
81 Write READCHAR to read a character,
82 UNREAD(c) to unread c to be read again. */
84 #define READCHAR readchar (readcharfun)
85 #define UNREAD(c) unreadchar (readcharfun, c)
88 readchar (readcharfun
)
89 Lisp_Object readcharfun
;
92 register struct buffer
*inbuffer
;
95 if (XTYPE (readcharfun
) == Lisp_Buffer
)
97 inbuffer
= XBUFFER (readcharfun
);
99 if (BUF_PT (inbuffer
) >= BUF_ZV (inbuffer
))
101 c
= *(unsigned char *) BUF_CHAR_ADDRESS (inbuffer
, BUF_PT (inbuffer
));
102 SET_BUF_PT (inbuffer
, BUF_PT (inbuffer
) + 1);
106 if (XTYPE (readcharfun
) == Lisp_Marker
)
108 inbuffer
= XMARKER (readcharfun
)->buffer
;
110 mpos
= marker_position (readcharfun
);
112 if (mpos
> BUF_ZV (inbuffer
) - 1)
114 c
= *(unsigned char *) BUF_CHAR_ADDRESS (inbuffer
, mpos
);
115 if (mpos
!= BUF_GPT (inbuffer
))
116 XMARKER (readcharfun
)->bufpos
++;
118 Fset_marker (readcharfun
, make_number (mpos
+ 1),
119 Fmarker_buffer (readcharfun
));
122 if (EQ (readcharfun
, Qget_file_char
))
123 return getc (instream
);
125 if (XTYPE (readcharfun
) == Lisp_String
)
128 /* This used to be return of a conditional expression,
129 but that truncated -1 to a char on VMS. */
130 if (read_from_string_index
< read_from_string_limit
)
131 c
= XSTRING (readcharfun
)->data
[read_from_string_index
++];
137 tem
= call0 (readcharfun
);
144 /* Unread the character C in the way appropriate for the stream READCHARFUN.
145 If the stream is a user function, call it with the char as argument. */
148 unreadchar (readcharfun
, c
)
149 Lisp_Object readcharfun
;
152 if (XTYPE (readcharfun
) == Lisp_Buffer
)
154 if (XBUFFER (readcharfun
) == current_buffer
)
157 SET_BUF_PT (XBUFFER (readcharfun
), BUF_PT (XBUFFER (readcharfun
)) - 1);
159 else if (XTYPE (readcharfun
) == Lisp_Marker
)
160 XMARKER (readcharfun
)->bufpos
--;
161 else if (XTYPE (readcharfun
) == Lisp_String
)
162 read_from_string_index
--;
163 else if (EQ (readcharfun
, Qget_file_char
))
164 ungetc (c
, instream
);
166 call1 (readcharfun
, make_number (c
));
169 static Lisp_Object
read0 (), read1 (), read_list (), read_vector ();
171 /* get a character from the tty */
173 extern Lisp_Object
read_char ();
175 /* Read input events until we get one that's acceptable for our purposes.
177 If NO_SWITCH_FRAME is non-zero, switch-frame events are stashed
178 until we get a character we like, and then stuffed into
181 If ASCII_REQUIRED is non-zero, we check function key events to see
182 if the unmodified version of the symbol has a Qascii_character
183 property, and use that character, if present.
185 If ERROR_NONASCII is non-zero, we signal an error if the input we
186 get isn't an ASCII character with modifiers. If it's zero but
187 ASCII_REQUIRED is non-zero, we just re-read until we get an ASCII
190 read_filtered_event (no_switch_frame
, ascii_required
, error_nonascii
)
191 int no_switch_frame
, ascii_required
, error_nonascii
;
194 return make_number (getchar ());
196 register Lisp_Object val
;
197 register Lisp_Object delayed_switch_frame
= Qnil
;
199 /* Read until we get an acceptable event. */
201 val
= read_char (0, 0, 0, Qnil
, 0);
203 /* switch-frame events are put off until after the next ASCII
204 character. This is better than signalling an error just because
205 the last characters were typed to a separate minibuffer frame,
206 for example. Eventually, some code which can deal with
207 switch-frame events will read it and process it. */
209 && EVENT_HAS_PARAMETERS (val
)
210 && EQ (EVENT_HEAD (val
), Qswitch_frame
))
212 delayed_switch_frame
= val
;
218 /* Convert certain symbols to their ASCII equivalents. */
219 if (XTYPE (val
) == Lisp_Symbol
)
221 Lisp_Object tem
, tem1
, tem2
;
222 tem
= Fget (val
, Qevent_symbol_element_mask
);
225 tem1
= Fget (Fcar (tem
), Qascii_character
);
226 /* Merge this symbol's modifier bits
227 with the ASCII equivalent of its basic code. */
229 XFASTINT (val
) = XINT (tem1
) | XINT (Fcar (Fcdr (tem
)));
233 /* If we don't have a character now, deal with it appropriately. */
234 if (XTYPE (val
) != Lisp_Int
)
238 unread_command_events
= Fcons (val
, Qnil
);
239 error ("Non-character input-event");
246 if (! NILP (delayed_switch_frame
))
247 unread_switch_frame
= delayed_switch_frame
;
253 DEFUN ("read-char", Fread_char
, Sread_char
, 0, 0, 0,
254 "Read a character from the command input (keyboard or macro).\n\
255 It is returned as a number.\n\
256 If the user generates an event which is not a character (i.e. a mouse\n\
257 click or function key event), `read-char' signals an error. As an\n\
258 exception, switch-frame events are put off until non-ASCII events can\n\
260 If you want to read non-character events, or ignore them, call\n\
261 `read-event' or `read-char-exclusive' instead.")
264 return read_filtered_event (1, 1, 1);
267 DEFUN ("read-event", Fread_event
, Sread_event
, 0, 0, 0,
268 "Read an event object from the input stream.")
271 return read_filtered_event (0, 0, 0);
274 DEFUN ("read-char-exclusive", Fread_char_exclusive
, Sread_char_exclusive
, 0, 0, 0,
275 "Read a character from the command input (keyboard or macro).\n\
276 It is returned as a number. Non character events are ignored.")
279 return read_filtered_event (1, 1, 0);
282 DEFUN ("get-file-char", Fget_file_char
, Sget_file_char
, 0, 0, 0,
283 "Don't use this yourself.")
286 register Lisp_Object val
;
287 XSET (val
, Lisp_Int
, getc (instream
));
291 static void readevalloop ();
292 static Lisp_Object
load_unwind ();
294 DEFUN ("load", Fload
, Sload
, 1, 4, 0,
295 "Execute a file of Lisp code named FILE.\n\
296 First try FILE with `.elc' appended, then try with `.el',\n\
297 then try FILE unmodified.\n\
298 This function searches the directories in `load-path'.\n\
299 If optional second arg NOERROR is non-nil,\n\
300 report no error if FILE doesn't exist.\n\
301 Print messages at start and end of loading unless\n\
302 optional third arg NOMESSAGE is non-nil.\n\
303 If optional fourth arg NOSUFFIX is non-nil, don't try adding\n\
304 suffixes `.elc' or `.el' to the specified name FILE.\n\
305 Return t if file exists.")
306 (str
, noerror
, nomessage
, nosuffix
)
307 Lisp_Object str
, noerror
, nomessage
, nosuffix
;
309 register FILE *stream
;
310 register int fd
= -1;
311 register Lisp_Object lispstream
;
313 int count
= specpdl_ptr
- specpdl
;
317 /* 1 means inhibit the message at the beginning. */
320 CHECK_STRING (str
, 0);
321 str
= Fsubstitute_in_file_name (str
);
323 /* Avoid weird lossage with null string as arg,
324 since it would try to load a directory as a Lisp file */
325 if (XSTRING (str
)->size
> 0)
327 fd
= openp (Vload_path
, str
, !NILP (nosuffix
) ? "" : ".elc:.el:",
335 Fsignal (Qfile_error
, Fcons (build_string ("Cannot open load file"),
341 if (!bcmp (&(XSTRING (found
)->data
[XSTRING (found
)->size
- 4]),
347 stat (XSTRING (found
)->data
, &s1
);
348 XSTRING (found
)->data
[XSTRING (found
)->size
- 1] = 0;
349 result
= stat (XSTRING (found
)->data
, &s2
);
350 if (result
>= 0 && (unsigned) s1
.st_mtime
< (unsigned) s2
.st_mtime
)
352 message ("Source file `%s' newer than byte-compiled file",
353 XSTRING (found
)->data
);
354 /* Don't immediately overwrite this message. */
358 XSTRING (found
)->data
[XSTRING (found
)->size
- 1] = 'c';
361 stream
= fdopen (fd
, "r");
365 error ("Failure to create stdio stream for %s", XSTRING (str
)->data
);
368 if (NILP (nomessage
) && !nomessage1
)
369 message ("Loading %s...", XSTRING (str
)->data
);
372 /* We may not be able to store STREAM itself as a Lisp_Object pointer
373 since that is guaranteed to work only for data that has been malloc'd.
374 So malloc a full-size pointer, and record the address of that pointer. */
375 ptr
= (FILE **) xmalloc (sizeof (FILE *));
377 XSET (lispstream
, Lisp_Internal_Stream
, (int) ptr
);
378 record_unwind_protect (load_unwind
, lispstream
);
380 readevalloop (Qget_file_char
, stream
, str
, Feval
, 0);
381 unbind_to (count
, Qnil
);
383 /* Run any load-hooks for this file. */
384 temp
= Fassoc (str
, Vafter_load_alist
);
386 Fprogn (Fcdr (temp
));
389 if (!noninteractive
&& NILP (nomessage
))
390 message ("Loading %s...done", XSTRING (str
)->data
);
395 load_unwind (stream
) /* used as unwind-protect function in load */
398 fclose (*(FILE **) XSTRING (stream
));
399 xfree (XPNTR (stream
));
400 if (--load_in_progress
< 0) load_in_progress
= 0;
406 complete_filename_p (pathname
)
407 Lisp_Object pathname
;
409 register unsigned char *s
= XSTRING (pathname
)->data
;
420 /* Search for a file whose name is STR, looking in directories
421 in the Lisp list PATH, and trying suffixes from SUFFIX.
422 SUFFIX is a string containing possible suffixes separated by colons.
423 On success, returns a file descriptor. On failure, returns -1.
425 EXEC_ONLY nonzero means don't open the files,
426 just look for one that is executable. In this case,
427 returns 1 on success.
429 If STOREPTR is nonzero, it points to a slot where the name of
430 the file actually found should be stored as a Lisp string.
431 Nil is stored there on failure. */
434 openp (path
, str
, suffix
, storeptr
, exec_only
)
435 Lisp_Object path
, str
;
437 Lisp_Object
*storeptr
;
443 register char *fn
= buf
;
446 register Lisp_Object filename
;
452 if (complete_filename_p (str
))
455 for (; !NILP (path
); path
= Fcdr (path
))
459 filename
= Fexpand_file_name (str
, Fcar (path
));
460 if (!complete_filename_p (filename
))
461 /* If there are non-absolute elts in PATH (eg ".") */
462 /* Of course, this could conceivably lose if luser sets
463 default-directory to be something non-absolute... */
465 filename
= Fexpand_file_name (filename
, current_buffer
->directory
);
466 if (!complete_filename_p (filename
))
467 /* Give up on this path element! */
471 /* Calculate maximum size of any filename made from
472 this path element/specified file name and any possible suffix. */
473 want_size
= strlen (suffix
) + XSTRING (filename
)->size
+ 1;
474 if (fn_size
< want_size
)
475 fn
= (char *) alloca (fn_size
= 100 + want_size
);
479 /* Loop over suffixes. */
482 char *esuffix
= (char *) index (nsuffix
, ':');
483 int lsuffix
= esuffix
? esuffix
- nsuffix
: strlen (nsuffix
);
485 /* Concatenate path element/specified name with the suffix. */
486 strncpy (fn
, XSTRING (filename
)->data
, XSTRING (filename
)->size
);
487 fn
[XSTRING (filename
)->size
] = 0;
488 if (lsuffix
!= 0) /* Bug happens on CCI if lsuffix is 0. */
489 strncat (fn
, nsuffix
, lsuffix
);
491 /* Ignore file if it's a directory. */
492 if (stat (fn
, &st
) >= 0
493 && (st
.st_mode
& S_IFMT
) != S_IFDIR
)
495 /* Check that we can access or open it. */
497 fd
= (access (fn
, X_OK
) == 0) ? 1 : -1;
499 fd
= open (fn
, 0, 0);
503 /* We succeeded; return this descriptor and filename. */
505 *storeptr
= build_string (fn
);
510 /* Advance to next suffix. */
513 nsuffix
+= lsuffix
+ 1;
515 if (absolute
) return -1;
522 /* Merge the list we've accumulated of globals from the current input source
523 into the load_history variable. The details depend on whether
524 the source has an associated file name or not. */
527 build_load_history (stream
, source
)
531 register Lisp_Object tail
, prev
, newelt
;
532 register Lisp_Object tem
, tem2
;
533 register int foundit
, loading
;
535 loading
= stream
|| !NARROWED
;
537 tail
= Vload_history
;
544 /* Find the feature's previous assoc list... */
545 if (!NILP (Fequal (source
, Fcar (tem
))))
549 /* If we're loading, remove it. */
553 Vload_history
= Fcdr (tail
);
555 Fsetcdr (prev
, Fcdr (tail
));
558 /* Otherwise, cons on new symbols that are not already members. */
561 tem2
= Vcurrent_load_list
;
565 newelt
= Fcar (tem2
);
567 if (NILP (Fmemq (newelt
, tem
)))
568 Fsetcar (tail
, Fcons (Fcar (tem
),
569 Fcons (newelt
, Fcdr (tem
))));
582 /* If we're loading, cons the new assoc onto the front of load-history,
583 the most-recently-loaded position. Also do this if we didn't find
584 an existing member for the current source. */
585 if (loading
|| !foundit
)
586 Vload_history
= Fcons (Fnreverse(Vcurrent_load_list
),
591 unreadpure () /* Used as unwind-protect function in readevalloop */
598 readevalloop (readcharfun
, stream
, sourcename
, evalfun
, printflag
)
599 Lisp_Object readcharfun
;
601 Lisp_Object sourcename
;
602 Lisp_Object (*evalfun
) ();
606 register Lisp_Object val
;
608 int count
= specpdl_ptr
- specpdl
;
609 struct gcpro gcpro1
, gcpro2
;
611 specbind (Qstandard_input
, readcharfun
);
613 oldlist
= Vcurrent_load_list
;
614 GCPRO2 (sourcename
, oldlist
);
616 Vcurrent_load_list
= Qnil
;
617 LOADHIST_ATTACH (sourcename
);
625 while ((c
= READCHAR
) != '\n' && c
!= -1);
629 if (c
== ' ' || c
== '\t' || c
== '\n' || c
== '\f') continue;
631 if (!NILP (Vpurify_flag
) && c
== '(')
633 record_unwind_protect (unreadpure
, Qnil
);
634 val
= read_list (-1, readcharfun
);
635 unbind_to (count
+ 1, Qnil
);
640 val
= read0 (readcharfun
);
643 val
= (*evalfun
) (val
);
646 Vvalues
= Fcons (val
, Vvalues
);
647 if (EQ (Vstandard_output
, Qt
))
654 build_load_history (stream
, sourcename
);
656 Vcurrent_load_list
= oldlist
;
659 unbind_to (count
, Qnil
);
664 DEFUN ("eval-buffer", Feval_buffer
, Seval_buffer
, 0, 2, "",
665 "Execute the current buffer as Lisp code.\n\
666 Programs can pass two arguments, BUFFER and PRINTFLAG.\n\
667 BUFFER is the buffer to evaluate (nil means use current buffer).\n\
668 PRINTFLAG controls printing of output:\n\
669 nil means discard it; anything else is stream for print.\n\
671 If there is no error, point does not move. If there is an error,\n\
672 point remains at the end of the last character read from the buffer.")
674 Lisp_Object bufname
, printflag
;
676 int count
= specpdl_ptr
- specpdl
;
677 Lisp_Object tem
, buf
;
680 buf
= Fcurrent_buffer ();
682 buf
= Fget_buffer (bufname
);
684 error ("No such buffer.");
686 if (NILP (printflag
))
690 specbind (Qstandard_output
, tem
);
691 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
692 BUF_SET_PT (XBUFFER (buf
), BUF_BEGV (XBUFFER (buf
)));
693 readevalloop (buf
, 0, XBUFFER (buf
)->filename
, Feval
, !NILP (printflag
));
694 unbind_to (count
, Qnil
);
700 DEFUN ("eval-current-buffer", Feval_current_buffer
, Seval_current_buffer
, 0, 1, "",
701 "Execute the current buffer as Lisp code.\n\
702 Programs can pass argument PRINTFLAG which controls printing of output:\n\
703 nil means discard it; anything else is stream for print.\n\
705 If there is no error, point does not move. If there is an error,\n\
706 point remains at the end of the last character read from the buffer.")
708 Lisp_Object printflag
;
710 int count
= specpdl_ptr
- specpdl
;
711 Lisp_Object tem
, cbuf
;
713 cbuf
= Fcurrent_buffer ()
715 if (NILP (printflag
))
719 specbind (Qstandard_output
, tem
);
720 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
722 readevalloop (cbuf
, 0, XBUFFER (cbuf
)->filename
, Feval
, !NILP (printflag
));
723 return unbind_to (count
, Qnil
);
727 DEFUN ("eval-region", Feval_region
, Seval_region
, 2, 3, "r",
728 "Execute the region as Lisp code.\n\
729 When called from programs, expects two arguments,\n\
730 giving starting and ending indices in the current buffer\n\
731 of the text to be executed.\n\
732 Programs can pass third argument PRINTFLAG which controls output:\n\
733 nil means discard it; anything else is stream for printing it.\n\
735 If there is no error, point does not move. If there is an error,\n\
736 point remains at the end of the last character read from the buffer.")
738 Lisp_Object b
, e
, printflag
;
740 int count
= specpdl_ptr
- specpdl
;
741 Lisp_Object tem
, cbuf
;
743 cbuf
= Fcurrent_buffer ();
745 if (NILP (printflag
))
749 specbind (Qstandard_output
, tem
);
751 if (NILP (printflag
))
752 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
753 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
755 /* This both uses b and checks its type. */
757 Fnarrow_to_region (make_number (BEGV
), e
);
758 readevalloop (cbuf
, 0, XBUFFER (cbuf
)->filename
, Feval
, !NILP (printflag
));
760 return unbind_to (count
, Qnil
);
763 #endif /* standalone */
765 DEFUN ("read", Fread
, Sread
, 0, 1, 0,
766 "Read one Lisp expression as text from STREAM, return as Lisp object.\n\
767 If STREAM is nil, use the value of `standard-input' (which see).\n\
768 STREAM or the value of `standard-input' may be:\n\
769 a buffer (read from point and advance it)\n\
770 a marker (read from where it points and advance it)\n\
771 a function (call it with no arguments for each character,\n\
772 call it with a char as argument to push a char back)\n\
773 a string (takes text from string, starting at the beginning)\n\
774 t (read text line using minibuffer and use it).")
776 Lisp_Object readcharfun
;
778 extern Lisp_Object
Fread_minibuffer ();
780 if (NILP (readcharfun
))
781 readcharfun
= Vstandard_input
;
782 if (EQ (readcharfun
, Qt
))
783 readcharfun
= Qread_char
;
786 if (EQ (readcharfun
, Qread_char
))
787 return Fread_minibuffer (build_string ("Lisp expression: "), Qnil
);
790 if (XTYPE (readcharfun
) == Lisp_String
)
791 return Fcar (Fread_from_string (readcharfun
, Qnil
, Qnil
));
793 return read0 (readcharfun
);
796 DEFUN ("read-from-string", Fread_from_string
, Sread_from_string
, 1, 3, 0,
797 "Read one Lisp expression which is represented as text by STRING.\n\
798 Returns a cons: (OBJECT-READ . FINAL-STRING-INDEX).\n\
799 START and END optionally delimit a substring of STRING from which to read;\n\
800 they default to 0 and (length STRING) respectively.")
802 Lisp_Object string
, start
, end
;
804 int startval
, endval
;
807 CHECK_STRING (string
,0);
810 endval
= XSTRING (string
)->size
;
812 { CHECK_NUMBER (end
,2);
814 if (endval
< 0 || endval
> XSTRING (string
)->size
)
815 args_out_of_range (string
, end
);
821 { CHECK_NUMBER (start
,1);
822 startval
= XINT (start
);
823 if (startval
< 0 || startval
> endval
)
824 args_out_of_range (string
, start
);
827 read_from_string_index
= startval
;
828 read_from_string_limit
= endval
;
830 tem
= read0 (string
);
831 return Fcons (tem
, make_number (read_from_string_index
));
834 /* Use this for recursive reads, in contexts where internal tokens are not allowed. */
838 Lisp_Object readcharfun
;
840 register Lisp_Object val
;
843 val
= read1 (readcharfun
);
844 if (XTYPE (val
) == Lisp_Internal
)
847 return Fsignal (Qinvalid_read_syntax
, Fcons (make_string (&c
, 1), Qnil
));
853 static int read_buffer_size
;
854 static char *read_buffer
;
857 read_escape (readcharfun
)
858 Lisp_Object readcharfun
;
860 register int c
= READCHAR
;
887 error ("Invalid escape character syntax");
890 c
= read_escape (readcharfun
);
891 return c
| meta_modifier
;
896 error ("Invalid escape character syntax");
899 c
= read_escape (readcharfun
);
900 return c
| shift_modifier
;
905 error ("Invalid escape character syntax");
908 c
= read_escape (readcharfun
);
909 return c
| hyper_modifier
;
914 error ("Invalid escape character syntax");
917 c
= read_escape (readcharfun
);
918 return c
| alt_modifier
;
923 error ("Invalid escape character syntax");
926 c
= read_escape (readcharfun
);
927 return c
| super_modifier
;
932 error ("Invalid escape character syntax");
936 c
= read_escape (readcharfun
);
937 if ((c
& 0177) == '?')
939 /* ASCII control chars are made from letters (both cases),
940 as well as the non-letters within 0100...0137. */
941 else if ((c
& 0137) >= 0101 && (c
& 0137) <= 0132)
942 return (c
& (037 | ~0177));
943 else if ((c
& 0177) >= 0100 && (c
& 0177) <= 0137)
944 return (c
& (037 | ~0177));
946 return c
| ctrl_modifier
;
956 /* An octal escape, as in ANSI C. */
958 register int i
= c
- '0';
959 register int count
= 0;
962 if ((c
= READCHAR
) >= '0' && c
<= '7')
977 /* A hex escape, as in ANSI C. */
983 if (c
>= '0' && c
<= '9')
988 else if ((c
>= 'a' && c
<= 'f')
989 || (c
>= 'A' && c
<= 'F'))
992 if (c
>= 'a' && c
<= 'f')
1013 register Lisp_Object readcharfun
;
1020 if (c
< 0) return Fsignal (Qend_of_file
, Qnil
);
1025 return read_list (0, readcharfun
);
1028 return read_vector (readcharfun
);
1033 register Lisp_Object val
;
1034 XSET (val
, Lisp_Internal
, c
);
1042 /* Accept compiled functions at read-time so that we don't have to
1043 build them using function calls. */
1045 tmp
= read_vector (readcharfun
);
1046 return Fmake_byte_code (XVECTOR (tmp
)->size
,
1047 XVECTOR (tmp
)->contents
);
1049 #ifdef USE_TEXT_PROPERTIES
1053 struct gcpro gcpro1
;
1055 /* Read the string itself. */
1056 tmp
= read1 (readcharfun
);
1057 if (XTYPE (tmp
) != Lisp_String
)
1058 Fsignal (Qinvalid_read_syntax
, Fcons (make_string ("#", 1), Qnil
));
1060 /* Read the intervals and their properties. */
1063 Lisp_Object beg
, end
, plist
;
1065 beg
= read1 (readcharfun
);
1066 if (XTYPE (beg
) == Lisp_Internal
)
1068 if (XINT (beg
) == ')')
1070 Fsignal (Qinvalid_read_syntax
, Fcons (make_string ("invalid string property list", 28), Qnil
));
1072 end
= read1 (readcharfun
);
1073 if (XTYPE (end
) == Lisp_Internal
)
1074 Fsignal (Qinvalid_read_syntax
,
1075 Fcons (make_string ("invalid string property list", 28), Qnil
));
1077 plist
= read1 (readcharfun
);
1078 if (XTYPE (plist
) == Lisp_Internal
)
1079 Fsignal (Qinvalid_read_syntax
,
1080 Fcons (make_string ("invalid string property list", 28), Qnil
));
1081 Fset_text_properties (beg
, end
, plist
, tmp
);
1088 Fsignal (Qinvalid_read_syntax
, Fcons (make_string ("#", 1), Qnil
));
1091 while ((c
= READCHAR
) >= 0 && c
!= '\n');
1096 return Fcons (Qquote
, Fcons (read0 (readcharfun
), Qnil
));
1101 register Lisp_Object val
;
1104 if (c
< 0) return Fsignal (Qend_of_file
, Qnil
);
1107 XSET (val
, Lisp_Int
, read_escape (readcharfun
));
1109 XSET (val
, Lisp_Int
, c
);
1116 register char *p
= read_buffer
;
1117 register char *end
= read_buffer
+ read_buffer_size
;
1121 while ((c
= READCHAR
) >= 0
1126 char *new = (char *) xrealloc (read_buffer
, read_buffer_size
*= 2);
1127 p
+= new - read_buffer
;
1128 read_buffer
+= new - read_buffer
;
1129 end
= read_buffer
+ read_buffer_size
;
1132 c
= read_escape (readcharfun
);
1133 /* c is -1 if \ newline has just been seen */
1136 if (p
== read_buffer
)
1139 else if (c
& CHAR_META
)
1140 /* Move the meta bit to the right place for a string. */
1141 *p
++ = (c
& ~CHAR_META
) | 0x80;
1145 if (c
< 0) return Fsignal (Qend_of_file
, Qnil
);
1147 /* If purifying, and string starts with \ newline,
1148 return zero instead. This is for doc strings
1149 that we are really going to find in etc/DOC.nn.nn */
1150 if (!NILP (Vpurify_flag
) && NILP (Vdoc_file_name
) && cancel
)
1151 return make_number (0);
1154 return make_pure_string (read_buffer
, p
- read_buffer
);
1156 return make_string (read_buffer
, p
- read_buffer
);
1161 #ifdef LISP_FLOAT_TYPE
1162 /* If a period is followed by a number, then we should read it
1163 as a floating point number. Otherwise, it denotes a dotted
1165 int next_char
= READCHAR
;
1168 if (! isdigit (next_char
))
1171 register Lisp_Object val
;
1172 XSET (val
, Lisp_Internal
, c
);
1176 /* Otherwise, we fall through! Note that the atom-reading loop
1177 below will now loop at least once, assuring that we will not
1178 try to UNREAD two characters in a row. */
1181 if (c
<= 040) goto retry
;
1183 register char *p
= read_buffer
;
1186 register char *end
= read_buffer
+ read_buffer_size
;
1189 !(c
== '\"' || c
== '\'' || c
== ';' || c
== '?'
1190 || c
== '(' || c
== ')'
1191 #ifndef LISP_FLOAT_TYPE
1192 /* If we have floating-point support, then we need
1193 to allow <digits><dot><digits>. */
1195 #endif /* not LISP_FLOAT_TYPE */
1196 || c
== '[' || c
== ']' || c
== '#'
1201 register char *new = (char *) xrealloc (read_buffer
, read_buffer_size
*= 2);
1202 p
+= new - read_buffer
;
1203 read_buffer
+= new - read_buffer
;
1204 end
= read_buffer
+ read_buffer_size
;
1214 char *new = (char *) xrealloc (read_buffer
, read_buffer_size
*= 2);
1215 p
+= new - read_buffer
;
1216 read_buffer
+= new - read_buffer
;
1217 /* end = read_buffer + read_buffer_size; */
1224 /* Is it an integer? */
1227 register Lisp_Object val
;
1229 if (*p1
== '+' || *p1
== '-') p1
++;
1232 while (p1
!= p
&& (c
= *p1
) >= '0' && c
<= '9') p1
++;
1233 #ifdef LISP_FLOAT_TYPE
1234 /* Integers can have trailing decimal points. */
1235 if (p1
> read_buffer
&& p1
< p
&& *p1
== '.') p1
++;
1238 /* It is an integer. */
1240 #ifdef LISP_FLOAT_TYPE
1244 XSET (val
, Lisp_Int
, atoi (read_buffer
));
1248 #ifdef LISP_FLOAT_TYPE
1249 if (isfloat_string (read_buffer
))
1250 return make_float (atof (read_buffer
));
1254 return intern (read_buffer
);
1259 #ifdef LISP_FLOAT_TYPE
1274 if (*cp
== '+' || *cp
== '-')
1280 while (isdigit (*cp
))
1291 while (isdigit (*cp
))
1299 if ((*cp
== '+') || (*cp
== '-'))
1305 while (isdigit (*cp
))
1309 && (state
== (LEAD_INT
|DOT_CHAR
|TRAIL_INT
)
1310 || state
== (DOT_CHAR
|TRAIL_INT
)
1311 || state
== (LEAD_INT
|E_CHAR
|EXP_INT
)
1312 || state
== (LEAD_INT
|DOT_CHAR
|TRAIL_INT
|E_CHAR
|EXP_INT
)
1313 || state
== (DOT_CHAR
|TRAIL_INT
|E_CHAR
|EXP_INT
)));
1315 #endif /* LISP_FLOAT_TYPE */
1318 read_vector (readcharfun
)
1319 Lisp_Object readcharfun
;
1323 register Lisp_Object
*ptr
;
1324 register Lisp_Object tem
, vector
;
1325 register struct Lisp_Cons
*otem
;
1328 tem
= read_list (1, readcharfun
);
1329 len
= Flength (tem
);
1330 vector
= (read_pure
? make_pure_vector (XINT (len
)) : Fmake_vector (len
, Qnil
));
1333 size
= XVECTOR (vector
)->size
;
1334 ptr
= XVECTOR (vector
)->contents
;
1335 for (i
= 0; i
< size
; i
++)
1337 ptr
[i
] = read_pure
? Fpurecopy (Fcar (tem
)) : Fcar (tem
);
1345 /* flag = 1 means check for ] to terminate rather than ) and .
1346 flag = -1 means check for starting with defun
1347 and make structure pure. */
1350 read_list (flag
, readcharfun
)
1352 register Lisp_Object readcharfun
;
1354 /* -1 means check next element for defun,
1355 0 means don't check,
1356 1 means already checked and found defun. */
1357 int defunflag
= flag
< 0 ? -1 : 0;
1358 Lisp_Object val
, tail
;
1359 register Lisp_Object elt
, tem
;
1360 struct gcpro gcpro1
, gcpro2
;
1368 elt
= read1 (readcharfun
);
1370 if (XTYPE (elt
) == Lisp_Internal
)
1374 if (XINT (elt
) == ']')
1376 return Fsignal (Qinvalid_read_syntax
, Fcons (make_string (") or . in a vector", 18), Qnil
));
1378 if (XINT (elt
) == ')')
1380 if (XINT (elt
) == '.')
1384 XCONS (tail
)->cdr
= read0 (readcharfun
);
1386 val
= read0 (readcharfun
);
1387 elt
= read1 (readcharfun
);
1389 if (XTYPE (elt
) == Lisp_Internal
&& XINT (elt
) == ')')
1391 return Fsignal (Qinvalid_read_syntax
, Fcons (make_string (". in wrong context", 18), Qnil
));
1393 return Fsignal (Qinvalid_read_syntax
, Fcons (make_string ("] in a list", 11), Qnil
));
1395 tem
= (read_pure
&& flag
<= 0
1396 ? pure_cons (elt
, Qnil
)
1397 : Fcons (elt
, Qnil
));
1399 XCONS (tail
)->cdr
= tem
;
1404 defunflag
= EQ (elt
, Qdefun
);
1405 else if (defunflag
> 0)
1410 Lisp_Object Vobarray
;
1411 Lisp_Object initial_obarray
;
1414 check_obarray (obarray
)
1415 Lisp_Object obarray
;
1417 while (XTYPE (obarray
) != Lisp_Vector
|| XVECTOR (obarray
)->size
== 0)
1419 /* If Vobarray is now invalid, force it to be valid. */
1420 if (EQ (Vobarray
, obarray
)) Vobarray
= initial_obarray
;
1422 obarray
= wrong_type_argument (Qvectorp
, obarray
);
1427 static int hash_string ();
1428 Lisp_Object
oblookup ();
1435 int len
= strlen (str
);
1436 Lisp_Object obarray
= Vobarray
;
1438 if (XTYPE (obarray
) != Lisp_Vector
|| XVECTOR (obarray
)->size
== 0)
1439 obarray
= check_obarray (obarray
);
1440 tem
= oblookup (obarray
, str
, len
);
1441 if (XTYPE (tem
) == Lisp_Symbol
)
1443 return Fintern ((!NILP (Vpurify_flag
)
1444 ? make_pure_string (str
, len
)
1445 : make_string (str
, len
)),
1449 DEFUN ("intern", Fintern
, Sintern
, 1, 2, 0,
1450 "Return the canonical symbol whose name is STRING.\n\
1451 If there is none, one is created by this function and returned.\n\
1452 A second optional argument specifies the obarray to use;\n\
1453 it defaults to the value of `obarray'.")
1455 Lisp_Object str
, obarray
;
1457 register Lisp_Object tem
, sym
, *ptr
;
1459 if (NILP (obarray
)) obarray
= Vobarray
;
1460 obarray
= check_obarray (obarray
);
1462 CHECK_STRING (str
, 0);
1464 tem
= oblookup (obarray
, XSTRING (str
)->data
, XSTRING (str
)->size
);
1465 if (XTYPE (tem
) != Lisp_Int
)
1468 if (!NILP (Vpurify_flag
))
1469 str
= Fpurecopy (str
);
1470 sym
= Fmake_symbol (str
);
1472 ptr
= &XVECTOR (obarray
)->contents
[XINT (tem
)];
1473 if (XTYPE (*ptr
) == Lisp_Symbol
)
1474 XSYMBOL (sym
)->next
= XSYMBOL (*ptr
);
1476 XSYMBOL (sym
)->next
= 0;
1481 DEFUN ("intern-soft", Fintern_soft
, Sintern_soft
, 1, 2, 0,
1482 "Return the canonical symbol whose name is STRING, or nil if none exists.\n\
1483 A second optional argument specifies the obarray to use;\n\
1484 it defaults to the value of `obarray'.")
1486 Lisp_Object str
, obarray
;
1488 register Lisp_Object tem
;
1490 if (NILP (obarray
)) obarray
= Vobarray
;
1491 obarray
= check_obarray (obarray
);
1493 CHECK_STRING (str
, 0);
1495 tem
= oblookup (obarray
, XSTRING (str
)->data
, XSTRING (str
)->size
);
1496 if (XTYPE (tem
) != Lisp_Int
)
1502 oblookup (obarray
, ptr
, size
)
1503 Lisp_Object obarray
;
1508 register Lisp_Object tail
;
1509 Lisp_Object bucket
, tem
;
1511 if (XTYPE (obarray
) != Lisp_Vector
||
1512 (obsize
= XVECTOR (obarray
)->size
) == 0)
1514 obarray
= check_obarray (obarray
);
1515 obsize
= XVECTOR (obarray
)->size
;
1517 /* Combining next two lines breaks VMS C 2.3. */
1518 hash
= hash_string (ptr
, size
);
1520 bucket
= XVECTOR (obarray
)->contents
[hash
];
1521 if (XFASTINT (bucket
) == 0)
1523 else if (XTYPE (bucket
) != Lisp_Symbol
)
1524 error ("Bad data in guts of obarray"); /* Like CADR error message */
1525 else for (tail
= bucket
; ; XSET (tail
, Lisp_Symbol
, XSYMBOL (tail
)->next
))
1527 if (XSYMBOL (tail
)->name
->size
== size
&&
1528 !bcmp (XSYMBOL (tail
)->name
->data
, ptr
, size
))
1530 else if (XSYMBOL (tail
)->next
== 0)
1533 XSET (tem
, Lisp_Int
, hash
);
1538 hash_string (ptr
, len
)
1542 register unsigned char *p
= ptr
;
1543 register unsigned char *end
= p
+ len
;
1544 register unsigned char c
;
1545 register int hash
= 0;
1550 if (c
>= 0140) c
-= 40;
1551 hash
= ((hash
<<3) + (hash
>>28) + c
);
1553 return hash
& 07777777777;
1557 map_obarray (obarray
, fn
, arg
)
1558 Lisp_Object obarray
;
1563 register Lisp_Object tail
;
1564 CHECK_VECTOR (obarray
, 1);
1565 for (i
= XVECTOR (obarray
)->size
- 1; i
>= 0; i
--)
1567 tail
= XVECTOR (obarray
)->contents
[i
];
1568 if (XFASTINT (tail
) != 0)
1572 if (XSYMBOL (tail
)->next
== 0)
1574 XSET (tail
, Lisp_Symbol
, XSYMBOL (tail
)->next
);
1579 mapatoms_1 (sym
, function
)
1580 Lisp_Object sym
, function
;
1582 call1 (function
, sym
);
1585 DEFUN ("mapatoms", Fmapatoms
, Smapatoms
, 1, 2, 0,
1586 "Call FUNCTION on every symbol in OBARRAY.\n\
1587 OBARRAY defaults to the value of `obarray'.")
1589 Lisp_Object function
, obarray
;
1593 if (NILP (obarray
)) obarray
= Vobarray
;
1594 obarray
= check_obarray (obarray
);
1596 map_obarray (obarray
, mapatoms_1
, function
);
1600 #define OBARRAY_SIZE 509
1605 Lisp_Object oblength
;
1609 XFASTINT (oblength
) = OBARRAY_SIZE
;
1611 Qnil
= Fmake_symbol (make_pure_string ("nil", 3));
1612 Vobarray
= Fmake_vector (oblength
, make_number (0));
1613 initial_obarray
= Vobarray
;
1614 staticpro (&initial_obarray
);
1615 /* Intern nil in the obarray */
1616 /* These locals are to kludge around a pyramid compiler bug. */
1617 hash
= hash_string ("nil", 3);
1618 /* Separate statement here to avoid VAXC bug. */
1619 hash
%= OBARRAY_SIZE
;
1620 tem
= &XVECTOR (Vobarray
)->contents
[hash
];
1623 Qunbound
= Fmake_symbol (make_pure_string ("unbound", 7));
1624 XSYMBOL (Qnil
)->function
= Qunbound
;
1625 XSYMBOL (Qunbound
)->value
= Qunbound
;
1626 XSYMBOL (Qunbound
)->function
= Qunbound
;
1629 XSYMBOL (Qnil
)->value
= Qnil
;
1630 XSYMBOL (Qnil
)->plist
= Qnil
;
1631 XSYMBOL (Qt
)->value
= Qt
;
1633 /* Qt is correct even if CANNOT_DUMP. loadup.el will set to nil at end. */
1636 Qvariable_documentation
= intern ("variable-documentation");
1638 read_buffer_size
= 100;
1639 read_buffer
= (char *) malloc (read_buffer_size
);
1644 struct Lisp_Subr
*sname
;
1647 sym
= intern (sname
->symbol_name
);
1648 XSET (XSYMBOL (sym
)->function
, Lisp_Subr
, sname
);
1651 #ifdef NOTDEF /* use fset in subr.el now */
1653 defalias (sname
, string
)
1654 struct Lisp_Subr
*sname
;
1658 sym
= intern (string
);
1659 XSET (XSYMBOL (sym
)->function
, Lisp_Subr
, sname
);
1663 /* New replacement for DefIntVar; it ignores the doc string argument
1664 on the assumption that make-docfile will handle that. */
1665 /* Define an "integer variable"; a symbol whose value is forwarded
1666 to a C variable of type int. Sample call: */
1667 /* DEFVARINT ("indent-tabs-mode", &indent_tabs_mode, "Documentation"); */
1670 defvar_int (namestring
, address
, doc
)
1676 sym
= intern (namestring
);
1677 XSET (XSYMBOL (sym
)->value
, Lisp_Intfwd
, address
);
1680 /* Similar but define a variable whose value is T if address contains 1,
1681 NIL if address contains 0 */
1684 defvar_bool (namestring
, address
, doc
)
1690 sym
= intern (namestring
);
1691 XSET (XSYMBOL (sym
)->value
, Lisp_Boolfwd
, address
);
1694 /* Similar but define a variable whose value is the Lisp Object stored at address. */
1697 defvar_lisp (namestring
, address
, doc
)
1699 Lisp_Object
*address
;
1703 sym
= intern (namestring
);
1704 XSET (XSYMBOL (sym
)->value
, Lisp_Objfwd
, address
);
1705 staticpro (address
);
1708 /* Similar but don't request gc-marking of the C variable.
1709 Used when that variable will be gc-marked for some other reason,
1710 since marking the same slot twice can cause trouble with strings. */
1713 defvar_lisp_nopro (namestring
, address
, doc
)
1715 Lisp_Object
*address
;
1719 sym
= intern (namestring
);
1720 XSET (XSYMBOL (sym
)->value
, Lisp_Objfwd
, address
);
1725 /* Similar but define a variable whose value is the Lisp Object stored in
1726 the current buffer. address is the address of the slot in the buffer that is current now. */
1729 defvar_per_buffer (namestring
, address
, type
, doc
)
1731 Lisp_Object
*address
;
1737 extern struct buffer buffer_local_symbols
;
1739 sym
= intern (namestring
);
1740 offset
= (char *)address
- (char *)current_buffer
;
1742 XSET (XSYMBOL (sym
)->value
, Lisp_Buffer_Objfwd
,
1743 (Lisp_Object
*) offset
);
1744 *(Lisp_Object
*)(offset
+ (char *)&buffer_local_symbols
) = sym
;
1745 *(Lisp_Object
*)(offset
+ (char *)&buffer_local_types
) = type
;
1746 if (*(int *)(offset
+ (char *)&buffer_local_flags
) == 0)
1747 /* Did a DEFVAR_PER_BUFFER without initializing the corresponding
1748 slot of buffer_local_flags */
1752 #endif /* standalone */
1758 /* Compute the default load-path. */
1760 normal
= PATH_LOADSEARCH
;
1761 Vload_path
= decode_env_path (0, normal
);
1763 if (NILP (Vpurify_flag
))
1764 normal
= PATH_LOADSEARCH
;
1766 normal
= PATH_DUMPLOADSEARCH
;
1768 /* In a dumped Emacs, we normally have to reset the value of
1769 Vload_path from PATH_LOADSEARCH, since the value that was dumped
1770 uses ../lisp, instead of the path of the installed elisp
1771 libraries. However, if it appears that Vload_path was changed
1772 from the default before dumping, don't override that value. */
1775 Lisp_Object dump_path
;
1777 dump_path
= decode_env_path (0, PATH_DUMPLOADSEARCH
);
1778 if (! NILP (Fequal (dump_path
, Vload_path
)))
1779 Vload_path
= decode_env_path (0, normal
);
1782 Vload_path
= decode_env_path (0, normal
);
1785 /* Warn if dirs in the *standard* path don't exist. */
1787 Lisp_Object path_tail
;
1789 for (path_tail
= Vload_path
;
1791 path_tail
= XCONS (path_tail
)->cdr
)
1793 Lisp_Object dirfile
;
1794 dirfile
= Fcar (path_tail
);
1795 if (XTYPE (dirfile
) == Lisp_String
)
1797 dirfile
= Fdirectory_file_name (dirfile
);
1798 if (access (XSTRING (dirfile
)->data
, 0) < 0)
1799 printf ("Warning: lisp library (%s) does not exist.\n",
1800 XSTRING (Fcar (path_tail
))->data
);
1805 /* If the EMACSLOADPATH environment variable is set, use its value.
1806 This doesn't apply if we're dumping. */
1807 if (NILP (Vpurify_flag
)
1808 && egetenv ("EMACSLOADPATH"))
1809 Vload_path
= decode_env_path ("EMACSLOADPATH", normal
);
1813 load_in_progress
= 0;
1820 defsubr (&Sread_from_string
);
1822 defsubr (&Sintern_soft
);
1824 defsubr (&Seval_buffer
);
1825 defsubr (&Seval_region
);
1826 defsubr (&Sread_char
);
1827 defsubr (&Sread_char_exclusive
);
1828 defsubr (&Sread_event
);
1829 defsubr (&Sget_file_char
);
1830 defsubr (&Smapatoms
);
1832 DEFVAR_LISP ("obarray", &Vobarray
,
1833 "Symbol table for use by `intern' and `read'.\n\
1834 It is a vector whose length ought to be prime for best results.\n\
1835 The vector's contents don't make sense if examined from Lisp programs;\n\
1836 to find all the symbols in an obarray, use `mapatoms'.");
1838 DEFVAR_LISP ("values", &Vvalues
,
1839 "List of values of all expressions which were read, evaluated and printed.\n\
1840 Order is reverse chronological.");
1842 DEFVAR_LISP ("standard-input", &Vstandard_input
,
1843 "Stream for read to get input from.\n\
1844 See documentation of `read' for possible values.");
1845 Vstandard_input
= Qt
;
1847 DEFVAR_LISP ("load-path", &Vload_path
,
1848 "*List of directories to search for files to load.\n\
1849 Each element is a string (directory name) or nil (try default directory).\n\
1850 Initialized based on EMACSLOADPATH environment variable, if any,\n\
1851 otherwise to default specified by file `paths.h' when Emacs was built.");
1853 DEFVAR_BOOL ("load-in-progress", &load_in_progress
,
1854 "Non-nil iff inside of `load'.");
1856 DEFVAR_LISP ("after-load-alist", &Vafter_load_alist
,
1857 "An alist of expressions to be evalled when particular files are loaded.\n\
1858 Each element looks like (FILENAME FORMS...).\n\
1859 When `load' is run and the file-name argument is FILENAME,\n\
1860 the FORMS in the corresponding element are executed at the end of loading.\n\n\
1861 FILENAME must match exactly! Normally FILENAME is the name of a library,\n\
1862 with no directory specified, since that is how `load' is normally called.\n\
1863 An error in FORMS does not undo the load,\n\
1864 but does prevent execution of the rest of the FORMS.");
1865 Vafter_load_alist
= Qnil
;
1867 DEFVAR_LISP ("load-history", &Vload_history
,
1868 "Alist mapping source file names to symbols and features.\n\
1869 Each alist element is a list that starts with a file name,\n\
1870 except for one element (optional) that starts with nil and describes\n\
1871 definitions evaluated from buffers not visiting files.\n\
1872 The remaining elements of each list are symbols defined as functions\n\
1873 or variables, and cons cells `(provide . FEATURE)' and `(require . FEATURE)'.");
1874 Vload_history
= Qnil
;
1876 staticpro (&Vcurrent_load_list
);
1877 Vcurrent_load_list
= Qnil
;
1879 Qstandard_input
= intern ("standard-input");
1880 staticpro (&Qstandard_input
);
1882 Qread_char
= intern ("read-char");
1883 staticpro (&Qread_char
);
1885 Qget_file_char
= intern ("get-file-char");
1886 staticpro (&Qget_file_char
);
1888 Qascii_character
= intern ("ascii-character");
1889 staticpro (&Qascii_character
);