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 /* File for get_file_char to read from. Use by load */
64 static FILE *instream
;
66 /* When nonzero, read conses in pure space */
69 /* For use within read-from-string (this reader is non-reentrant!!) */
70 static int read_from_string_index
;
71 static int read_from_string_limit
;
73 /* Handle unreading and rereading of characters.
74 Write READCHAR to read a character,
75 UNREAD(c) to unread c to be read again. */
77 #define READCHAR readchar (readcharfun)
78 #define UNREAD(c) unreadchar (readcharfun, c)
81 readchar (readcharfun
)
82 Lisp_Object readcharfun
;
85 register struct buffer
*inbuffer
;
88 if (XTYPE (readcharfun
) == Lisp_Buffer
)
90 inbuffer
= XBUFFER (readcharfun
);
92 if (BUF_PT (inbuffer
) >= BUF_ZV (inbuffer
))
94 c
= *(unsigned char *) BUF_CHAR_ADDRESS (inbuffer
, BUF_PT (inbuffer
));
95 SET_BUF_PT (inbuffer
, BUF_PT (inbuffer
) + 1);
99 if (XTYPE (readcharfun
) == Lisp_Marker
)
101 inbuffer
= XMARKER (readcharfun
)->buffer
;
103 mpos
= marker_position (readcharfun
);
105 if (mpos
> BUF_ZV (inbuffer
) - 1)
107 c
= *(unsigned char *) BUF_CHAR_ADDRESS (inbuffer
, mpos
);
108 if (mpos
!= BUF_GPT (inbuffer
))
109 XMARKER (readcharfun
)->bufpos
++;
111 Fset_marker (readcharfun
, make_number (mpos
+ 1),
112 Fmarker_buffer (readcharfun
));
115 if (EQ (readcharfun
, Qget_file_char
))
116 return getc (instream
);
118 if (XTYPE (readcharfun
) == Lisp_String
)
121 /* This used to be return of a conditional expression,
122 but that truncated -1 to a char on VMS. */
123 if (read_from_string_index
< read_from_string_limit
)
124 c
= XSTRING (readcharfun
)->data
[read_from_string_index
++];
130 tem
= call0 (readcharfun
);
137 /* Unread the character C in the way appropriate for the stream READCHARFUN.
138 If the stream is a user function, call it with the char as argument. */
141 unreadchar (readcharfun
, c
)
142 Lisp_Object readcharfun
;
145 if (XTYPE (readcharfun
) == Lisp_Buffer
)
147 if (XBUFFER (readcharfun
) == current_buffer
)
150 SET_BUF_PT (XBUFFER (readcharfun
), BUF_PT (XBUFFER (readcharfun
)) - 1);
152 else if (XTYPE (readcharfun
) == Lisp_Marker
)
153 XMARKER (readcharfun
)->bufpos
--;
154 else if (XTYPE (readcharfun
) == Lisp_String
)
155 read_from_string_index
--;
156 else if (EQ (readcharfun
, Qget_file_char
))
157 ungetc (c
, instream
);
159 call1 (readcharfun
, make_number (c
));
162 static Lisp_Object
read0 (), read1 (), read_list (), read_vector ();
164 /* get a character from the tty */
166 extern Lisp_Object
read_char ();
168 DEFUN ("read-char", Fread_char
, Sread_char
, 0, 0, 0,
169 "Read a character from the command input (keyboard or macro).\n\
170 It is returned as a number.\n\
171 If the user generates an event which is not a character (i.e. a mouse\n\
172 click or function key event), `read-char' signals an error. As an\n\
173 exception, switch-frame events are put off until non-ASCII events can\n\
175 If you want to read non-character events, or ignore them, call\n\
176 `read-event' or `read-char-exclusive' instead.")
179 register Lisp_Object val
;
183 register Lisp_Object delayed_switch_frame
;
185 delayed_switch_frame
= Qnil
;
189 val
= read_char (0, 0, 0, Qnil
, 0);
191 /* switch-frame events are put off until after the next ASCII
192 character. This is better than signalling an error just
193 because the last characters were typed to a separate
194 minibuffer frame, for example. Eventually, some code which
195 can deal with switch-frame events will read it and process
197 if (EVENT_HAS_PARAMETERS (val
)
198 && EQ (EVENT_HEAD (val
), Qswitch_frame
))
199 delayed_switch_frame
= val
;
204 if (! NILP (delayed_switch_frame
))
205 unread_switch_frame
= delayed_switch_frame
;
207 /* Only ASCII characters are acceptable.
208 But convert certain symbols to their ASCII equivalents. */
209 if (XTYPE (val
) == Lisp_Symbol
)
211 Lisp_Object tem
, tem1
, tem2
;
212 tem
= Fget (val
, Qevent_symbol_element_mask
);
215 tem1
= Fget (Fcar (tem
), Qascii_character
);
216 /* Merge this symbol's modifier bits
217 with the ASCII equivalent of its basic code. */
219 XFASTINT (val
) = XINT (tem1
) | XINT (Fcar (Fcdr (tem
)));
222 if (XTYPE (val
) != Lisp_Int
)
224 unread_command_events
= Fcons (val
, Qnil
);
225 error ("Non-character input-event");
235 DEFUN ("read-event", Fread_event
, Sread_event
, 0, 0, 0,
236 "Read an event object from the input stream.")
239 register Lisp_Object val
;
241 val
= read_char (0, 0, 0, Qnil
, 0);
245 DEFUN ("read-char-exclusive", Fread_char_exclusive
, Sread_char_exclusive
, 0, 0, 0,
246 "Read a character from the command input (keyboard or macro).\n\
247 It is returned as a number. Non character events are ignored.")
250 register Lisp_Object val
;
254 Lisp_Object delayed_switch_frame
;
256 delayed_switch_frame
= Qnil
;
260 val
= read_char (0, 0, 0, Qnil
, 0);
262 /* Convert certain symbols (for keys like RET, DEL, TAB)
263 to ASCII integers. */
264 if (XTYPE (val
) == Lisp_Symbol
)
266 Lisp_Object tem
, tem1
;
267 tem
= Fget (val
, Qevent_symbol_element_mask
);
270 tem1
= Fget (Fcar (tem
), Qascii_character
);
271 /* Merge this symbol's modifier bits
272 with the ASCII equivalent of its basic code. */
274 XFASTINT (val
) = XINT (tem1
) | XINT (Fcar (Fcdr (tem
)));
277 if (XTYPE (val
) == Lisp_Int
)
280 /* switch-frame events are put off until after the next ASCII
281 character. This is better than signalling an error just
282 because the last characters were typed to a separate
283 minibuffer frame, for example. Eventually, some code which
284 can deal with switch-frame events will read it and process
286 else if (EVENT_HAS_PARAMETERS (val
)
287 && EQ (EVENT_HEAD (val
), Qswitch_frame
))
288 delayed_switch_frame
= val
;
290 /* Drop everything else. */
293 if (! NILP (delayed_switch_frame
))
294 unread_switch_frame
= delayed_switch_frame
;
303 DEFUN ("get-file-char", Fget_file_char
, Sget_file_char
, 0, 0, 0,
304 "Don't use this yourself.")
307 register Lisp_Object val
;
308 XSET (val
, Lisp_Int
, getc (instream
));
312 static void readevalloop ();
313 static Lisp_Object
load_unwind ();
315 DEFUN ("load", Fload
, Sload
, 1, 4, 0,
316 "Execute a file of Lisp code named FILE.\n\
317 First try FILE with `.elc' appended, then try with `.el',\n\
318 then try FILE unmodified.\n\
319 This function searches the directories in `load-path'.\n\
320 If optional second arg NOERROR is non-nil,\n\
321 report no error if FILE doesn't exist.\n\
322 Print messages at start and end of loading unless\n\
323 optional third arg NOMESSAGE is non-nil.\n\
324 If optional fourth arg NOSUFFIX is non-nil, don't try adding\n\
325 suffixes `.elc' or `.el' to the specified name FILE.\n\
326 Return t if file exists.")
327 (str
, noerror
, nomessage
, nosuffix
)
328 Lisp_Object str
, noerror
, nomessage
, nosuffix
;
330 register FILE *stream
;
331 register int fd
= -1;
332 register Lisp_Object lispstream
;
334 int count
= specpdl_ptr
- specpdl
;
338 /* 1 means inhibit the message at the beginning. */
341 CHECK_STRING (str
, 0);
342 str
= Fsubstitute_in_file_name (str
);
344 /* Avoid weird lossage with null string as arg,
345 since it would try to load a directory as a Lisp file */
346 if (XSTRING (str
)->size
> 0)
348 fd
= openp (Vload_path
, str
, !NILP (nosuffix
) ? "" : ".elc:.el:",
356 Fsignal (Qfile_error
, Fcons (build_string ("Cannot open load file"),
362 if (!bcmp (&(XSTRING (found
)->data
[XSTRING (found
)->size
- 4]),
368 stat (XSTRING (found
)->data
, &s1
);
369 XSTRING (found
)->data
[XSTRING (found
)->size
- 1] = 0;
370 result
= stat (XSTRING (found
)->data
, &s2
);
371 if (result
>= 0 && (unsigned) s1
.st_mtime
< (unsigned) s2
.st_mtime
)
373 message ("Source file `%s' newer than byte-compiled file",
374 XSTRING (found
)->data
);
375 /* Don't immediately overwrite this message. */
379 XSTRING (found
)->data
[XSTRING (found
)->size
- 1] = 'c';
382 stream
= fdopen (fd
, "r");
386 error ("Failure to create stdio stream for %s", XSTRING (str
)->data
);
389 if (NILP (nomessage
) && !nomessage1
)
390 message ("Loading %s...", XSTRING (str
)->data
);
393 /* We may not be able to store STREAM itself as a Lisp_Object pointer
394 since that is guaranteed to work only for data that has been malloc'd.
395 So malloc a full-size pointer, and record the address of that pointer. */
396 ptr
= (FILE **) xmalloc (sizeof (FILE *));
398 XSET (lispstream
, Lisp_Internal_Stream
, (int) ptr
);
399 record_unwind_protect (load_unwind
, lispstream
);
401 readevalloop (Qget_file_char
, stream
, Feval
, 0);
402 unbind_to (count
, Qnil
);
404 /* Run any load-hooks for this file. */
405 temp
= Fassoc (str
, Vafter_load_alist
);
407 Fprogn (Fcdr (temp
));
410 if (!noninteractive
&& NILP (nomessage
))
411 message ("Loading %s...done", XSTRING (str
)->data
);
416 load_unwind (stream
) /* used as unwind-protect function in load */
419 fclose (*(FILE **) XSTRING (stream
));
420 xfree (XPNTR (stream
));
421 if (--load_in_progress
< 0) load_in_progress
= 0;
427 complete_filename_p (pathname
)
428 Lisp_Object pathname
;
430 register unsigned char *s
= XSTRING (pathname
)->data
;
441 /* Search for a file whose name is STR, looking in directories
442 in the Lisp list PATH, and trying suffixes from SUFFIX.
443 SUFFIX is a string containing possible suffixes separated by colons.
444 On success, returns a file descriptor. On failure, returns -1.
446 EXEC_ONLY nonzero means don't open the files,
447 just look for one that is executable. In this case,
448 returns 1 on success.
450 If STOREPTR is nonzero, it points to a slot where the name of
451 the file actually found should be stored as a Lisp string.
452 Nil is stored there on failure. */
455 openp (path
, str
, suffix
, storeptr
, exec_only
)
456 Lisp_Object path
, str
;
458 Lisp_Object
*storeptr
;
464 register char *fn
= buf
;
467 register Lisp_Object filename
;
473 if (complete_filename_p (str
))
476 for (; !NILP (path
); path
= Fcdr (path
))
480 filename
= Fexpand_file_name (str
, Fcar (path
));
481 if (!complete_filename_p (filename
))
482 /* If there are non-absolute elts in PATH (eg ".") */
483 /* Of course, this could conceivably lose if luser sets
484 default-directory to be something non-absolute... */
486 filename
= Fexpand_file_name (filename
, current_buffer
->directory
);
487 if (!complete_filename_p (filename
))
488 /* Give up on this path element! */
492 /* Calculate maximum size of any filename made from
493 this path element/specified file name and any possible suffix. */
494 want_size
= strlen (suffix
) + XSTRING (filename
)->size
+ 1;
495 if (fn_size
< want_size
)
496 fn
= (char *) alloca (fn_size
= 100 + want_size
);
500 /* Loop over suffixes. */
503 char *esuffix
= (char *) index (nsuffix
, ':');
504 int lsuffix
= esuffix
? esuffix
- nsuffix
: strlen (nsuffix
);
506 /* Concatenate path element/specified name with the suffix. */
507 strncpy (fn
, XSTRING (filename
)->data
, XSTRING (filename
)->size
);
508 fn
[XSTRING (filename
)->size
] = 0;
509 if (lsuffix
!= 0) /* Bug happens on CCI if lsuffix is 0. */
510 strncat (fn
, nsuffix
, lsuffix
);
512 /* Ignore file if it's a directory. */
513 if (stat (fn
, &st
) >= 0
514 && (st
.st_mode
& S_IFMT
) != S_IFDIR
)
516 /* Check that we can access or open it. */
518 fd
= (access (fn
, X_OK
) == 0) ? 1 : -1;
520 fd
= open (fn
, 0, 0);
524 /* We succeeded; return this descriptor and filename. */
526 *storeptr
= build_string (fn
);
531 /* Advance to next suffix. */
534 nsuffix
+= lsuffix
+ 1;
536 if (absolute
) return -1;
544 unreadpure () /* Used as unwind-protect function in readevalloop */
551 readevalloop (readcharfun
, stream
, evalfun
, printflag
)
552 Lisp_Object readcharfun
;
554 Lisp_Object (*evalfun
) ();
558 register Lisp_Object val
;
559 int count
= specpdl_ptr
- specpdl
;
561 specbind (Qstandard_input
, readcharfun
);
569 while ((c
= READCHAR
) != '\n' && c
!= -1);
573 if (c
== ' ' || c
== '\t' || c
== '\n' || c
== '\f') continue;
575 if (!NILP (Vpurify_flag
) && c
== '(')
577 record_unwind_protect (unreadpure
, Qnil
);
578 val
= read_list (-1, readcharfun
);
579 unbind_to (count
+ 1, Qnil
);
584 val
= read0 (readcharfun
);
587 val
= (*evalfun
) (val
);
590 Vvalues
= Fcons (val
, Vvalues
);
591 if (EQ (Vstandard_output
, Qt
))
598 unbind_to (count
, Qnil
);
603 DEFUN ("eval-buffer", Feval_buffer
, Seval_buffer
, 0, 2, "",
604 "Execute the current buffer as Lisp code.\n\
605 Programs can pass two arguments, BUFFER and PRINTFLAG.\n\
606 BUFFER is the buffer to evaluate (nil means use current buffer).\n\
607 PRINTFLAG controls printing of output:\n\
608 nil means discard it; anything else is stream for print.\n\
610 If there is no error, point does not move. If there is an error,\n\
611 point remains at the end of the last character read from the buffer.")
613 Lisp_Object bufname
, printflag
;
615 int count
= specpdl_ptr
- specpdl
;
616 Lisp_Object tem
, buf
;
619 buf
= Fcurrent_buffer ();
621 buf
= Fget_buffer (bufname
);
623 error ("No such buffer.");
625 if (NILP (printflag
))
629 specbind (Qstandard_output
, tem
);
630 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
631 BUF_SET_PT (XBUFFER (buf
), BUF_BEGV (XBUFFER (buf
)));
632 readevalloop (buf
, 0, Feval
, !NILP (printflag
));
633 unbind_to (count
, Qnil
);
639 DEFUN ("eval-current-buffer", Feval_current_buffer
, Seval_current_buffer
, 0, 1, "",
640 "Execute the current buffer as Lisp code.\n\
641 Programs can pass argument PRINTFLAG which controls printing of output:\n\
642 nil means discard it; anything else is stream for print.\n\
644 If there is no error, point does not move. If there is an error,\n\
645 point remains at the end of the last character read from the buffer.")
647 Lisp_Object printflag
;
649 int count
= specpdl_ptr
- specpdl
;
652 if (NILP (printflag
))
656 specbind (Qstandard_output
, tem
);
657 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
659 readevalloop (Fcurrent_buffer (), 0, Feval
, !NILP (printflag
));
660 return unbind_to (count
, Qnil
);
664 DEFUN ("eval-region", Feval_region
, Seval_region
, 2, 3, "r",
665 "Execute the region as Lisp code.\n\
666 When called from programs, expects two arguments,\n\
667 giving starting and ending indices in the current buffer\n\
668 of the text to be executed.\n\
669 Programs can pass third argument PRINTFLAG which controls output:\n\
670 nil means discard it; anything else is stream for printing it.\n\
672 If there is no error, point does not move. If there is an error,\n\
673 point remains at the end of the last character read from the buffer.")
675 Lisp_Object b
, e
, printflag
;
677 int count
= specpdl_ptr
- specpdl
;
680 if (NILP (printflag
))
684 specbind (Qstandard_output
, tem
);
686 if (NILP (printflag
))
687 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
688 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
690 /* This both uses b and checks its type. */
692 Fnarrow_to_region (make_number (BEGV
), e
);
693 readevalloop (Fcurrent_buffer (), 0, Feval
, !NILP (printflag
));
695 return unbind_to (count
, Qnil
);
698 #endif /* standalone */
700 DEFUN ("read", Fread
, Sread
, 0, 1, 0,
701 "Read one Lisp expression as text from STREAM, return as Lisp object.\n\
702 If STREAM is nil, use the value of `standard-input' (which see).\n\
703 STREAM or the value of `standard-input' may be:\n\
704 a buffer (read from point and advance it)\n\
705 a marker (read from where it points and advance it)\n\
706 a function (call it with no arguments for each character,\n\
707 call it with a char as argument to push a char back)\n\
708 a string (takes text from string, starting at the beginning)\n\
709 t (read text line using minibuffer and use it).")
711 Lisp_Object readcharfun
;
713 extern Lisp_Object
Fread_minibuffer ();
715 if (NILP (readcharfun
))
716 readcharfun
= Vstandard_input
;
717 if (EQ (readcharfun
, Qt
))
718 readcharfun
= Qread_char
;
721 if (EQ (readcharfun
, Qread_char
))
722 return Fread_minibuffer (build_string ("Lisp expression: "), Qnil
);
725 if (XTYPE (readcharfun
) == Lisp_String
)
726 return Fcar (Fread_from_string (readcharfun
, Qnil
, Qnil
));
728 return read0 (readcharfun
);
731 DEFUN ("read-from-string", Fread_from_string
, Sread_from_string
, 1, 3, 0,
732 "Read one Lisp expression which is represented as text by STRING.\n\
733 Returns a cons: (OBJECT-READ . FINAL-STRING-INDEX).\n\
734 START and END optionally delimit a substring of STRING from which to read;\n\
735 they default to 0 and (length STRING) respectively.")
737 Lisp_Object string
, start
, end
;
739 int startval
, endval
;
742 CHECK_STRING (string
,0);
745 endval
= XSTRING (string
)->size
;
747 { CHECK_NUMBER (end
,2);
749 if (endval
< 0 || endval
> XSTRING (string
)->size
)
750 args_out_of_range (string
, end
);
756 { CHECK_NUMBER (start
,1);
757 startval
= XINT (start
);
758 if (startval
< 0 || startval
> endval
)
759 args_out_of_range (string
, start
);
762 read_from_string_index
= startval
;
763 read_from_string_limit
= endval
;
765 tem
= read0 (string
);
766 return Fcons (tem
, make_number (read_from_string_index
));
769 /* Use this for recursive reads, in contexts where internal tokens are not allowed. */
773 Lisp_Object readcharfun
;
775 register Lisp_Object val
;
778 val
= read1 (readcharfun
);
779 if (XTYPE (val
) == Lisp_Internal
)
782 return Fsignal (Qinvalid_read_syntax
, Fcons (make_string (&c
, 1), Qnil
));
788 static int read_buffer_size
;
789 static char *read_buffer
;
792 read_escape (readcharfun
)
793 Lisp_Object readcharfun
;
795 register int c
= READCHAR
;
822 error ("Invalid escape character syntax");
825 c
= read_escape (readcharfun
);
826 return c
| meta_modifier
;
831 error ("Invalid escape character syntax");
834 c
= read_escape (readcharfun
);
835 return c
| shift_modifier
;
840 error ("Invalid escape character syntax");
843 c
= read_escape (readcharfun
);
844 return c
| hyper_modifier
;
849 error ("Invalid escape character syntax");
852 c
= read_escape (readcharfun
);
853 return c
| alt_modifier
;
858 error ("Invalid escape character syntax");
861 c
= read_escape (readcharfun
);
862 return c
| super_modifier
;
867 error ("Invalid escape character syntax");
871 c
= read_escape (readcharfun
);
872 if ((c
& 0177) == '?')
874 /* ASCII control chars are made from letters (both cases),
875 as well as the non-letters within 0100...0137. */
876 else if ((c
& 0137) >= 0101 && (c
& 0137) <= 0132)
877 return (c
& (037 | ~0177));
878 else if ((c
& 0177) >= 0100 && (c
& 0177) <= 0137)
879 return (c
& (037 | ~0177));
881 return c
| ctrl_modifier
;
891 /* An octal escape, as in ANSI C. */
893 register int i
= c
- '0';
894 register int count
= 0;
897 if ((c
= READCHAR
) >= '0' && c
<= '7')
912 /* A hex escape, as in ANSI C. */
918 if (c
>= '0' && c
<= '9')
923 else if ((c
>= 'a' && c
<= 'f')
924 || (c
>= 'A' && c
<= 'F'))
927 if (c
>= 'a' && c
<= 'f')
948 register Lisp_Object readcharfun
;
955 if (c
< 0) return Fsignal (Qend_of_file
, Qnil
);
960 return read_list (0, readcharfun
);
963 return read_vector (readcharfun
);
968 register Lisp_Object val
;
969 XSET (val
, Lisp_Internal
, c
);
977 /* Accept compiled functions at read-time so that we don't have to
978 build them using function calls. */
980 tmp
= read_vector (readcharfun
);
981 return Fmake_byte_code (XVECTOR (tmp
)->size
,
982 XVECTOR (tmp
)->contents
);
984 #ifdef USE_TEXT_PROPERTIES
990 /* Read the string itself. */
991 tmp
= read1 (readcharfun
);
992 if (XTYPE (tmp
) != Lisp_String
)
993 Fsignal (Qinvalid_read_syntax
, Fcons (make_string ("#", 1), Qnil
));
995 /* Read the intervals and their properties. */
998 Lisp_Object beg
, end
, plist
;
1000 beg
= read1 (readcharfun
);
1001 if (XTYPE (beg
) == Lisp_Internal
)
1003 if (XINT (beg
) == ')')
1005 Fsignal (Qinvalid_read_syntax
, Fcons (make_string ("invalid string property list", 28), Qnil
));
1007 end
= read1 (readcharfun
);
1008 if (XTYPE (end
) == Lisp_Internal
)
1009 Fsignal (Qinvalid_read_syntax
,
1010 Fcons (make_string ("invalid string property list", 28), Qnil
));
1012 plist
= read1 (readcharfun
);
1013 if (XTYPE (plist
) == Lisp_Internal
)
1014 Fsignal (Qinvalid_read_syntax
,
1015 Fcons (make_string ("invalid string property list", 28), Qnil
));
1016 Fset_text_properties (beg
, end
, plist
, tmp
);
1023 Fsignal (Qinvalid_read_syntax
, Fcons (make_string ("#", 1), Qnil
));
1026 while ((c
= READCHAR
) >= 0 && c
!= '\n');
1031 return Fcons (Qquote
, Fcons (read0 (readcharfun
), Qnil
));
1036 register Lisp_Object val
;
1039 if (c
< 0) return Fsignal (Qend_of_file
, Qnil
);
1042 XSET (val
, Lisp_Int
, read_escape (readcharfun
));
1044 XSET (val
, Lisp_Int
, c
);
1051 register char *p
= read_buffer
;
1052 register char *end
= read_buffer
+ read_buffer_size
;
1056 while ((c
= READCHAR
) >= 0
1061 char *new = (char *) xrealloc (read_buffer
, read_buffer_size
*= 2);
1062 p
+= new - read_buffer
;
1063 read_buffer
+= new - read_buffer
;
1064 end
= read_buffer
+ read_buffer_size
;
1067 c
= read_escape (readcharfun
);
1068 /* c is -1 if \ newline has just been seen */
1071 if (p
== read_buffer
)
1074 else if (c
& CHAR_META
)
1075 /* Move the meta bit to the right place for a string. */
1076 *p
++ = (c
& ~CHAR_META
) | 0x80;
1080 if (c
< 0) return Fsignal (Qend_of_file
, Qnil
);
1082 /* If purifying, and string starts with \ newline,
1083 return zero instead. This is for doc strings
1084 that we are really going to find in etc/DOC.nn.nn */
1085 if (!NILP (Vpurify_flag
) && NILP (Vdoc_file_name
) && cancel
)
1086 return make_number (0);
1089 return make_pure_string (read_buffer
, p
- read_buffer
);
1091 return make_string (read_buffer
, p
- read_buffer
);
1096 #ifdef LISP_FLOAT_TYPE
1097 /* If a period is followed by a number, then we should read it
1098 as a floating point number. Otherwise, it denotes a dotted
1100 int next_char
= READCHAR
;
1103 if (! isdigit (next_char
))
1106 register Lisp_Object val
;
1107 XSET (val
, Lisp_Internal
, c
);
1111 /* Otherwise, we fall through! Note that the atom-reading loop
1112 below will now loop at least once, assuring that we will not
1113 try to UNREAD two characters in a row. */
1116 if (c
<= 040) goto retry
;
1118 register char *p
= read_buffer
;
1121 register char *end
= read_buffer
+ read_buffer_size
;
1124 !(c
== '\"' || c
== '\'' || c
== ';' || c
== '?'
1125 || c
== '(' || c
== ')'
1126 #ifndef LISP_FLOAT_TYPE
1127 /* If we have floating-point support, then we need
1128 to allow <digits><dot><digits>. */
1130 #endif /* not LISP_FLOAT_TYPE */
1131 || c
== '[' || c
== ']' || c
== '#'
1136 register char *new = (char *) xrealloc (read_buffer
, read_buffer_size
*= 2);
1137 p
+= new - read_buffer
;
1138 read_buffer
+= new - read_buffer
;
1139 end
= read_buffer
+ read_buffer_size
;
1149 char *new = (char *) xrealloc (read_buffer
, read_buffer_size
*= 2);
1150 p
+= new - read_buffer
;
1151 read_buffer
+= new - read_buffer
;
1152 /* end = read_buffer + read_buffer_size; */
1159 /* Is it an integer? */
1162 register Lisp_Object val
;
1164 if (*p1
== '+' || *p1
== '-') p1
++;
1167 while (p1
!= p
&& (c
= *p1
) >= '0' && c
<= '9') p1
++;
1168 #ifdef LISP_FLOAT_TYPE
1169 /* Integers can have trailing decimal points. */
1170 if (p1
> read_buffer
&& p1
< p
&& *p1
== '.') p1
++;
1173 /* It is an integer. */
1175 #ifdef LISP_FLOAT_TYPE
1179 XSET (val
, Lisp_Int
, atoi (read_buffer
));
1183 #ifdef LISP_FLOAT_TYPE
1184 if (isfloat_string (read_buffer
))
1185 return make_float (atof (read_buffer
));
1189 return intern (read_buffer
);
1194 #ifdef LISP_FLOAT_TYPE
1209 if (*cp
== '+' || *cp
== '-')
1215 while (isdigit (*cp
))
1226 while (isdigit (*cp
))
1234 if ((*cp
== '+') || (*cp
== '-'))
1240 while (isdigit (*cp
))
1244 && (state
== (LEAD_INT
|DOT_CHAR
|TRAIL_INT
)
1245 || state
== (DOT_CHAR
|TRAIL_INT
)
1246 || state
== (LEAD_INT
|E_CHAR
|EXP_INT
)
1247 || state
== (LEAD_INT
|DOT_CHAR
|TRAIL_INT
|E_CHAR
|EXP_INT
)
1248 || state
== (DOT_CHAR
|TRAIL_INT
|E_CHAR
|EXP_INT
)));
1250 #endif /* LISP_FLOAT_TYPE */
1253 read_vector (readcharfun
)
1254 Lisp_Object readcharfun
;
1258 register Lisp_Object
*ptr
;
1259 register Lisp_Object tem
, vector
;
1260 register struct Lisp_Cons
*otem
;
1263 tem
= read_list (1, readcharfun
);
1264 len
= Flength (tem
);
1265 vector
= (read_pure
? make_pure_vector (XINT (len
)) : Fmake_vector (len
, Qnil
));
1268 size
= XVECTOR (vector
)->size
;
1269 ptr
= XVECTOR (vector
)->contents
;
1270 for (i
= 0; i
< size
; i
++)
1272 ptr
[i
] = read_pure
? Fpurecopy (Fcar (tem
)) : Fcar (tem
);
1280 /* flag = 1 means check for ] to terminate rather than ) and .
1281 flag = -1 means check for starting with defun
1282 and make structure pure. */
1285 read_list (flag
, readcharfun
)
1287 register Lisp_Object readcharfun
;
1289 /* -1 means check next element for defun,
1290 0 means don't check,
1291 1 means already checked and found defun. */
1292 int defunflag
= flag
< 0 ? -1 : 0;
1293 Lisp_Object val
, tail
;
1294 register Lisp_Object elt
, tem
;
1295 struct gcpro gcpro1
, gcpro2
;
1303 elt
= read1 (readcharfun
);
1305 if (XTYPE (elt
) == Lisp_Internal
)
1309 if (XINT (elt
) == ']')
1311 return Fsignal (Qinvalid_read_syntax
, Fcons (make_string (") or . in a vector", 18), Qnil
));
1313 if (XINT (elt
) == ')')
1315 if (XINT (elt
) == '.')
1319 XCONS (tail
)->cdr
= read0 (readcharfun
);
1321 val
= read0 (readcharfun
);
1322 elt
= read1 (readcharfun
);
1324 if (XTYPE (elt
) == Lisp_Internal
&& XINT (elt
) == ')')
1326 return Fsignal (Qinvalid_read_syntax
, Fcons (make_string (". in wrong context", 18), Qnil
));
1328 return Fsignal (Qinvalid_read_syntax
, Fcons (make_string ("] in a list", 11), Qnil
));
1330 tem
= (read_pure
&& flag
<= 0
1331 ? pure_cons (elt
, Qnil
)
1332 : Fcons (elt
, Qnil
));
1334 XCONS (tail
)->cdr
= tem
;
1339 defunflag
= EQ (elt
, Qdefun
);
1340 else if (defunflag
> 0)
1345 Lisp_Object Vobarray
;
1346 Lisp_Object initial_obarray
;
1349 check_obarray (obarray
)
1350 Lisp_Object obarray
;
1352 while (XTYPE (obarray
) != Lisp_Vector
|| XVECTOR (obarray
)->size
== 0)
1354 /* If Vobarray is now invalid, force it to be valid. */
1355 if (EQ (Vobarray
, obarray
)) Vobarray
= initial_obarray
;
1357 obarray
= wrong_type_argument (Qvectorp
, obarray
);
1362 static int hash_string ();
1363 Lisp_Object
oblookup ();
1370 int len
= strlen (str
);
1371 Lisp_Object obarray
= Vobarray
;
1373 if (XTYPE (obarray
) != Lisp_Vector
|| XVECTOR (obarray
)->size
== 0)
1374 obarray
= check_obarray (obarray
);
1375 tem
= oblookup (obarray
, str
, len
);
1376 if (XTYPE (tem
) == Lisp_Symbol
)
1378 return Fintern ((!NILP (Vpurify_flag
)
1379 ? make_pure_string (str
, len
)
1380 : make_string (str
, len
)),
1384 DEFUN ("intern", Fintern
, Sintern
, 1, 2, 0,
1385 "Return the canonical symbol whose name is STRING.\n\
1386 If there is none, one is created by this function and returned.\n\
1387 A second optional argument specifies the obarray to use;\n\
1388 it defaults to the value of `obarray'.")
1390 Lisp_Object str
, obarray
;
1392 register Lisp_Object tem
, sym
, *ptr
;
1394 if (NILP (obarray
)) obarray
= Vobarray
;
1395 obarray
= check_obarray (obarray
);
1397 CHECK_STRING (str
, 0);
1399 tem
= oblookup (obarray
, XSTRING (str
)->data
, XSTRING (str
)->size
);
1400 if (XTYPE (tem
) != Lisp_Int
)
1403 if (!NILP (Vpurify_flag
))
1404 str
= Fpurecopy (str
);
1405 sym
= Fmake_symbol (str
);
1407 ptr
= &XVECTOR (obarray
)->contents
[XINT (tem
)];
1408 if (XTYPE (*ptr
) == Lisp_Symbol
)
1409 XSYMBOL (sym
)->next
= XSYMBOL (*ptr
);
1411 XSYMBOL (sym
)->next
= 0;
1416 DEFUN ("intern-soft", Fintern_soft
, Sintern_soft
, 1, 2, 0,
1417 "Return the canonical symbol whose name is STRING, or nil if none exists.\n\
1418 A second optional argument specifies the obarray to use;\n\
1419 it defaults to the value of `obarray'.")
1421 Lisp_Object str
, obarray
;
1423 register Lisp_Object tem
;
1425 if (NILP (obarray
)) obarray
= Vobarray
;
1426 obarray
= check_obarray (obarray
);
1428 CHECK_STRING (str
, 0);
1430 tem
= oblookup (obarray
, XSTRING (str
)->data
, XSTRING (str
)->size
);
1431 if (XTYPE (tem
) != Lisp_Int
)
1437 oblookup (obarray
, ptr
, size
)
1438 Lisp_Object obarray
;
1443 register Lisp_Object tail
;
1444 Lisp_Object bucket
, tem
;
1446 if (XTYPE (obarray
) != Lisp_Vector
||
1447 (obsize
= XVECTOR (obarray
)->size
) == 0)
1449 obarray
= check_obarray (obarray
);
1450 obsize
= XVECTOR (obarray
)->size
;
1452 /* Combining next two lines breaks VMS C 2.3. */
1453 hash
= hash_string (ptr
, size
);
1455 bucket
= XVECTOR (obarray
)->contents
[hash
];
1456 if (XFASTINT (bucket
) == 0)
1458 else if (XTYPE (bucket
) != Lisp_Symbol
)
1459 error ("Bad data in guts of obarray"); /* Like CADR error message */
1460 else for (tail
= bucket
; ; XSET (tail
, Lisp_Symbol
, XSYMBOL (tail
)->next
))
1462 if (XSYMBOL (tail
)->name
->size
== size
&&
1463 !bcmp (XSYMBOL (tail
)->name
->data
, ptr
, size
))
1465 else if (XSYMBOL (tail
)->next
== 0)
1468 XSET (tem
, Lisp_Int
, hash
);
1473 hash_string (ptr
, len
)
1477 register unsigned char *p
= ptr
;
1478 register unsigned char *end
= p
+ len
;
1479 register unsigned char c
;
1480 register int hash
= 0;
1485 if (c
>= 0140) c
-= 40;
1486 hash
= ((hash
<<3) + (hash
>>28) + c
);
1488 return hash
& 07777777777;
1492 map_obarray (obarray
, fn
, arg
)
1493 Lisp_Object obarray
;
1498 register Lisp_Object tail
;
1499 CHECK_VECTOR (obarray
, 1);
1500 for (i
= XVECTOR (obarray
)->size
- 1; i
>= 0; i
--)
1502 tail
= XVECTOR (obarray
)->contents
[i
];
1503 if (XFASTINT (tail
) != 0)
1507 if (XSYMBOL (tail
)->next
== 0)
1509 XSET (tail
, Lisp_Symbol
, XSYMBOL (tail
)->next
);
1514 mapatoms_1 (sym
, function
)
1515 Lisp_Object sym
, function
;
1517 call1 (function
, sym
);
1520 DEFUN ("mapatoms", Fmapatoms
, Smapatoms
, 1, 2, 0,
1521 "Call FUNCTION on every symbol in OBARRAY.\n\
1522 OBARRAY defaults to the value of `obarray'.")
1524 Lisp_Object function
, obarray
;
1528 if (NILP (obarray
)) obarray
= Vobarray
;
1529 obarray
= check_obarray (obarray
);
1531 map_obarray (obarray
, mapatoms_1
, function
);
1535 #define OBARRAY_SIZE 509
1540 Lisp_Object oblength
;
1544 XFASTINT (oblength
) = OBARRAY_SIZE
;
1546 Qnil
= Fmake_symbol (make_pure_string ("nil", 3));
1547 Vobarray
= Fmake_vector (oblength
, make_number (0));
1548 initial_obarray
= Vobarray
;
1549 staticpro (&initial_obarray
);
1550 /* Intern nil in the obarray */
1551 /* These locals are to kludge around a pyramid compiler bug. */
1552 hash
= hash_string ("nil", 3);
1553 /* Separate statement here to avoid VAXC bug. */
1554 hash
%= OBARRAY_SIZE
;
1555 tem
= &XVECTOR (Vobarray
)->contents
[hash
];
1558 Qunbound
= Fmake_symbol (make_pure_string ("unbound", 7));
1559 XSYMBOL (Qnil
)->function
= Qunbound
;
1560 XSYMBOL (Qunbound
)->value
= Qunbound
;
1561 XSYMBOL (Qunbound
)->function
= Qunbound
;
1564 XSYMBOL (Qnil
)->value
= Qnil
;
1565 XSYMBOL (Qnil
)->plist
= Qnil
;
1566 XSYMBOL (Qt
)->value
= Qt
;
1568 /* Qt is correct even if CANNOT_DUMP. loadup.el will set to nil at end. */
1571 Qvariable_documentation
= intern ("variable-documentation");
1573 read_buffer_size
= 100;
1574 read_buffer
= (char *) malloc (read_buffer_size
);
1579 struct Lisp_Subr
*sname
;
1582 sym
= intern (sname
->symbol_name
);
1583 XSET (XSYMBOL (sym
)->function
, Lisp_Subr
, sname
);
1586 #ifdef NOTDEF /* use fset in subr.el now */
1588 defalias (sname
, string
)
1589 struct Lisp_Subr
*sname
;
1593 sym
= intern (string
);
1594 XSET (XSYMBOL (sym
)->function
, Lisp_Subr
, sname
);
1598 /* New replacement for DefIntVar; it ignores the doc string argument
1599 on the assumption that make-docfile will handle that. */
1600 /* Define an "integer variable"; a symbol whose value is forwarded
1601 to a C variable of type int. Sample call: */
1602 /* DEFVARINT ("indent-tabs-mode", &indent_tabs_mode, "Documentation"); */
1605 defvar_int (namestring
, address
, doc
)
1611 sym
= intern (namestring
);
1612 XSET (XSYMBOL (sym
)->value
, Lisp_Intfwd
, address
);
1615 /* Similar but define a variable whose value is T if address contains 1,
1616 NIL if address contains 0 */
1619 defvar_bool (namestring
, address
, doc
)
1625 sym
= intern (namestring
);
1626 XSET (XSYMBOL (sym
)->value
, Lisp_Boolfwd
, address
);
1629 /* Similar but define a variable whose value is the Lisp Object stored at address. */
1632 defvar_lisp (namestring
, address
, doc
)
1634 Lisp_Object
*address
;
1638 sym
= intern (namestring
);
1639 XSET (XSYMBOL (sym
)->value
, Lisp_Objfwd
, address
);
1640 staticpro (address
);
1643 /* Similar but don't request gc-marking of the C variable.
1644 Used when that variable will be gc-marked for some other reason,
1645 since marking the same slot twice can cause trouble with strings. */
1648 defvar_lisp_nopro (namestring
, address
, doc
)
1650 Lisp_Object
*address
;
1654 sym
= intern (namestring
);
1655 XSET (XSYMBOL (sym
)->value
, Lisp_Objfwd
, address
);
1660 /* Similar but define a variable whose value is the Lisp Object stored in
1661 the current buffer. address is the address of the slot in the buffer that is current now. */
1664 defvar_per_buffer (namestring
, address
, type
, doc
)
1666 Lisp_Object
*address
;
1672 extern struct buffer buffer_local_symbols
;
1674 sym
= intern (namestring
);
1675 offset
= (char *)address
- (char *)current_buffer
;
1677 XSET (XSYMBOL (sym
)->value
, Lisp_Buffer_Objfwd
,
1678 (Lisp_Object
*) offset
);
1679 *(Lisp_Object
*)(offset
+ (char *)&buffer_local_symbols
) = sym
;
1680 *(Lisp_Object
*)(offset
+ (char *)&buffer_local_types
) = type
;
1681 if (*(int *)(offset
+ (char *)&buffer_local_flags
) == 0)
1682 /* Did a DEFVAR_PER_BUFFER without initializing the corresponding
1683 slot of buffer_local_flags */
1687 #endif /* standalone */
1693 /* Compute the default load-path. */
1695 normal
= PATH_LOADSEARCH
;
1696 Vload_path
= decode_env_path (0, normal
);
1698 if (NILP (Vpurify_flag
))
1699 normal
= PATH_LOADSEARCH
;
1701 normal
= PATH_DUMPLOADSEARCH
;
1703 /* In a dumped Emacs, we normally have to reset the value of
1704 Vload_path from PATH_LOADSEARCH, since the value that was dumped
1705 uses ../lisp, instead of the path of the installed elisp
1706 libraries. However, if it appears that Vload_path was changed
1707 from the default before dumping, don't override that value. */
1710 Lisp_Object dump_path
;
1712 dump_path
= decode_env_path (0, PATH_DUMPLOADSEARCH
);
1713 if (! NILP (Fequal (dump_path
, Vload_path
)))
1714 Vload_path
= decode_env_path (0, normal
);
1717 Vload_path
= decode_env_path (0, normal
);
1720 /* Warn if dirs in the *standard* path don't exist. */
1722 Lisp_Object path_tail
;
1724 for (path_tail
= Vload_path
;
1726 path_tail
= XCONS (path_tail
)->cdr
)
1728 Lisp_Object dirfile
;
1729 dirfile
= Fcar (path_tail
);
1730 if (XTYPE (dirfile
) == Lisp_String
)
1732 dirfile
= Fdirectory_file_name (dirfile
);
1733 if (access (XSTRING (dirfile
)->data
, 0) < 0)
1734 printf ("Warning: lisp library (%s) does not exist.\n",
1735 XSTRING (Fcar (path_tail
))->data
);
1740 /* If the EMACSLOADPATH environment variable is set, use its value.
1741 This doesn't apply if we're dumping. */
1742 if (NILP (Vpurify_flag
)
1743 && egetenv ("EMACSLOADPATH"))
1744 Vload_path
= decode_env_path ("EMACSLOADPATH", normal
);
1748 load_in_progress
= 0;
1755 defsubr (&Sread_from_string
);
1757 defsubr (&Sintern_soft
);
1759 defsubr (&Seval_buffer
);
1760 defsubr (&Seval_region
);
1761 defsubr (&Sread_char
);
1762 defsubr (&Sread_char_exclusive
);
1763 defsubr (&Sread_event
);
1764 defsubr (&Sget_file_char
);
1765 defsubr (&Smapatoms
);
1767 DEFVAR_LISP ("obarray", &Vobarray
,
1768 "Symbol table for use by `intern' and `read'.\n\
1769 It is a vector whose length ought to be prime for best results.\n\
1770 The vector's contents don't make sense if examined from Lisp programs;\n\
1771 to find all the symbols in an obarray, use `mapatoms'.");
1773 DEFVAR_LISP ("values", &Vvalues
,
1774 "List of values of all expressions which were read, evaluated and printed.\n\
1775 Order is reverse chronological.");
1777 DEFVAR_LISP ("standard-input", &Vstandard_input
,
1778 "Stream for read to get input from.\n\
1779 See documentation of `read' for possible values.");
1780 Vstandard_input
= Qt
;
1782 DEFVAR_LISP ("load-path", &Vload_path
,
1783 "*List of directories to search for files to load.\n\
1784 Each element is a string (directory name) or nil (try default directory).\n\
1785 Initialized based on EMACSLOADPATH environment variable, if any,\n\
1786 otherwise to default specified by file `paths.h' when Emacs was built.");
1788 DEFVAR_BOOL ("load-in-progress", &load_in_progress
,
1789 "Non-nil iff inside of `load'.");
1791 DEFVAR_LISP ("after-load-alist", &Vafter_load_alist
,
1792 "An alist of expressions to be evalled when particular files are loaded.\n\
1793 Each element looks like (FILENAME FORMS...).\n\
1794 When `load' is run and the file-name argument is FILENAME,\n\
1795 the FORMS in the corresponding element are executed at the end of loading.\n\n\
1796 FILENAME must match exactly! Normally FILENAME is the name of a library,\n\
1797 with no directory specified, since that is how `load' is normally called.\n\
1798 An error in FORMS does not undo the load,\n\
1799 but does prevent execution of the rest of the FORMS.");
1800 Vafter_load_alist
= Qnil
;
1802 Qstandard_input
= intern ("standard-input");
1803 staticpro (&Qstandard_input
);
1805 Qread_char
= intern ("read-char");
1806 staticpro (&Qread_char
);
1808 Qget_file_char
= intern ("get-file-char");
1809 staticpro (&Qget_file_char
);
1811 Qascii_character
= intern ("ascii-character");
1812 staticpro (&Qascii_character
);