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>
38 #include <sys/inode.h>
45 #ifdef LISP_FLOAT_TYPE
47 #endif /* LISP_FLOAT_TYPE */
49 Lisp_Object Qread_char
, Qget_file_char
, Qstandard_input
;
50 Lisp_Object Qvariable_documentation
, Vvalues
, Vstandard_input
, Vafter_load_alist
;
52 /* non-zero if inside `load' */
55 /* Search path for files to be loaded. */
56 Lisp_Object Vload_path
;
58 /* File for get_file_char to read from. Use by load */
59 static FILE *instream
;
61 /* When nonzero, read conses in pure space */
64 /* For use within read-from-string (this reader is non-reentrant!!) */
65 static int read_from_string_index
;
66 static int read_from_string_limit
;
68 /* Handle unreading and rereading of characters.
69 Write READCHAR to read a character,
70 UNREAD(c) to unread c to be read again. */
72 #define READCHAR readchar (readcharfun)
73 #define UNREAD(c) unreadchar (readcharfun, c)
76 readchar (readcharfun
)
77 Lisp_Object readcharfun
;
80 register struct buffer
*inbuffer
;
83 if (XTYPE (readcharfun
) == Lisp_Buffer
)
85 inbuffer
= XBUFFER (readcharfun
);
87 if (BUF_PT (inbuffer
) >= BUF_ZV (inbuffer
))
89 c
= *(unsigned char *) BUF_CHAR_ADDRESS (inbuffer
, BUF_PT (inbuffer
));
90 SET_BUF_PT (inbuffer
, BUF_PT (inbuffer
) + 1);
94 if (XTYPE (readcharfun
) == Lisp_Marker
)
96 inbuffer
= XMARKER (readcharfun
)->buffer
;
98 mpos
= marker_position (readcharfun
);
100 if (mpos
> BUF_ZV (inbuffer
) - 1)
102 c
= *(unsigned char *) BUF_CHAR_ADDRESS (inbuffer
, mpos
);
103 if (mpos
!= BUF_GPT (inbuffer
))
104 XMARKER (readcharfun
)->bufpos
++;
106 Fset_marker (readcharfun
, make_number (mpos
+ 1),
107 Fmarker_buffer (readcharfun
));
110 if (EQ (readcharfun
, Qget_file_char
))
111 return getc (instream
);
113 if (XTYPE (readcharfun
) == Lisp_String
)
116 /* This used to be return of a conditional expression,
117 but that truncated -1 to a char on VMS. */
118 if (read_from_string_index
< read_from_string_limit
)
119 c
= XSTRING (readcharfun
)->data
[read_from_string_index
++];
125 tem
= call0 (readcharfun
);
132 /* Unread the character C in the way appropriate for the stream READCHARFUN.
133 If the stream is a user function, call it with the char as argument. */
136 unreadchar (readcharfun
, c
)
137 Lisp_Object readcharfun
;
140 if (XTYPE (readcharfun
) == Lisp_Buffer
)
142 if (XBUFFER (readcharfun
) == current_buffer
)
145 SET_BUF_PT (XBUFFER (readcharfun
), BUF_PT (XBUFFER (readcharfun
)) - 1);
147 else if (XTYPE (readcharfun
) == Lisp_Marker
)
148 XMARKER (readcharfun
)->bufpos
--;
149 else if (XTYPE (readcharfun
) == Lisp_String
)
150 read_from_string_index
--;
151 else if (EQ (readcharfun
, Qget_file_char
))
152 ungetc (c
, instream
);
154 call1 (readcharfun
, make_number (c
));
157 static Lisp_Object
read0 (), read1 (), read_list (), read_vector ();
159 /* get a character from the tty */
161 DEFUN ("read-char", Fread_char
, Sread_char
, 0, 0, 0,
162 "Read a character from the command input (keyboard or macro).\n\
163 It is returned as a number.")
166 register Lisp_Object val
;
170 if (XTYPE (val
) != Lisp_Int
)
172 unread_command_char
= val
;
173 error ("Object read was not a character");
182 #ifdef HAVE_X_WINDOWS
183 DEFUN ("read-event", Fread_event
, Sread_event
, 0, 0, 0,
184 "Read an event object from the input stream.")
187 register Lisp_Object val
;
194 DEFUN ("read-char-exclusive", Fread_char_exclusive
, Sread_char_exclusive
, 0, 0, 0,
195 "Read a character from the command input (keyboard or macro).\n\
196 It is returned as a number. Non character events are ignored.")
199 register Lisp_Object val
;
203 while (XTYPE (val
) != Lisp_Int
)
212 DEFUN ("get-file-char", Fget_file_char
, Sget_file_char
, 0, 0, 0,
213 "Don't use this yourself.")
216 register Lisp_Object val
;
217 XSET (val
, Lisp_Int
, getc (instream
));
221 static void readevalloop ();
222 static Lisp_Object
load_unwind ();
224 DEFUN ("load", Fload
, Sload
, 1, 4, 0,
225 "Execute a file of Lisp code named FILE.\n\
226 First try FILE with `.elc' appended, then try with `.el',\n\
227 then try FILE unmodified.\n\
228 This function searches the directories in `load-path'.\n\
229 If optional second arg NOERROR is non-nil,\n\
230 report no error if FILE doesn't exist.\n\
231 Print messages at start and end of loading unless\n\
232 optional third arg NOMESSAGE is non-nil.\n\
233 If optional fourth arg NOSUFFIX is non-nil, don't try adding\n\
234 suffixes `.elc' or `.el' to the specified name FILE.\n\
235 Return t if file exists.")
236 (str
, noerror
, nomessage
, nosuffix
)
237 Lisp_Object str
, noerror
, nomessage
, nosuffix
;
239 register FILE *stream
;
240 register int fd
= -1;
241 register Lisp_Object lispstream
;
243 int count
= specpdl_ptr
- specpdl
;
248 CHECK_STRING (str
, 0);
249 str
= Fsubstitute_in_file_name (str
);
251 /* Avoid weird lossage with null string as arg,
252 since it would try to load a directory as a Lisp file */
253 if (XSTRING (str
)->size
> 0)
255 fd
= openp (Vload_path
, str
, !NILP (nosuffix
) ? "" : ".elc:.el:",
263 Fsignal (Qfile_error
, Fcons (build_string ("Cannot open load file"),
269 if (!bcmp (&(XSTRING (found
)->data
[XSTRING (found
)->size
- 4]),
275 stat (XSTRING (found
)->data
, &s1
);
276 XSTRING (found
)->data
[XSTRING (found
)->size
- 1] = 0;
277 result
= stat (XSTRING (found
)->data
, &s2
);
278 if (result
>= 0 && (unsigned) s1
.st_mtime
< (unsigned) s2
.st_mtime
)
279 message ("Source file `%s' newer than byte-compiled file",
280 XSTRING (found
)->data
);
281 XSTRING (found
)->data
[XSTRING (found
)->size
- 1] = 'c';
284 stream
= fdopen (fd
, "r");
288 error ("Failure to create stdio stream for %s", XSTRING (str
)->data
);
291 if (NILP (nomessage
))
292 message ("Loading %s...", XSTRING (str
)->data
);
295 /* We may not be able to store STREAM itself as a Lisp_Object pointer
296 since that is guaranteed to work only for data that has been malloc'd.
297 So malloc a full-size pointer, and record the address of that pointer. */
298 ptr
= (FILE **) xmalloc (sizeof (FILE *));
300 XSET (lispstream
, Lisp_Internal_Stream
, (int) ptr
);
301 record_unwind_protect (load_unwind
, lispstream
);
303 readevalloop (Qget_file_char
, stream
, Feval
, 0);
304 unbind_to (count
, Qnil
);
306 /* Run any load-hooks for this file. */
307 temp
= Fassoc (str
, Vafter_load_alist
);
309 Fprogn (Fcdr (temp
));
312 if (!noninteractive
&& NILP (nomessage
))
313 message ("Loading %s...done", XSTRING (str
)->data
);
318 load_unwind (stream
) /* used as unwind-protect function in load */
321 fclose (*(FILE **) XSTRING (stream
));
322 free (XPNTR (stream
));
323 if (--load_in_progress
< 0) load_in_progress
= 0;
329 complete_filename_p (pathname
)
330 Lisp_Object pathname
;
332 register unsigned char *s
= XSTRING (pathname
)->data
;
343 /* Search for a file whose name is STR, looking in directories
344 in the Lisp list PATH, and trying suffixes from SUFFIX.
345 SUFFIX is a string containing possible suffixes separated by colons.
346 On success, returns a file descriptor. On failure, returns -1.
348 EXEC_ONLY nonzero means don't open the files,
349 just look for one that is executable. In this case,
350 returns 1 on success.
352 If STOREPTR is nonzero, it points to a slot where the name of
353 the file actually found should be stored as a Lisp string.
354 Nil is stored there on failure. */
357 openp (path
, str
, suffix
, storeptr
, exec_only
)
358 Lisp_Object path
, str
;
360 Lisp_Object
*storeptr
;
366 register char *fn
= buf
;
369 register Lisp_Object filename
;
375 if (complete_filename_p (str
))
378 for (; !NILP (path
); path
= Fcdr (path
))
382 filename
= Fexpand_file_name (str
, Fcar (path
));
383 if (!complete_filename_p (filename
))
384 /* If there are non-absolute elts in PATH (eg ".") */
385 /* Of course, this could conceivably lose if luser sets
386 default-directory to be something non-absolute... */
388 filename
= Fexpand_file_name (filename
, current_buffer
->directory
);
389 if (!complete_filename_p (filename
))
390 /* Give up on this path element! */
394 /* Calculate maximum size of any filename made from
395 this path element/specified file name and any possible suffix. */
396 want_size
= strlen (suffix
) + XSTRING (filename
)->size
+ 1;
397 if (fn_size
< want_size
)
398 fn
= (char *) alloca (fn_size
= 100 + want_size
);
402 /* Loop over suffixes. */
405 char *esuffix
= (char *) index (nsuffix
, ':');
406 int lsuffix
= esuffix
? esuffix
- nsuffix
: strlen (nsuffix
);
408 /* Concatenate path element/specified name with the suffix. */
409 strncpy (fn
, XSTRING (filename
)->data
, XSTRING (filename
)->size
);
410 fn
[XSTRING (filename
)->size
] = 0;
411 if (lsuffix
!= 0) /* Bug happens on CCI if lsuffix is 0. */
412 strncat (fn
, nsuffix
, lsuffix
);
414 /* Ignore file if it's a directory. */
415 if (stat (fn
, &st
) >= 0
416 && (st
.st_mode
& S_IFMT
) != S_IFDIR
)
418 /* Check that we can access or open it. */
420 fd
= (access (fn
, X_OK
) == 0) ? 1 : -1;
422 fd
= open (fn
, 0, 0);
426 /* We succeeded; return this descriptor and filename. */
428 *storeptr
= build_string (fn
);
433 /* Advance to next suffix. */
436 nsuffix
+= lsuffix
+ 1;
438 if (absolute
) return -1;
446 unreadpure () /* Used as unwind-protect function in readevalloop */
453 readevalloop (readcharfun
, stream
, evalfun
, printflag
)
454 Lisp_Object readcharfun
;
456 Lisp_Object (*evalfun
) ();
460 register Lisp_Object val
;
461 int count
= specpdl_ptr
- specpdl
;
463 specbind (Qstandard_input
, readcharfun
);
471 while ((c
= READCHAR
) != '\n' && c
!= -1);
475 if (c
== ' ' || c
== '\t' || c
== '\n' || c
== '\f') continue;
477 if (!NILP (Vpurify_flag
) && c
== '(')
479 record_unwind_protect (unreadpure
, Qnil
);
480 val
= read_list (-1, readcharfun
);
481 unbind_to (count
+ 1, Qnil
);
486 val
= read0 (readcharfun
);
489 val
= (*evalfun
) (val
);
492 Vvalues
= Fcons (val
, Vvalues
);
493 if (EQ (Vstandard_output
, Qt
))
500 unbind_to (count
, Qnil
);
505 DEFUN ("eval-buffer", Feval_buffer
, Seval_buffer
, 0, 2, "",
506 "Execute the current buffer as Lisp code.\n\
507 Programs can pass two arguments, BUFFER and PRINTFLAG.\n\
508 BUFFER is the buffer to evaluate (nil means use current buffer).\n\
509 PRINTFLAG controls printing of output:\n\
510 nil means discard it; anything else is stream for print.\n\
512 If there is no error, point does not move. If there is an error,\n\
513 point remains at the end of the last character read from the buffer.")
515 Lisp_Object bufname
, printflag
;
517 int count
= specpdl_ptr
- specpdl
;
518 Lisp_Object tem
, buf
;
521 buf
= Fcurrent_buffer ();
523 buf
= Fget_buffer (bufname
);
525 error ("No such buffer.");
527 if (NILP (printflag
))
531 specbind (Qstandard_output
, tem
);
532 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
533 BUF_SET_PT (XBUFFER (buf
), BUF_BEGV (XBUFFER (buf
)));
534 readevalloop (buf
, 0, Feval
, !NILP (printflag
));
541 DEFUN ("eval-current-buffer", Feval_current_buffer
, Seval_current_buffer
, 0, 1, "",
542 "Execute the current buffer as Lisp code.\n\
543 Programs can pass argument PRINTFLAG which controls printing of output:\n\
544 nil means discard it; anything else is stream for print.\n\
546 If there is no error, point does not move. If there is an error,\n\
547 point remains at the end of the last character read from the buffer.")
549 Lisp_Object printflag
;
551 int count
= specpdl_ptr
- specpdl
;
554 if (NILP (printflag
))
558 specbind (Qstandard_output
, tem
);
559 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
561 readevalloop (Fcurrent_buffer (), 0, Feval
, !NILP (printflag
));
562 return unbind_to (count
, Qnil
);
566 DEFUN ("eval-region", Feval_region
, Seval_region
, 2, 3, "r",
567 "Execute the region as Lisp code.\n\
568 When called from programs, expects two arguments,\n\
569 giving starting and ending indices in the current buffer\n\
570 of the text to be executed.\n\
571 Programs can pass third argument PRINTFLAG which controls output:\n\
572 nil means discard it; anything else is stream for printing it.\n\
574 If there is no error, point does not move. If there is an error,\n\
575 point remains at the end of the last character read from the buffer.")
577 Lisp_Object b
, e
, printflag
;
579 int count
= specpdl_ptr
- specpdl
;
582 if (NILP (printflag
))
586 specbind (Qstandard_output
, tem
);
588 if (NILP (printflag
))
589 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
590 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
592 /* This both uses b and checks its type. */
594 Fnarrow_to_region (make_number (BEGV
), e
);
595 readevalloop (Fcurrent_buffer (), 0, Feval
, !NILP (printflag
));
597 return unbind_to (count
, Qnil
);
600 #endif /* standalone */
602 DEFUN ("read", Fread
, Sread
, 0, 1, 0,
603 "Read one Lisp expression as text from STREAM, return as Lisp object.\n\
604 If STREAM is nil, use the value of `standard-input' (which see).\n\
605 STREAM or the value of `standard-input' may be:\n\
606 a buffer (read from point and advance it)\n\
607 a marker (read from where it points and advance it)\n\
608 a function (call it with no arguments for each character,\n\
609 call it with a char as argument to push a char back)\n\
610 a string (takes text from string, starting at the beginning)\n\
611 t (read text line using minibuffer and use it).")
613 Lisp_Object readcharfun
;
615 extern Lisp_Object
Fread_minibuffer ();
617 if (NILP (readcharfun
))
618 readcharfun
= Vstandard_input
;
619 if (EQ (readcharfun
, Qt
))
620 readcharfun
= Qread_char
;
623 if (EQ (readcharfun
, Qread_char
))
624 return Fread_minibuffer (build_string ("Lisp expression: "), Qnil
);
627 if (XTYPE (readcharfun
) == Lisp_String
)
628 return Fcar (Fread_from_string (readcharfun
, Qnil
, Qnil
));
630 return read0 (readcharfun
);
633 DEFUN ("read-from-string", Fread_from_string
, Sread_from_string
, 1, 3, 0,
634 "Read one Lisp expression which is represented as text by STRING.\n\
635 Returns a cons: (OBJECT-READ . FINAL-STRING-INDEX).\n\
636 START and END optionally delimit a substring of STRING from which to read;\n\
637 they default to 0 and (length STRING) respectively.")
639 Lisp_Object string
, start
, end
;
641 int startval
, endval
;
644 CHECK_STRING (string
,0);
647 endval
= XSTRING (string
)->size
;
649 { CHECK_NUMBER (end
,2);
651 if (endval
< 0 || endval
> XSTRING (string
)->size
)
652 args_out_of_range (string
, end
);
658 { CHECK_NUMBER (start
,1);
659 startval
= XINT (start
);
660 if (startval
< 0 || startval
> endval
)
661 args_out_of_range (string
, start
);
664 read_from_string_index
= startval
;
665 read_from_string_limit
= endval
;
667 tem
= read0 (string
);
668 return Fcons (tem
, make_number (read_from_string_index
));
671 /* Use this for recursive reads, in contexts where internal tokens are not allowed. */
675 Lisp_Object readcharfun
;
677 register Lisp_Object val
;
680 val
= read1 (readcharfun
);
681 if (XTYPE (val
) == Lisp_Internal
)
684 return Fsignal (Qinvalid_read_syntax
, Fcons (make_string (&c
, 1), Qnil
));
690 static int read_buffer_size
;
691 static char *read_buffer
;
694 read_escape (readcharfun
)
695 Lisp_Object readcharfun
;
697 register int c
= READCHAR
;
722 error ("Invalid escape character syntax");
725 c
= read_escape (readcharfun
);
731 error ("Invalid escape character syntax");
735 c
= read_escape (readcharfun
);
739 return (c
& (0200 | 037));
749 /* An octal escape, as in ANSI C. */
751 register int i
= c
- '0';
752 register int count
= 0;
755 if ((c
= READCHAR
) >= '0' && c
<= '7')
770 /* A hex escape, as in ANSI C. */
776 if (c
>= '0' && c
<= '9')
781 else if ((c
>= 'a' && c
<= 'f')
782 || (c
>= 'A' && c
<= 'F'))
785 if (c
>= 'a' && c
<= 'f')
806 register Lisp_Object readcharfun
;
813 if (c
< 0) return Fsignal (Qend_of_file
, Qnil
);
818 return read_list (0, readcharfun
);
821 return read_vector (readcharfun
);
826 register Lisp_Object val
;
827 XSET (val
, Lisp_Internal
, c
);
835 /* Accept compiled functions at read-time so that we don't have to
836 build them using function calls. */
837 Lisp_Object tmp
= read_vector (readcharfun
);
838 return Fmake_byte_code (XVECTOR(tmp
)->size
, XVECTOR (tmp
)->contents
);
841 return Fsignal (Qinvalid_read_syntax
, Fcons (make_string ("#", 1), Qnil
));
844 while ((c
= READCHAR
) >= 0 && c
!= '\n');
849 return Fcons (Qquote
, Fcons (read0 (readcharfun
), Qnil
));
854 register Lisp_Object val
;
857 if (c
< 0) return Fsignal (Qend_of_file
, Qnil
);
860 XSET (val
, Lisp_Int
, read_escape (readcharfun
));
862 XSET (val
, Lisp_Int
, c
);
869 register char *p
= read_buffer
;
870 register char *end
= read_buffer
+ read_buffer_size
;
874 while ((c
= READCHAR
) >= 0
879 char *new = (char *) xrealloc (read_buffer
, read_buffer_size
*= 2);
880 p
+= new - read_buffer
;
881 read_buffer
+= new - read_buffer
;
882 end
= read_buffer
+ read_buffer_size
;
885 c
= read_escape (readcharfun
);
886 /* c is -1 if \ newline has just been seen */
889 if (p
== read_buffer
)
895 if (c
< 0) return Fsignal (Qend_of_file
, Qnil
);
897 /* If purifying, and string starts with \ newline,
898 return zero instead. This is for doc strings
899 that we are really going to find in etc/DOC.nn.nn */
900 if (!NILP (Vpurify_flag
) && NILP (Vdoc_file_name
) && cancel
)
901 return make_number (0);
904 return make_pure_string (read_buffer
, p
- read_buffer
);
906 return make_string (read_buffer
, p
- read_buffer
);
911 #ifdef LISP_FLOAT_TYPE
912 /* If a period is followed by a number, then we should read it
913 as a floating point number. Otherwise, it denotes a dotted
915 int next_char
= READCHAR
;
918 if (! isdigit (next_char
))
921 register Lisp_Object val
;
922 XSET (val
, Lisp_Internal
, c
);
926 /* Otherwise, we fall through! Note that the atom-reading loop
927 below will now loop at least once, assuring that we will not
928 try to UNREAD two characters in a row. */
931 if (c
<= 040) goto retry
;
933 register char *p
= read_buffer
;
936 register char *end
= read_buffer
+ read_buffer_size
;
939 !(c
== '\"' || c
== '\'' || c
== ';' || c
== '?'
940 || c
== '(' || c
== ')'
941 #ifndef LISP_FLOAT_TYPE
942 /* If we have floating-point support, then we need
943 to allow <digits><dot><digits>. */
945 #endif /* not LISP_FLOAT_TYPE */
946 || c
== '[' || c
== ']' || c
== '#'
951 register char *new = (char *) xrealloc (read_buffer
, read_buffer_size
*= 2);
952 p
+= new - read_buffer
;
953 read_buffer
+= new - read_buffer
;
954 end
= read_buffer
+ read_buffer_size
;
964 char *new = (char *) xrealloc (read_buffer
, read_buffer_size
*= 2);
965 p
+= new - read_buffer
;
966 read_buffer
+= new - read_buffer
;
967 /* end = read_buffer + read_buffer_size; */
974 /* Is it an integer? */
977 register Lisp_Object val
;
979 if (*p1
== '+' || *p1
== '-') p1
++;
982 while (p1
!= p
&& (c
= *p1
) >= '0' && c
<= '9') p1
++;
986 XSET (val
, Lisp_Int
, atoi (read_buffer
));
990 #ifdef LISP_FLOAT_TYPE
991 if (isfloat_string (read_buffer
))
992 return make_float (atof (read_buffer
));
996 return intern (read_buffer
);
1001 #ifdef LISP_FLOAT_TYPE
1016 if (*cp
== '+' || *cp
== '-')
1022 while (isdigit (*cp
))
1033 while (isdigit (*cp
))
1041 if ((*cp
== '+') || (*cp
== '-'))
1047 while (isdigit (*cp
))
1051 && (state
== (LEAD_INT
|DOT_CHAR
|TRAIL_INT
)
1052 || state
== (LEAD_INT
|E_CHAR
|EXP_INT
)
1053 || state
== (LEAD_INT
|DOT_CHAR
|TRAIL_INT
|E_CHAR
|EXP_INT
)));
1055 #endif /* LISP_FLOAT_TYPE */
1058 read_vector (readcharfun
)
1059 Lisp_Object readcharfun
;
1063 register Lisp_Object
*ptr
;
1064 register Lisp_Object tem
, vector
;
1065 register struct Lisp_Cons
*otem
;
1068 tem
= read_list (1, readcharfun
);
1069 len
= Flength (tem
);
1070 vector
= (read_pure
? make_pure_vector (XINT (len
)) : Fmake_vector (len
, Qnil
));
1073 size
= XVECTOR (vector
)->size
;
1074 ptr
= XVECTOR (vector
)->contents
;
1075 for (i
= 0; i
< size
; i
++)
1077 ptr
[i
] = read_pure
? Fpurecopy (Fcar (tem
)) : Fcar (tem
);
1085 /* flag = 1 means check for ] to terminate rather than ) and .
1086 flag = -1 means check for starting with defun
1087 and make structure pure. */
1090 read_list (flag
, readcharfun
)
1092 register Lisp_Object readcharfun
;
1094 /* -1 means check next element for defun,
1095 0 means don't check,
1096 1 means already checked and found defun. */
1097 int defunflag
= flag
< 0 ? -1 : 0;
1098 Lisp_Object val
, tail
;
1099 register Lisp_Object elt
, tem
;
1100 struct gcpro gcpro1
, gcpro2
;
1108 elt
= read1 (readcharfun
);
1110 if (XTYPE (elt
) == Lisp_Internal
)
1114 if (XINT (elt
) == ']')
1116 return Fsignal (Qinvalid_read_syntax
, Fcons (make_string (") or . in a vector", 18), Qnil
));
1118 if (XINT (elt
) == ')')
1120 if (XINT (elt
) == '.')
1124 XCONS (tail
)->cdr
= read0 (readcharfun
);
1126 val
= read0 (readcharfun
);
1127 elt
= read1 (readcharfun
);
1129 if (XTYPE (elt
) == Lisp_Internal
&& XINT (elt
) == ')')
1131 return Fsignal (Qinvalid_read_syntax
, Fcons (make_string (". in wrong context", 18), Qnil
));
1133 return Fsignal (Qinvalid_read_syntax
, Fcons (make_string ("] in a list", 11), Qnil
));
1135 tem
= (read_pure
&& flag
<= 0
1136 ? pure_cons (elt
, Qnil
)
1137 : Fcons (elt
, Qnil
));
1139 XCONS (tail
)->cdr
= tem
;
1144 defunflag
= EQ (elt
, Qdefun
);
1145 else if (defunflag
> 0)
1150 Lisp_Object Vobarray
;
1151 Lisp_Object initial_obarray
;
1154 check_obarray (obarray
)
1155 Lisp_Object obarray
;
1157 while (XTYPE (obarray
) != Lisp_Vector
|| XVECTOR (obarray
)->size
== 0)
1159 /* If Vobarray is now invalid, force it to be valid. */
1160 if (EQ (Vobarray
, obarray
)) Vobarray
= initial_obarray
;
1162 obarray
= wrong_type_argument (Qvectorp
, obarray
);
1167 static int hash_string ();
1168 Lisp_Object
oblookup ();
1175 int len
= strlen (str
);
1176 Lisp_Object obarray
= Vobarray
;
1178 if (XTYPE (obarray
) != Lisp_Vector
|| XVECTOR (obarray
)->size
== 0)
1179 obarray
= check_obarray (obarray
);
1180 tem
= oblookup (obarray
, str
, len
);
1181 if (XTYPE (tem
) == Lisp_Symbol
)
1183 return Fintern ((!NILP (Vpurify_flag
)
1184 ? make_pure_string (str
, len
)
1185 : make_string (str
, len
)),
1189 DEFUN ("intern", Fintern
, Sintern
, 1, 2, 0,
1190 "Return the canonical symbol whose name is STRING.\n\
1191 If there is none, one is created by this function and returned.\n\
1192 A second optional argument specifies the obarray to use;\n\
1193 it defaults to the value of `obarray'.")
1195 Lisp_Object str
, obarray
;
1197 register Lisp_Object tem
, sym
, *ptr
;
1199 if (NILP (obarray
)) obarray
= Vobarray
;
1200 obarray
= check_obarray (obarray
);
1202 CHECK_STRING (str
, 0);
1204 tem
= oblookup (obarray
, XSTRING (str
)->data
, XSTRING (str
)->size
);
1205 if (XTYPE (tem
) != Lisp_Int
)
1208 if (!NILP (Vpurify_flag
))
1209 str
= Fpurecopy (str
);
1210 sym
= Fmake_symbol (str
);
1212 ptr
= &XVECTOR (obarray
)->contents
[XINT (tem
)];
1213 if (XTYPE (*ptr
) == Lisp_Symbol
)
1214 XSYMBOL (sym
)->next
= XSYMBOL (*ptr
);
1216 XSYMBOL (sym
)->next
= 0;
1221 DEFUN ("intern-soft", Fintern_soft
, Sintern_soft
, 1, 2, 0,
1222 "Return the canonical symbol whose name is STRING, or nil if none exists.\n\
1223 A second optional argument specifies the obarray to use;\n\
1224 it defaults to the value of `obarray'.")
1226 Lisp_Object str
, obarray
;
1228 register Lisp_Object tem
;
1230 if (NILP (obarray
)) obarray
= Vobarray
;
1231 obarray
= check_obarray (obarray
);
1233 CHECK_STRING (str
, 0);
1235 tem
= oblookup (obarray
, XSTRING (str
)->data
, XSTRING (str
)->size
);
1236 if (XTYPE (tem
) != Lisp_Int
)
1242 oblookup (obarray
, ptr
, size
)
1243 Lisp_Object obarray
;
1248 register Lisp_Object tail
;
1249 Lisp_Object bucket
, tem
;
1251 if (XTYPE (obarray
) != Lisp_Vector
||
1252 (obsize
= XVECTOR (obarray
)->size
) == 0)
1254 obarray
= check_obarray (obarray
);
1255 obsize
= XVECTOR (obarray
)->size
;
1257 /* Combining next two lines breaks VMS C 2.3. */
1258 hash
= hash_string (ptr
, size
);
1260 bucket
= XVECTOR (obarray
)->contents
[hash
];
1261 if (XFASTINT (bucket
) == 0)
1263 else if (XTYPE (bucket
) != Lisp_Symbol
)
1264 error ("Bad data in guts of obarray"); /* Like CADR error message */
1265 else for (tail
= bucket
; ; XSET (tail
, Lisp_Symbol
, XSYMBOL (tail
)->next
))
1267 if (XSYMBOL (tail
)->name
->size
== size
&&
1268 !bcmp (XSYMBOL (tail
)->name
->data
, ptr
, size
))
1270 else if (XSYMBOL (tail
)->next
== 0)
1273 XSET (tem
, Lisp_Int
, hash
);
1278 hash_string (ptr
, len
)
1282 register unsigned char *p
= ptr
;
1283 register unsigned char *end
= p
+ len
;
1284 register unsigned char c
;
1285 register int hash
= 0;
1290 if (c
>= 0140) c
-= 40;
1291 hash
= ((hash
<<3) + (hash
>>28) + c
);
1293 return hash
& 07777777777;
1297 map_obarray (obarray
, fn
, arg
)
1298 Lisp_Object obarray
;
1303 register Lisp_Object tail
;
1304 CHECK_VECTOR (obarray
, 1);
1305 for (i
= XVECTOR (obarray
)->size
- 1; i
>= 0; i
--)
1307 tail
= XVECTOR (obarray
)->contents
[i
];
1308 if (XFASTINT (tail
) != 0)
1312 if (XSYMBOL (tail
)->next
== 0)
1314 XSET (tail
, Lisp_Symbol
, XSYMBOL (tail
)->next
);
1319 mapatoms_1 (sym
, function
)
1320 Lisp_Object sym
, function
;
1322 call1 (function
, sym
);
1325 DEFUN ("mapatoms", Fmapatoms
, Smapatoms
, 1, 2, 0,
1326 "Call FUNCTION on every symbol in OBARRAY.\n\
1327 OBARRAY defaults to the value of `obarray'.")
1329 Lisp_Object function
, obarray
;
1333 if (NILP (obarray
)) obarray
= Vobarray
;
1334 obarray
= check_obarray (obarray
);
1336 map_obarray (obarray
, mapatoms_1
, function
);
1340 #define OBARRAY_SIZE 509
1345 Lisp_Object oblength
;
1349 XFASTINT (oblength
) = OBARRAY_SIZE
;
1351 Qnil
= Fmake_symbol (make_pure_string ("nil", 3));
1352 Vobarray
= Fmake_vector (oblength
, make_number (0));
1353 initial_obarray
= Vobarray
;
1354 staticpro (&initial_obarray
);
1355 /* Intern nil in the obarray */
1356 /* These locals are to kludge around a pyramid compiler bug. */
1357 hash
= hash_string ("nil", 3);
1358 /* Separate statement here to avoid VAXC bug. */
1359 hash
%= OBARRAY_SIZE
;
1360 tem
= &XVECTOR (Vobarray
)->contents
[hash
];
1363 Qunbound
= Fmake_symbol (make_pure_string ("unbound", 7));
1364 XSYMBOL (Qnil
)->function
= Qunbound
;
1365 XSYMBOL (Qunbound
)->value
= Qunbound
;
1366 XSYMBOL (Qunbound
)->function
= Qunbound
;
1369 XSYMBOL (Qnil
)->value
= Qnil
;
1370 XSYMBOL (Qnil
)->plist
= Qnil
;
1371 XSYMBOL (Qt
)->value
= Qt
;
1373 /* Qt is correct even if CANNOT_DUMP. loadup.el will set to nil at end. */
1376 Qvariable_documentation
= intern ("variable-documentation");
1378 read_buffer_size
= 100;
1379 read_buffer
= (char *) malloc (read_buffer_size
);
1384 struct Lisp_Subr
*sname
;
1387 sym
= intern (sname
->symbol_name
);
1388 XSET (XSYMBOL (sym
)->function
, Lisp_Subr
, sname
);
1391 #ifdef NOTDEF /* use fset in subr.el now */
1393 defalias (sname
, string
)
1394 struct Lisp_Subr
*sname
;
1398 sym
= intern (string
);
1399 XSET (XSYMBOL (sym
)->function
, Lisp_Subr
, sname
);
1403 /* New replacement for DefIntVar; it ignores the doc string argument
1404 on the assumption that make-docfile will handle that. */
1405 /* Define an "integer variable"; a symbol whose value is forwarded
1406 to a C variable of type int. Sample call: */
1407 /* DEFVARINT ("indent-tabs-mode", &indent_tabs_mode, "Documentation"); */
1410 defvar_int (namestring
, address
, doc
)
1416 sym
= intern (namestring
);
1417 XSET (XSYMBOL (sym
)->value
, Lisp_Intfwd
, address
);
1420 /* Similar but define a variable whose value is T if address contains 1,
1421 NIL if address contains 0 */
1424 defvar_bool (namestring
, address
, doc
)
1430 sym
= intern (namestring
);
1431 XSET (XSYMBOL (sym
)->value
, Lisp_Boolfwd
, address
);
1434 /* Similar but define a variable whose value is the Lisp Object stored at address. */
1437 defvar_lisp (namestring
, address
, doc
)
1439 Lisp_Object
*address
;
1443 sym
= intern (namestring
);
1444 XSET (XSYMBOL (sym
)->value
, Lisp_Objfwd
, address
);
1445 staticpro (address
);
1448 /* Similar but don't request gc-marking of the C variable.
1449 Used when that variable will be gc-marked for some other reason,
1450 since marking the same slot twice can cause trouble with strings. */
1453 defvar_lisp_nopro (namestring
, address
, doc
)
1455 Lisp_Object
*address
;
1459 sym
= intern (namestring
);
1460 XSET (XSYMBOL (sym
)->value
, Lisp_Objfwd
, address
);
1465 /* Similar but define a variable whose value is the Lisp Object stored in
1466 the current buffer. address is the address of the slot in the buffer that is current now. */
1469 defvar_per_buffer (namestring
, address
, doc
)
1471 Lisp_Object
*address
;
1476 extern struct buffer buffer_local_symbols
;
1478 sym
= intern (namestring
);
1479 offset
= (char *)address
- (char *)current_buffer
;
1481 XSET (XSYMBOL (sym
)->value
, Lisp_Buffer_Objfwd
,
1482 (Lisp_Object
*) offset
);
1483 *(Lisp_Object
*)(offset
+ (char *)&buffer_local_symbols
) = sym
;
1484 if (*(int *)(offset
+ (char *)&buffer_local_flags
) == 0)
1485 /* Did a DEFVAR_PER_BUFFER without initializing the corresponding
1486 slot of buffer_local_flags */
1490 #endif /* standalone */
1496 /* Compute the default load-path. */
1498 normal
= PATH_LOADSEARCH
;
1499 Vload_path
= decode_env_path (0, normal
);
1501 if (NILP (Vpurify_flag
))
1502 normal
= PATH_LOADSEARCH
;
1504 normal
= PATH_DUMPLOADSEARCH
;
1506 /* In a dumped Emacs, we normally have to reset the value of
1507 Vload_path from PATH_LOADSEARCH, since the value that was dumped
1508 uses ../lisp, instead of the path of the installed elisp
1509 libraries. However, if it appears that Vload_path was changed
1510 from the default before dumping, don't override that value. */
1513 Lisp_Object dump_path
;
1515 dump_path
= decode_env_path (0, PATH_DUMPLOADSEARCH
);
1516 if (! NILP (Fequal (dump_path
, Vload_path
)))
1517 Vload_path
= decode_env_path (0, normal
);
1520 Vload_path
= decode_env_path (0, normal
);
1523 /* Warn if dirs in the *standard* path don't exist. */
1525 Lisp_Object path_tail
;
1527 for (path_tail
= Vload_path
;
1529 path_tail
= XCONS (path_tail
)->cdr
)
1531 Lisp_Object dirfile
;
1532 dirfile
= Fcar (path_tail
);
1533 if (XTYPE (dirfile
) == Lisp_String
)
1535 dirfile
= Fdirectory_file_name (dirfile
);
1536 if (access (XSTRING (dirfile
)->data
, 0) < 0)
1537 printf ("Warning: lisp library (%s) does not exist.\n",
1538 XSTRING (Fcar (path_tail
))->data
);
1543 /* If the EMACSLOADPATH environment variable is set, use its value.
1544 This doesn't apply if we're dumping. */
1545 if (NILP (Vpurify_flag
)
1546 && egetenv ("EMACSLOADPATH"))
1547 Vload_path
= decode_env_path ("EMACSLOADPATH", normal
);
1551 load_in_progress
= 0;
1558 defsubr (&Sread_from_string
);
1560 defsubr (&Sintern_soft
);
1562 defsubr (&Seval_buffer
);
1563 defsubr (&Seval_region
);
1564 defsubr (&Sread_char
);
1565 defsubr (&Sread_char_exclusive
);
1566 #ifdef HAVE_X_WINDOWS
1567 defsubr (&Sread_event
);
1568 #endif /* HAVE_X_WINDOWS */
1569 defsubr (&Sget_file_char
);
1570 defsubr (&Smapatoms
);
1572 DEFVAR_LISP ("obarray", &Vobarray
,
1573 "Symbol table for use by `intern' and `read'.\n\
1574 It is a vector whose length ought to be prime for best results.\n\
1575 The vector's contents don't make sense if examined from Lisp programs;\n\
1576 to find all the symbols in an obarray, use `mapatoms'.");
1578 DEFVAR_LISP ("values", &Vvalues
,
1579 "List of values of all expressions which were read, evaluated and printed.\n\
1580 Order is reverse chronological.");
1582 DEFVAR_LISP ("standard-input", &Vstandard_input
,
1583 "Stream for read to get input from.\n\
1584 See documentation of `read' for possible values.");
1585 Vstandard_input
= Qt
;
1587 DEFVAR_LISP ("load-path", &Vload_path
,
1588 "*List of directories to search for files to load.\n\
1589 Each element is a string (directory name) or nil (try default directory).\n\
1590 Initialized based on EMACSLOADPATH environment variable, if any,\n\
1591 otherwise to default specified in by file `paths.h' when Emacs was built.");
1593 DEFVAR_BOOL ("load-in-progress", &load_in_progress
,
1594 "Non-nil iff inside of `load'.");
1596 DEFVAR_LISP ("after-load-alist", &Vafter_load_alist
,
1597 "An alist of expressions to be evalled when particular files are loaded.\n\
1598 Each element looks like (FILENAME FORMS...).\n\
1599 When `load' is run and the file-name argument is FILENAME,\n\
1600 the FORMS in the corresponding element are executed at the end of loading.\n\n\
1601 FILENAME must match exactly! Normally FILENAME is the name of a library,\n\
1602 with no directory specified, since that is how `load' is normally called.\n\
1603 An error in FORMS does not undo the load,\n\
1604 but does prevent execution of the rest of the FORMS.");
1605 Vafter_load_alist
= Qnil
;
1607 Qstandard_input
= intern ("standard-input");
1608 staticpro (&Qstandard_input
);
1610 Qread_char
= intern ("read-char");
1611 staticpro (&Qread_char
);
1613 Qget_file_char
= intern ("get-file-char");
1614 staticpro (&Qget_file_char
);