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>
37 #include <sys/inode.h>
44 #ifdef LISP_FLOAT_TYPE
46 #endif /* LISP_FLOAT_TYPE */
48 Lisp_Object Qread_char
, Qget_file_char
, Qstandard_input
;
49 Lisp_Object Qvariable_documentation
, Vvalues
, Vstandard_input
, Vafter_load_alist
;
51 /* non-zero if inside `load' */
54 /* Search path for files to be loaded. */
55 Lisp_Object Vload_path
;
57 /* File for get_file_char to read from. Use by load */
58 static FILE *instream
;
60 /* When nonzero, read conses in pure space */
63 /* For use within read-from-string (this reader is non-reentrant!!) */
64 static int read_from_string_index
;
65 static int read_from_string_limit
;
67 /* Handle unreading and rereading of characters.
68 Write READCHAR to read a character,
69 UNREAD(c) to unread c to be read again. */
71 #define READCHAR readchar (readcharfun)
72 #define UNREAD(c) unreadchar (readcharfun, c)
75 readchar (readcharfun
)
76 Lisp_Object readcharfun
;
79 register struct buffer
*inbuffer
;
82 if (XTYPE (readcharfun
) == Lisp_Buffer
)
84 inbuffer
= XBUFFER (readcharfun
);
86 if (BUF_PT (inbuffer
) >= BUF_ZV (inbuffer
))
88 c
= *(unsigned char *) BUF_CHAR_ADDRESS (inbuffer
, BUF_PT (inbuffer
));
89 SET_BUF_PT (inbuffer
, BUF_PT (inbuffer
) + 1);
93 if (XTYPE (readcharfun
) == Lisp_Marker
)
95 inbuffer
= XMARKER (readcharfun
)->buffer
;
97 mpos
= marker_position (readcharfun
);
99 if (mpos
> BUF_ZV (inbuffer
) - 1)
101 c
= *(unsigned char *) BUF_CHAR_ADDRESS (inbuffer
, mpos
);
102 if (mpos
!= BUF_GPT (inbuffer
))
103 XMARKER (readcharfun
)->bufpos
++;
105 Fset_marker (readcharfun
, make_number (mpos
+ 1),
106 Fmarker_buffer (readcharfun
));
109 if (EQ (readcharfun
, Qget_file_char
))
110 return getc (instream
);
112 if (XTYPE (readcharfun
) == Lisp_String
)
115 /* This used to be return of a conditional expression,
116 but that truncated -1 to a char on VMS. */
117 if (read_from_string_index
< read_from_string_limit
)
118 c
= XSTRING (readcharfun
)->data
[read_from_string_index
++];
124 tem
= call0 (readcharfun
);
131 /* Unread the character C in the way appropriate for the stream READCHARFUN.
132 If the stream is a user function, call it with the char as argument. */
135 unreadchar (readcharfun
, c
)
136 Lisp_Object readcharfun
;
139 if (XTYPE (readcharfun
) == Lisp_Buffer
)
141 if (XBUFFER (readcharfun
) == current_buffer
)
144 SET_BUF_PT (XBUFFER (readcharfun
), BUF_PT (XBUFFER (readcharfun
)) - 1);
146 else if (XTYPE (readcharfun
) == Lisp_Marker
)
147 XMARKER (readcharfun
)->bufpos
--;
148 else if (XTYPE (readcharfun
) == Lisp_String
)
149 read_from_string_index
--;
150 else if (EQ (readcharfun
, Qget_file_char
))
151 ungetc (c
, instream
);
153 call1 (readcharfun
, make_number (c
));
156 static Lisp_Object
read0 (), read1 (), read_list (), read_vector ();
158 /* get a character from the tty */
160 DEFUN ("read-char", Fread_char
, Sread_char
, 0, 0, 0,
161 "Read a character from the command input (keyboard or macro).\n\
162 It is returned as a number.")
165 register Lisp_Object val
;
169 if (XTYPE (val
) != Lisp_Int
)
171 unread_command_char
= val
;
172 error ("Object read was not a character");
181 #ifdef HAVE_X_WINDOWS
182 DEFUN ("read-event", Fread_event
, Sread_event
, 0, 0, 0,
183 "Read an event object from the input stream.")
186 register Lisp_Object val
;
192 DEFUN ("read-char-exclusive", Fread_char_exclusive
, Sread_char_exclusive
, 0, 0, 0,
193 "Read a character from the command input (keyboard or macro).\n\
194 It is returned as a number. Non character events are ignored.")
197 register Lisp_Object val
;
201 while (XTYPE (val
) != Lisp_Int
)
209 #endif /* HAVE_X_WINDOWS */
211 DEFUN ("get-file-char", Fget_file_char
, Sget_file_char
, 0, 0, 0,
212 "Don't use this yourself.")
215 register Lisp_Object val
;
216 XSET (val
, Lisp_Int
, getc (instream
));
220 static void readevalloop ();
221 static Lisp_Object
load_unwind ();
223 DEFUN ("load", Fload
, Sload
, 1, 4, 0,
224 "Execute a file of Lisp code named FILE.\n\
225 First try FILE with `.elc' appended, then try with `.el',\n\
226 then try FILE unmodified.\n\
227 This function searches the directories in `load-path'.\n\
228 If optional second arg NOERROR is non-nil,\n\
229 report no error if FILE doesn't exist.\n\
230 Print messages at start and end of loading unless\n\
231 optional third arg NOMESSAGE is non-nil.\n\
232 If optional fourth arg NOSUFFIX is non-nil, don't try adding\n\
233 suffixes `.elc' or `.el' to the specified name FILE.\n\
234 Return t if file exists.")
235 (str
, noerror
, nomessage
, nosuffix
)
236 Lisp_Object str
, noerror
, nomessage
, nosuffix
;
238 register FILE *stream
;
239 register int fd
= -1;
240 register Lisp_Object lispstream
;
242 int count
= specpdl_ptr
- specpdl
;
247 CHECK_STRING (str
, 0);
248 str
= Fsubstitute_in_file_name (str
);
250 /* Avoid weird lossage with null string as arg,
251 since it would try to load a directory as a Lisp file */
252 if (XSTRING (str
)->size
> 0)
254 fd
= openp (Vload_path
, str
, !NILP (nosuffix
) ? "" : ".elc:.el:",
262 Fsignal (Qfile_error
, Fcons (build_string ("Cannot open load file"),
268 if (!bcmp (&(XSTRING (found
)->data
[XSTRING (found
)->size
- 4]),
274 stat (XSTRING (found
)->data
, &s1
);
275 XSTRING (found
)->data
[XSTRING (found
)->size
- 1] = 0;
276 result
= stat (XSTRING (found
)->data
, &s2
);
277 if (result
>= 0 && (unsigned) s1
.st_mtime
< (unsigned) s2
.st_mtime
)
278 message ("Source file `%s' newer than byte-compiled file",
279 XSTRING (found
)->data
);
280 XSTRING (found
)->data
[XSTRING (found
)->size
- 1] = 'c';
283 stream
= fdopen (fd
, "r");
287 error ("Failure to create stdio stream for %s", XSTRING (str
)->data
);
290 if (NILP (nomessage
))
291 message ("Loading %s...", XSTRING (str
)->data
);
294 /* We may not be able to store STREAM itself as a Lisp_Object pointer
295 since that is guaranteed to work only for data that has been malloc'd.
296 So malloc a full-size pointer, and record the address of that pointer. */
297 ptr
= (FILE **) xmalloc (sizeof (FILE *));
299 XSET (lispstream
, Lisp_Internal_Stream
, (int) ptr
);
300 record_unwind_protect (load_unwind
, lispstream
);
302 readevalloop (Qget_file_char
, stream
, Feval
, 0);
303 unbind_to (count
, Qnil
);
305 /* Run any load-hooks for this file. */
306 temp
= Fassoc (str
, Vafter_load_alist
);
308 Fprogn (Fcdr (temp
));
311 if (!noninteractive
&& NILP (nomessage
))
312 message ("Loading %s...done", XSTRING (str
)->data
);
317 load_unwind (stream
) /* used as unwind-protect function in load */
320 fclose (*(FILE **) XSTRING (stream
));
321 free (XPNTR (stream
));
322 if (--load_in_progress
< 0) load_in_progress
= 0;
328 complete_filename_p (pathname
)
329 Lisp_Object pathname
;
331 register unsigned char *s
= XSTRING (pathname
)->data
;
342 /* Search for a file whose name is STR, looking in directories
343 in the Lisp list PATH, and trying suffixes from SUFFIX.
344 SUFFIX is a string containing possible suffixes separated by colons.
345 On success, returns a file descriptor. On failure, returns -1.
347 EXEC_ONLY nonzero means don't open the files,
348 just look for one that is executable. In this case,
349 returns 1 on success.
351 If STOREPTR is nonzero, it points to a slot where the name of
352 the file actually found should be stored as a Lisp string.
353 Nil is stored there on failure. */
356 openp (path
, str
, suffix
, storeptr
, exec_only
)
357 Lisp_Object path
, str
;
359 Lisp_Object
*storeptr
;
365 register char *fn
= buf
;
368 register Lisp_Object filename
;
374 if (complete_filename_p (str
))
377 for (; !NILP (path
); path
= Fcdr (path
))
381 filename
= Fexpand_file_name (str
, Fcar (path
));
382 if (!complete_filename_p (filename
))
383 /* If there are non-absolute elts in PATH (eg ".") */
384 /* Of course, this could conceivably lose if luser sets
385 default-directory to be something non-absolute... */
387 filename
= Fexpand_file_name (filename
, current_buffer
->directory
);
388 if (!complete_filename_p (filename
))
389 /* Give up on this path element! */
393 /* Calculate maximum size of any filename made from
394 this path element/specified file name and any possible suffix. */
395 want_size
= strlen (suffix
) + XSTRING (filename
)->size
+ 1;
396 if (fn_size
< want_size
)
397 fn
= (char *) alloca (fn_size
= 100 + want_size
);
401 /* Loop over suffixes. */
404 char *esuffix
= (char *) index (nsuffix
, ':');
405 int lsuffix
= esuffix
? esuffix
- nsuffix
: strlen (nsuffix
);
407 /* Concatenate path element/specified name with the suffix. */
408 strncpy (fn
, XSTRING (filename
)->data
, XSTRING (filename
)->size
);
409 fn
[XSTRING (filename
)->size
] = 0;
410 if (lsuffix
!= 0) /* Bug happens on CCI if lsuffix is 0. */
411 strncat (fn
, nsuffix
, lsuffix
);
413 /* Ignore file if it's a directory. */
414 if (stat (fn
, &st
) >= 0
415 && (st
.st_mode
& S_IFMT
) != S_IFDIR
)
417 /* Check that we can access or open it. */
419 fd
= (access (fn
, X_OK
) == 0) ? 1 : -1;
421 fd
= open (fn
, 0, 0);
425 /* We succeeded; return this descriptor and filename. */
427 *storeptr
= build_string (fn
);
432 /* Advance to next suffix. */
435 nsuffix
+= lsuffix
+ 1;
437 if (absolute
) return -1;
445 unreadpure () /* Used as unwind-protect function in readevalloop */
452 readevalloop (readcharfun
, stream
, evalfun
, printflag
)
453 Lisp_Object readcharfun
;
455 Lisp_Object (*evalfun
) ();
459 register Lisp_Object val
;
460 int count
= specpdl_ptr
- specpdl
;
462 specbind (Qstandard_input
, readcharfun
);
470 while ((c
= READCHAR
) != '\n' && c
!= -1);
474 if (c
== ' ' || c
== '\t' || c
== '\n' || c
== '\f') continue;
476 if (!NILP (Vpurify_flag
) && c
== '(')
478 record_unwind_protect (unreadpure
, Qnil
);
479 val
= read_list (-1, readcharfun
);
480 unbind_to (count
+ 1, Qnil
);
485 val
= read0 (readcharfun
);
488 val
= (*evalfun
) (val
);
491 Vvalues
= Fcons (val
, Vvalues
);
492 if (EQ (Vstandard_output
, Qt
))
499 unbind_to (count
, Qnil
);
504 DEFUN ("eval-buffer", Feval_buffer
, Seval_buffer
, 0, 1, "",
505 "Execute the current buffer as Lisp code.\n\
506 Programs can pass two arguments, BUFFER and PRINTFLAG.\n\
507 BUFFER is the buffer to evaluate (nil means use current buffer).\n\
508 PRINTFLAG controls printing of output:\n\
509 nil means discard it; anything else is stream for print.\n\
511 If there is no error, point does not move. If there is an error,\n\
512 point remains at the end of the last character read from the buffer.")
514 Lisp_Object bufname
, printflag
;
516 int count
= specpdl_ptr
- specpdl
;
517 Lisp_Object tem
, buf
;
520 buf
= Fcurrent_buffer ();
522 buf
= Fget_buffer (bufname
);
524 error ("No such buffer.");
526 if (NILP (printflag
))
530 specbind (Qstandard_output
, tem
);
531 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
532 BUF_SET_PT (XBUFFER (buf
), BUF_BEGV (XBUFFER (buf
)));
533 readevalloop (buf
, 0, Feval
, !NILP (printflag
));
540 DEFUN ("eval-current-buffer", Feval_current_buffer
, Seval_current_buffer
, 0, 1, "",
541 "Execute the current buffer as Lisp code.\n\
542 Programs can pass argument PRINTFLAG which controls printing of output:\n\
543 nil means discard it; anything else is stream for print.\n\
545 If there is no error, point does not move. If there is an error,\n\
546 point remains at the end of the last character read from the buffer.")
548 Lisp_Object printflag
;
550 int count
= specpdl_ptr
- specpdl
;
553 if (NILP (printflag
))
557 specbind (Qstandard_output
, tem
);
558 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
560 readevalloop (Fcurrent_buffer (), 0, Feval
, !NILP (printflag
));
561 return unbind_to (count
, Qnil
);
565 DEFUN ("eval-region", Feval_region
, Seval_region
, 2, 3, "r",
566 "Execute the region as Lisp code.\n\
567 When called from programs, expects two arguments,\n\
568 giving starting and ending indices in the current buffer\n\
569 of the text to be executed.\n\
570 Programs can pass third argument PRINTFLAG which controls output:\n\
571 nil means discard it; anything else is stream for printing it.\n\
573 If there is no error, point does not move. If there is an error,\n\
574 point remains at the end of the last character read from the buffer.")
576 Lisp_Object b
, e
, printflag
;
578 int count
= specpdl_ptr
- specpdl
;
581 if (NILP (printflag
))
585 specbind (Qstandard_output
, tem
);
587 if (NILP (printflag
))
588 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
589 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
591 /* This both uses b and checks its type. */
593 Fnarrow_to_region (make_number (BEGV
), e
);
594 readevalloop (Fcurrent_buffer (), 0, Feval
, !NILP (printflag
));
596 return unbind_to (count
, Qnil
);
599 #endif /* standalone */
601 DEFUN ("read", Fread
, Sread
, 0, 1, 0,
602 "Read one Lisp expression as text from STREAM, return as Lisp object.\n\
603 If STREAM is nil, use the value of `standard-input' (which see).\n\
604 STREAM or the value of `standard-input' may be:\n\
605 a buffer (read from point and advance it)\n\
606 a marker (read from where it points and advance it)\n\
607 a function (call it with no arguments for each character,\n\
608 call it with a char as argument to push a char back)\n\
609 a string (takes text from string, starting at the beginning)\n\
610 t (read text line using minibuffer and use it).")
612 Lisp_Object readcharfun
;
614 extern Lisp_Object
Fread_minibuffer ();
616 if (NILP (readcharfun
))
617 readcharfun
= Vstandard_input
;
618 if (EQ (readcharfun
, Qt
))
619 readcharfun
= Qread_char
;
622 if (EQ (readcharfun
, Qread_char
))
623 return Fread_minibuffer (build_string ("Lisp expression: "), Qnil
);
626 if (XTYPE (readcharfun
) == Lisp_String
)
627 return Fcar (Fread_from_string (readcharfun
, Qnil
, Qnil
));
629 return read0 (readcharfun
);
632 DEFUN ("read-from-string", Fread_from_string
, Sread_from_string
, 1, 3, 0,
633 "Read one Lisp expression which is represented as text by STRING.\n\
634 Returns a cons: (OBJECT-READ . FINAL-STRING-INDEX).\n\
635 START and END optionally delimit a substring of STRING from which to read;\n\
636 they default to 0 and (length STRING) respectively.")
638 Lisp_Object string
, start
, end
;
640 int startval
, endval
;
643 CHECK_STRING (string
,0);
646 endval
= XSTRING (string
)->size
;
648 { CHECK_NUMBER (end
,2);
650 if (endval
< 0 || endval
> XSTRING (string
)->size
)
651 args_out_of_range (string
, end
);
657 { CHECK_NUMBER (start
,1);
658 startval
= XINT (start
);
659 if (startval
< 0 || startval
> endval
)
660 args_out_of_range (string
, start
);
663 read_from_string_index
= startval
;
664 read_from_string_limit
= endval
;
666 tem
= read0 (string
);
667 return Fcons (tem
, make_number (read_from_string_index
));
670 /* Use this for recursive reads, in contexts where internal tokens are not allowed. */
674 Lisp_Object readcharfun
;
676 register Lisp_Object val
;
679 val
= read1 (readcharfun
);
680 if (XTYPE (val
) == Lisp_Internal
)
683 return Fsignal (Qinvalid_read_syntax
, Fcons (make_string (&c
, 1), Qnil
));
689 static int read_buffer_size
;
690 static char *read_buffer
;
693 read_escape (readcharfun
)
694 Lisp_Object readcharfun
;
696 register int c
= READCHAR
;
721 error ("Invalid escape character syntax");
724 c
= read_escape (readcharfun
);
730 error ("Invalid escape character syntax");
734 c
= read_escape (readcharfun
);
738 return (c
& (0200 | 037));
748 /* An octal escape, as in ANSI C. */
750 register int i
= c
- '0';
751 register int count
= 0;
754 if ((c
= READCHAR
) >= '0' && c
<= '7')
769 /* A hex escape, as in ANSI C. */
775 if (c
>= '0' && c
<= '9')
780 else if ((c
>= 'a' && c
<= 'f')
781 || (c
>= 'A' && c
<= 'F'))
784 if (c
>= 'a' && c
<= 'f')
805 register Lisp_Object readcharfun
;
812 if (c
< 0) return Fsignal (Qend_of_file
, Qnil
);
817 return read_list (0, readcharfun
);
820 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
);
910 if (c
<= 040) goto retry
;
912 register char *p
= read_buffer
;
915 register char *end
= read_buffer
+ read_buffer_size
;
918 !(c
== '\"' || c
== '\'' || c
== ';' || c
== '?'
919 || c
== '(' || c
== ')'
920 #ifndef LISP_FLOAT_TYPE /* we need to see <number><dot><number> */
922 #endif /* not LISP_FLOAT_TYPE */
923 || c
== '[' || c
== ']' || c
== '#'
928 register char *new = (char *) xrealloc (read_buffer
, read_buffer_size
*= 2);
929 p
+= new - read_buffer
;
930 read_buffer
+= new - read_buffer
;
931 end
= read_buffer
+ read_buffer_size
;
941 char *new = (char *) xrealloc (read_buffer
, read_buffer_size
*= 2);
942 p
+= new - read_buffer
;
943 read_buffer
+= new - read_buffer
;
944 /* end = read_buffer + read_buffer_size; */
951 /* Is it an integer? */
954 register Lisp_Object val
;
956 if (*p1
== '+' || *p1
== '-') p1
++;
959 while (p1
!= p
&& (c
= *p1
) >= '0' && c
<= '9') p1
++;
963 XSET (val
, Lisp_Int
, atoi (read_buffer
));
967 #ifdef LISP_FLOAT_TYPE
968 if (isfloat_string (read_buffer
))
969 return make_float (atof (read_buffer
));
973 return intern (read_buffer
);
978 #ifdef LISP_FLOAT_TYPE
994 if (*cp
== '+' || *cp
== '-')
1000 while (isdigit (*cp
))
1011 while (isdigit (*cp
))
1019 if ((*cp
== '+') || (*cp
== '-'))
1025 while (isdigit (*cp
))
1029 && (state
== (LEAD_INT
|DOT_CHAR
|TRAIL_INT
)
1030 || state
== (LEAD_INT
|E_CHAR
|EXP_INT
)
1031 || state
== (LEAD_INT
|DOT_CHAR
|TRAIL_INT
|E_CHAR
|EXP_INT
)));
1033 #endif /* LISP_FLOAT_TYPE */
1036 read_vector (readcharfun
)
1037 Lisp_Object readcharfun
;
1041 register Lisp_Object
*ptr
;
1042 register Lisp_Object tem
, vector
;
1043 register struct Lisp_Cons
*otem
;
1046 tem
= read_list (1, readcharfun
);
1047 len
= Flength (tem
);
1048 vector
= (read_pure
? make_pure_vector (XINT (len
)) : Fmake_vector (len
, Qnil
));
1051 size
= XVECTOR (vector
)->size
;
1052 ptr
= XVECTOR (vector
)->contents
;
1053 for (i
= 0; i
< size
; i
++)
1055 ptr
[i
] = read_pure
? Fpurecopy (Fcar (tem
)) : Fcar (tem
);
1063 /* flag = 1 means check for ] to terminate rather than ) and .
1064 flag = -1 means check for starting with defun
1065 and make structure pure. */
1068 read_list (flag
, readcharfun
)
1070 register Lisp_Object readcharfun
;
1072 /* -1 means check next element for defun,
1073 0 means don't check,
1074 1 means already checked and found defun. */
1075 int defunflag
= flag
< 0 ? -1 : 0;
1076 Lisp_Object val
, tail
;
1077 register Lisp_Object elt
, tem
;
1078 struct gcpro gcpro1
, gcpro2
;
1086 elt
= read1 (readcharfun
);
1088 if (XTYPE (elt
) == Lisp_Internal
)
1092 if (XINT (elt
) == ']')
1094 return Fsignal (Qinvalid_read_syntax
, Fcons (make_string (") or . in a vector", 18), Qnil
));
1096 if (XINT (elt
) == ')')
1098 if (XINT (elt
) == '.')
1102 XCONS (tail
)->cdr
= read0 (readcharfun
);
1104 val
= read0 (readcharfun
);
1105 elt
= read1 (readcharfun
);
1107 if (XTYPE (elt
) == Lisp_Internal
&& XINT (elt
) == ')')
1109 return Fsignal (Qinvalid_read_syntax
, Fcons (make_string (". in wrong context", 18), Qnil
));
1111 return Fsignal (Qinvalid_read_syntax
, Fcons (make_string ("] in a list", 11), Qnil
));
1113 tem
= (read_pure
&& flag
<= 0
1114 ? pure_cons (elt
, Qnil
)
1115 : Fcons (elt
, Qnil
));
1117 XCONS (tail
)->cdr
= tem
;
1122 defunflag
= EQ (elt
, Qdefun
);
1123 else if (defunflag
> 0)
1128 Lisp_Object Vobarray
;
1129 Lisp_Object initial_obarray
;
1132 check_obarray (obarray
)
1133 Lisp_Object obarray
;
1135 while (XTYPE (obarray
) != Lisp_Vector
|| XVECTOR (obarray
)->size
== 0)
1137 /* If Vobarray is now invalid, force it to be valid. */
1138 if (EQ (Vobarray
, obarray
)) Vobarray
= initial_obarray
;
1140 obarray
= wrong_type_argument (Qvectorp
, obarray
);
1145 static int hash_string ();
1146 Lisp_Object
oblookup ();
1153 int len
= strlen (str
);
1154 Lisp_Object obarray
= Vobarray
;
1156 if (XTYPE (obarray
) != Lisp_Vector
|| XVECTOR (obarray
)->size
== 0)
1157 obarray
= check_obarray (obarray
);
1158 tem
= oblookup (obarray
, str
, len
);
1159 if (XTYPE (tem
) == Lisp_Symbol
)
1161 return Fintern ((!NILP (Vpurify_flag
)
1162 ? make_pure_string (str
, len
)
1163 : make_string (str
, len
)),
1167 DEFUN ("intern", Fintern
, Sintern
, 1, 2, 0,
1168 "Return the canonical symbol whose name is STRING.\n\
1169 If there is none, one is created by this function and returned.\n\
1170 A second optional argument specifies the obarray to use;\n\
1171 it defaults to the value of `obarray'.")
1173 Lisp_Object str
, obarray
;
1175 register Lisp_Object tem
, sym
, *ptr
;
1177 if (NILP (obarray
)) obarray
= Vobarray
;
1178 obarray
= check_obarray (obarray
);
1180 CHECK_STRING (str
, 0);
1182 tem
= oblookup (obarray
, XSTRING (str
)->data
, XSTRING (str
)->size
);
1183 if (XTYPE (tem
) != Lisp_Int
)
1186 if (!NILP (Vpurify_flag
))
1187 str
= Fpurecopy (str
);
1188 sym
= Fmake_symbol (str
);
1190 ptr
= &XVECTOR (obarray
)->contents
[XINT (tem
)];
1191 if (XTYPE (*ptr
) == Lisp_Symbol
)
1192 XSYMBOL (sym
)->next
= XSYMBOL (*ptr
);
1194 XSYMBOL (sym
)->next
= 0;
1199 DEFUN ("intern-soft", Fintern_soft
, Sintern_soft
, 1, 2, 0,
1200 "Return the canonical symbol whose name is STRING, or nil if none exists.\n\
1201 A second optional argument specifies the obarray to use;\n\
1202 it defaults to the value of `obarray'.")
1204 Lisp_Object str
, obarray
;
1206 register Lisp_Object tem
;
1208 if (NILP (obarray
)) obarray
= Vobarray
;
1209 obarray
= check_obarray (obarray
);
1211 CHECK_STRING (str
, 0);
1213 tem
= oblookup (obarray
, XSTRING (str
)->data
, XSTRING (str
)->size
);
1214 if (XTYPE (tem
) != Lisp_Int
)
1220 oblookup (obarray
, ptr
, size
)
1221 Lisp_Object obarray
;
1226 register Lisp_Object tail
;
1227 Lisp_Object bucket
, tem
;
1229 if (XTYPE (obarray
) != Lisp_Vector
||
1230 (obsize
= XVECTOR (obarray
)->size
) == 0)
1232 obarray
= check_obarray (obarray
);
1233 obsize
= XVECTOR (obarray
)->size
;
1235 /* Combining next two lines breaks VMS C 2.3. */
1236 hash
= hash_string (ptr
, size
);
1238 bucket
= XVECTOR (obarray
)->contents
[hash
];
1239 if (XFASTINT (bucket
) == 0)
1241 else if (XTYPE (bucket
) != Lisp_Symbol
)
1242 error ("Bad data in guts of obarray"); /* Like CADR error message */
1243 else for (tail
= bucket
; ; XSET (tail
, Lisp_Symbol
, XSYMBOL (tail
)->next
))
1245 if (XSYMBOL (tail
)->name
->size
== size
&&
1246 !bcmp (XSYMBOL (tail
)->name
->data
, ptr
, size
))
1248 else if (XSYMBOL (tail
)->next
== 0)
1251 XSET (tem
, Lisp_Int
, hash
);
1256 hash_string (ptr
, len
)
1260 register unsigned char *p
= ptr
;
1261 register unsigned char *end
= p
+ len
;
1262 register unsigned char c
;
1263 register int hash
= 0;
1268 if (c
>= 0140) c
-= 40;
1269 hash
= ((hash
<<3) + (hash
>>28) + c
);
1271 return hash
& 07777777777;
1275 map_obarray (obarray
, fn
, arg
)
1276 Lisp_Object obarray
;
1281 register Lisp_Object tail
;
1282 CHECK_VECTOR (obarray
, 1);
1283 for (i
= XVECTOR (obarray
)->size
- 1; i
>= 0; i
--)
1285 tail
= XVECTOR (obarray
)->contents
[i
];
1286 if (XFASTINT (tail
) != 0)
1290 if (XSYMBOL (tail
)->next
== 0)
1292 XSET (tail
, Lisp_Symbol
, XSYMBOL (tail
)->next
);
1297 mapatoms_1 (sym
, function
)
1298 Lisp_Object sym
, function
;
1300 call1 (function
, sym
);
1303 DEFUN ("mapatoms", Fmapatoms
, Smapatoms
, 1, 2, 0,
1304 "Call FUNCTION on every symbol in OBARRAY.\n\
1305 OBARRAY defaults to the value of `obarray'.")
1307 Lisp_Object function
, obarray
;
1311 if (NILP (obarray
)) obarray
= Vobarray
;
1312 obarray
= check_obarray (obarray
);
1314 map_obarray (obarray
, mapatoms_1
, function
);
1318 #define OBARRAY_SIZE 509
1323 Lisp_Object oblength
;
1327 XFASTINT (oblength
) = OBARRAY_SIZE
;
1329 Qnil
= Fmake_symbol (make_pure_string ("nil", 3));
1330 Vobarray
= Fmake_vector (oblength
, make_number (0));
1331 initial_obarray
= Vobarray
;
1332 staticpro (&initial_obarray
);
1333 /* Intern nil in the obarray */
1334 /* These locals are to kludge around a pyramid compiler bug. */
1335 hash
= hash_string ("nil", 3);
1336 /* Separate statement here to avoid VAXC bug. */
1337 hash
%= OBARRAY_SIZE
;
1338 tem
= &XVECTOR (Vobarray
)->contents
[hash
];
1341 Qunbound
= Fmake_symbol (make_pure_string ("unbound", 7));
1342 XSYMBOL (Qnil
)->function
= Qunbound
;
1343 XSYMBOL (Qunbound
)->value
= Qunbound
;
1344 XSYMBOL (Qunbound
)->function
= Qunbound
;
1347 XSYMBOL (Qnil
)->value
= Qnil
;
1348 XSYMBOL (Qnil
)->plist
= Qnil
;
1349 XSYMBOL (Qt
)->value
= Qt
;
1351 /* Qt is correct even if CANNOT_DUMP. loadup.el will set to nil at end. */
1354 Qvariable_documentation
= intern ("variable-documentation");
1356 read_buffer_size
= 100;
1357 read_buffer
= (char *) malloc (read_buffer_size
);
1362 struct Lisp_Subr
*sname
;
1365 sym
= intern (sname
->symbol_name
);
1366 XSET (XSYMBOL (sym
)->function
, Lisp_Subr
, sname
);
1369 #ifdef NOTDEF /* use fset in subr.el now */
1371 defalias (sname
, string
)
1372 struct Lisp_Subr
*sname
;
1376 sym
= intern (string
);
1377 XSET (XSYMBOL (sym
)->function
, Lisp_Subr
, sname
);
1381 /* New replacement for DefIntVar; it ignores the doc string argument
1382 on the assumption that make-docfile will handle that. */
1383 /* Define an "integer variable"; a symbol whose value is forwarded
1384 to a C variable of type int. Sample call: */
1385 /* DEFVARINT ("indent-tabs-mode", &indent_tabs_mode, "Documentation"); */
1388 defvar_int (namestring
, address
, doc
)
1394 sym
= intern (namestring
);
1395 XSET (XSYMBOL (sym
)->value
, Lisp_Intfwd
, address
);
1398 /* Similar but define a variable whose value is T if address contains 1,
1399 NIL if address contains 0 */
1402 defvar_bool (namestring
, address
, doc
)
1408 sym
= intern (namestring
);
1409 XSET (XSYMBOL (sym
)->value
, Lisp_Boolfwd
, address
);
1412 /* Similar but define a variable whose value is the Lisp Object stored at address. */
1415 defvar_lisp (namestring
, address
, doc
)
1417 Lisp_Object
*address
;
1421 sym
= intern (namestring
);
1422 XSET (XSYMBOL (sym
)->value
, Lisp_Objfwd
, address
);
1423 staticpro (address
);
1426 /* Similar but don't request gc-marking of the C variable.
1427 Used when that variable will be gc-marked for some other reason,
1428 since marking the same slot twice can cause trouble with strings. */
1431 defvar_lisp_nopro (namestring
, address
, doc
)
1433 Lisp_Object
*address
;
1437 sym
= intern (namestring
);
1438 XSET (XSYMBOL (sym
)->value
, Lisp_Objfwd
, address
);
1443 /* Similar but define a variable whose value is the Lisp Object stored in
1444 the current buffer. address is the address of the slot in the buffer that is current now. */
1447 defvar_per_buffer (namestring
, address
, doc
)
1449 Lisp_Object
*address
;
1454 extern struct buffer buffer_local_symbols
;
1456 sym
= intern (namestring
);
1457 offset
= (char *)address
- (char *)current_buffer
;
1459 XSET (XSYMBOL (sym
)->value
, Lisp_Buffer_Objfwd
,
1460 (Lisp_Object
*) offset
);
1461 *(Lisp_Object
*)(offset
+ (char *)&buffer_local_symbols
) = sym
;
1462 if (*(int *)(offset
+ (char *)&buffer_local_flags
) == 0)
1463 /* Did a DEFVAR_PER_BUFFER without initializing the corresponding
1464 slot of buffer_local_flags */
1468 #endif /* standalone */
1474 /* Compute the default load-path. */
1476 normal
= PATH_LOADSEARCH
;
1477 Vload_path
= decode_env_path (0, normal
);
1479 if (NILP (Vpurify_flag
))
1480 normal
= PATH_LOADSEARCH
;
1482 normal
= PATH_DUMPLOADSEARCH
;
1484 /* In a dumped Emacs, we normally have to reset the value of
1485 Vload_path from PATH_LOADSEARCH, since the value that was dumped
1486 uses ../lisp, instead of the path of the installed elisp
1487 libraries. However, if it appears that Vload_path was changed
1488 from the default before dumping, don't override that value. */
1491 Lisp_Object dump_path
;
1493 dump_path
= decode_env_path (0, PATH_DUMPLOADSEARCH
);
1494 if (! NILP (Fequal (dump_path
, Vload_path
)))
1495 Vload_path
= decode_env_path (0, normal
);
1498 Vload_path
= decode_env_path (0, normal
);
1501 /* Warn if dirs in the *standard* path don't exist. */
1503 Lisp_Object path_tail
;
1505 for (path_tail
= Vload_path
;
1507 path_tail
= XCONS (path_tail
)->cdr
)
1509 Lisp_Object dirfile
;
1510 dirfile
= Fcar (path_tail
);
1511 if (XTYPE (dirfile
) == Lisp_String
)
1513 dirfile
= Fdirectory_file_name (dirfile
);
1514 if (access (XSTRING (dirfile
)->data
, 0) < 0)
1515 printf ("Warning: lisp library (%s) does not exist.\n",
1516 XSTRING (Fcar (path_tail
))->data
);
1521 /* If the EMACSLOADPATH environment variable is set, use its value.
1522 This doesn't apply if we're dumping. */
1523 if (NILP (Vpurify_flag
)
1524 && egetenv ("EMACSLOADPATH"))
1525 Vload_path
= decode_env_path ("EMACSLOADPATH", normal
);
1529 load_in_progress
= 0;
1536 defsubr (&Sread_from_string
);
1538 defsubr (&Sintern_soft
);
1540 defsubr (&Seval_buffer
);
1541 defsubr (&Seval_region
);
1542 defsubr (&Sread_char
);
1543 defsubr (&Sread_char_exclusive
);
1544 #ifdef HAVE_X_WINDOWS
1545 defsubr (&Sread_event
);
1546 #endif /* HAVE_X_WINDOWS */
1547 defsubr (&Sget_file_char
);
1548 defsubr (&Smapatoms
);
1550 DEFVAR_LISP ("obarray", &Vobarray
,
1551 "Symbol table for use by `intern' and `read'.\n\
1552 It is a vector whose length ought to be prime for best results.\n\
1553 The vector's contents don't make sense if examined from Lisp programs;\n\
1554 to find all the symbols in an obarray, use `mapatoms'.");
1556 DEFVAR_LISP ("values", &Vvalues
,
1557 "List of values of all expressions which were read, evaluated and printed.\n\
1558 Order is reverse chronological.");
1560 DEFVAR_LISP ("standard-input", &Vstandard_input
,
1561 "Stream for read to get input from.\n\
1562 See documentation of `read' for possible values.");
1563 Vstandard_input
= Qt
;
1565 DEFVAR_LISP ("load-path", &Vload_path
,
1566 "*List of directories to search for files to load.\n\
1567 Each element is a string (directory name) or nil (try default directory).\n\
1568 Initialized based on EMACSLOADPATH environment variable, if any,\n\
1569 otherwise to default specified in by file `paths.h' when Emacs was built.");
1571 DEFVAR_BOOL ("load-in-progress", &load_in_progress
,
1572 "Non-nil iff inside of `load'.");
1574 DEFVAR_LISP ("after-load-alist", &Vafter_load_alist
,
1575 "An alist of expressions to be evalled when particular files are loaded.\n\
1576 Each element looks like (FILENAME FORMS...).\n\
1577 When `load' is run and the file-name argument is FILENAME,\n\
1578 the FORMS in the corresponding element are executed at the end of loading.\n\n\
1579 FILENAME must match exactly! Normally FILENAME is the name of a library,\n\
1580 with no directory specified, since that is how `load' is normally called.\n\
1581 An error in FORMS does not undo the load,\n\
1582 but does prevent execution of the rest of the FORMS.");
1583 Vafter_load_alist
= Qnil
;
1585 Qstandard_input
= intern ("standard-input");
1586 staticpro (&Qstandard_input
);
1588 Qread_char
= intern ("read-char");
1589 staticpro (&Qread_char
);
1591 Qget_file_char
= intern ("get-file-char");
1592 staticpro (&Qget_file_char
);