1 /* Lisp parsing and input streams.
2 Copyright (C) 1985, 1986, 1987, 1988, 1989, 1992 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
6 GNU Emacs is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2, or (at your option)
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs; see the file COPYING. If not, write to
18 the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
22 #include <sys/types.h>
36 #include <sys/inode.h>
43 #ifdef LISP_FLOAT_TYPE
45 #endif /* LISP_FLOAT_TYPE */
47 Lisp_Object Qread_char
, Qget_file_char
, Qstandard_input
;
48 Lisp_Object Qvariable_documentation
, Vvalues
, Vstandard_input
, Vafter_load_alist
;
50 /* non-zero if inside `load' */
53 /* Search path for files to be loaded. */
54 Lisp_Object Vload_path
;
56 /* File for get_file_char to read from. Use by load */
57 static FILE *instream
;
59 /* When nonzero, read conses in pure space */
62 /* For use within read-from-string (this reader is non-reentrant!!) */
63 static int read_from_string_index
;
64 static int read_from_string_limit
;
66 /* Handle unreading and rereading of characters.
67 Write READCHAR to read a character,
68 UNREAD(c) to unread c to be read again. */
70 #define READCHAR readchar (readcharfun)
71 #define UNREAD(c) unreadchar (readcharfun, c)
74 readchar (readcharfun
)
75 Lisp_Object readcharfun
;
78 register struct buffer
*inbuffer
;
81 if (XTYPE (readcharfun
) == Lisp_Buffer
)
83 inbuffer
= XBUFFER (readcharfun
);
85 if (BUF_PT (inbuffer
) >= BUF_ZV (inbuffer
))
87 c
= *(unsigned char *) BUF_CHAR_ADDRESS (inbuffer
, BUF_PT (inbuffer
));
88 SET_BUF_PT (inbuffer
, BUF_PT (inbuffer
) + 1);
92 if (XTYPE (readcharfun
) == Lisp_Marker
)
94 inbuffer
= XMARKER (readcharfun
)->buffer
;
96 mpos
= marker_position (readcharfun
);
98 if (mpos
> BUF_ZV (inbuffer
) - 1)
100 c
= *(unsigned char *) BUF_CHAR_ADDRESS (inbuffer
, mpos
);
101 if (mpos
!= BUF_GPT (inbuffer
))
102 XMARKER (readcharfun
)->bufpos
++;
104 Fset_marker (readcharfun
, make_number (mpos
+ 1),
105 Fmarker_buffer (readcharfun
));
108 if (EQ (readcharfun
, Qget_file_char
))
109 return getc (instream
);
111 if (XTYPE (readcharfun
) == Lisp_String
)
114 /* This used to be return of a conditional expression,
115 but that truncated -1 to a char on VMS. */
116 if (read_from_string_index
< read_from_string_limit
)
117 c
= XSTRING (readcharfun
)->data
[read_from_string_index
++];
123 tem
= call0 (readcharfun
);
130 /* Unread the character C in the way appropriate for the stream READCHARFUN.
131 If the stream is a user function, call it with the char as argument. */
134 unreadchar (readcharfun
, c
)
135 Lisp_Object readcharfun
;
138 if (XTYPE (readcharfun
) == Lisp_Buffer
)
140 if (XBUFFER (readcharfun
) == current_buffer
)
143 SET_BUF_PT (XBUFFER (readcharfun
), BUF_PT (XBUFFER (readcharfun
)) - 1);
145 else if (XTYPE (readcharfun
) == Lisp_Marker
)
146 XMARKER (readcharfun
)->bufpos
--;
147 else if (XTYPE (readcharfun
) == Lisp_String
)
148 read_from_string_index
--;
149 else if (EQ (readcharfun
, Qget_file_char
))
150 ungetc (c
, instream
);
152 call1 (readcharfun
, make_number (c
));
155 static Lisp_Object
read0 (), read1 (), read_list (), read_vector ();
157 /* get a character from the tty */
159 DEFUN ("read-char", Fread_char
, Sread_char
, 0, 0, 0,
160 "Read a character from the command input (keyboard or macro).\n\
161 It is returned as a number.")
164 register Lisp_Object val
;
168 if (XTYPE (val
) != Lisp_Int
)
170 unread_command_char
= val
;
171 error ("Object read was not a character");
180 #ifdef HAVE_X_WINDOWS
181 DEFUN ("read-event", Fread_event
, Sread_event
, 0, 0, 0,
182 "Read an event object from the input stream.")
185 register Lisp_Object val
;
191 DEFUN ("read-char-exclusive", Fread_char_exclusive
, Sread_char_exclusive
, 0, 0, 0,
192 "Read a character from the command input (keyboard or macro).\n\
193 It is returned as a number. Non character events are ignored.")
196 register Lisp_Object val
;
200 while (XTYPE (val
) != Lisp_Int
)
208 #endif /* HAVE_X_WINDOWS */
210 DEFUN ("get-file-char", Fget_file_char
, Sget_file_char
, 0, 0, 0,
211 "Don't use this yourself.")
214 register Lisp_Object val
;
215 XSET (val
, Lisp_Int
, getc (instream
));
219 static void readevalloop ();
220 static Lisp_Object
load_unwind ();
222 DEFUN ("load", Fload
, Sload
, 1, 4, 0,
223 "Execute a file of Lisp code named FILE.\n\
224 First try FILE with `.elc' appended, then try with `.el',\n\
225 then try FILE unmodified.\n\
226 This function searches the directories in `load-path'.\n\
227 If optional second arg NOERROR is non-nil,\n\
228 report no error if FILE doesn't exist.\n\
229 Print messages at start and end of loading unless\n\
230 optional third arg NOMESSAGE is non-nil.\n\
231 If optional fourth arg NOSUFFIX is non-nil, don't try adding\n\
232 suffixes `.elc' or `.el' to the specified name FILE.\n\
233 Return t if file exists.")
234 (str
, noerror
, nomessage
, nosuffix
)
235 Lisp_Object str
, noerror
, nomessage
, nosuffix
;
237 register FILE *stream
;
238 register int fd
= -1;
239 register Lisp_Object lispstream
;
241 int count
= specpdl_ptr
- specpdl
;
246 CHECK_STRING (str
, 0);
247 str
= Fsubstitute_in_file_name (str
);
249 /* Avoid weird lossage with null string as arg,
250 since it would try to load a directory as a Lisp file */
251 if (XSTRING (str
)->size
> 0)
253 fd
= openp (Vload_path
, str
, !NILP (nosuffix
) ? "" : ".elc:.el:",
261 Fsignal (Qfile_error
, Fcons (build_string ("Cannot open load file"),
267 if (!bcmp (&(XSTRING (found
)->data
[XSTRING (found
)->size
- 4]),
273 stat (XSTRING (found
)->data
, &s1
);
274 XSTRING (found
)->data
[XSTRING (found
)->size
- 1] = 0;
275 result
= stat (XSTRING (found
)->data
, &s2
);
276 if (result
>= 0 && (unsigned) s1
.st_mtime
< (unsigned) s2
.st_mtime
)
277 message ("Source file `%s' newer than byte-compiled file",
278 XSTRING (found
)->data
);
279 XSTRING (found
)->data
[XSTRING (found
)->size
- 1] = 'c';
282 stream
= fdopen (fd
, "r");
286 error ("Failure to create stdio stream for %s", XSTRING (str
)->data
);
289 if (NILP (nomessage
))
290 message ("Loading %s...", XSTRING (str
)->data
);
293 /* We may not be able to store STREAM itself as a Lisp_Object pointer
294 since that is guaranteed to work only for data that has been malloc'd.
295 So malloc a full-size pointer, and record the address of that pointer. */
296 ptr
= (FILE **) xmalloc (sizeof (FILE *));
298 XSET (lispstream
, Lisp_Internal_Stream
, (int) ptr
);
299 record_unwind_protect (load_unwind
, lispstream
);
301 readevalloop (Qget_file_char
, stream
, Feval
, 0);
302 unbind_to (count
, Qnil
);
304 /* Run any load-hooks for this file. */
305 temp
= Fassoc (str
, Vafter_load_alist
);
307 Fprogn (Fcdr (temp
));
310 if (!noninteractive
&& NILP (nomessage
))
311 message ("Loading %s...done", XSTRING (str
)->data
);
316 load_unwind (stream
) /* used as unwind-protect function in load */
319 fclose (*(FILE **) XSTRING (stream
));
320 free (XPNTR (stream
));
321 if (--load_in_progress
< 0) load_in_progress
= 0;
327 complete_filename_p (pathname
)
328 Lisp_Object pathname
;
330 register unsigned char *s
= XSTRING (pathname
)->data
;
341 /* Search for a file whose name is STR, looking in directories
342 in the Lisp list PATH, and trying suffixes from SUFFIX.
343 SUFFIX is a string containing possible suffixes separated by colons.
344 On success, returns a file descriptor. On failure, returns -1.
346 EXEC_ONLY nonzero means don't open the files,
347 just look for one that is executable. In this case,
348 returns 1 on success.
350 If STOREPTR is nonzero, it points to a slot where the name of
351 the file actually found should be stored as a Lisp string.
352 Nil is stored there on failure. */
355 openp (path
, str
, suffix
, storeptr
, exec_only
)
356 Lisp_Object path
, str
;
358 Lisp_Object
*storeptr
;
364 register char *fn
= buf
;
367 register Lisp_Object filename
;
373 if (complete_filename_p (str
))
376 for (; !NILP (path
); path
= Fcdr (path
))
380 filename
= Fexpand_file_name (str
, Fcar (path
));
381 if (!complete_filename_p (filename
))
382 /* If there are non-absolute elts in PATH (eg ".") */
383 /* Of course, this could conceivably lose if luser sets
384 default-directory to be something non-absolute... */
386 filename
= Fexpand_file_name (filename
, current_buffer
->directory
);
387 if (!complete_filename_p (filename
))
388 /* Give up on this path element! */
392 /* Calculate maximum size of any filename made from
393 this path element/specified file name and any possible suffix. */
394 want_size
= strlen (suffix
) + XSTRING (filename
)->size
+ 1;
395 if (fn_size
< want_size
)
396 fn
= (char *) alloca (fn_size
= 100 + want_size
);
400 /* Loop over suffixes. */
403 char *esuffix
= (char *) index (nsuffix
, ':');
404 int lsuffix
= esuffix
? esuffix
- nsuffix
: strlen (nsuffix
);
406 /* Concatenate path element/specified name with the suffix. */
407 strncpy (fn
, XSTRING (filename
)->data
, XSTRING (filename
)->size
);
408 fn
[XSTRING (filename
)->size
] = 0;
409 if (lsuffix
!= 0) /* Bug happens on CCI if lsuffix is 0. */
410 strncat (fn
, nsuffix
, lsuffix
);
412 /* Ignore file if it's a directory. */
413 if (stat (fn
, &st
) >= 0
414 && (st
.st_mode
& S_IFMT
) != S_IFDIR
)
416 /* Check that we can access or open it. */
418 fd
= (access (fn
, X_OK
) == 0) ? 1 : -1;
420 fd
= open (fn
, 0, 0);
424 /* We succeeded; return this descriptor and filename. */
426 *storeptr
= build_string (fn
);
431 /* Advance to next suffix. */
434 nsuffix
+= lsuffix
+ 1;
436 if (absolute
) return -1;
444 unreadpure () /* Used as unwind-protect function in readevalloop */
451 readevalloop (readcharfun
, stream
, evalfun
, printflag
)
452 Lisp_Object readcharfun
;
454 Lisp_Object (*evalfun
) ();
458 register Lisp_Object val
;
459 int count
= specpdl_ptr
- specpdl
;
461 specbind (Qstandard_input
, readcharfun
);
469 while ((c
= READCHAR
) != '\n' && c
!= -1);
473 if (c
== ' ' || c
== '\t' || c
== '\n' || c
== '\f') continue;
475 if (!NILP (Vpurify_flag
) && c
== '(')
477 record_unwind_protect (unreadpure
, Qnil
);
478 val
= read_list (-1, readcharfun
);
479 unbind_to (count
+ 1, Qnil
);
484 val
= read0 (readcharfun
);
487 val
= (*evalfun
) (val
);
490 Vvalues
= Fcons (val
, Vvalues
);
491 if (EQ (Vstandard_output
, Qt
))
498 unbind_to (count
, Qnil
);
503 DEFUN ("eval-buffer", Feval_buffer
, Seval_buffer
, 0, 2, "bBuffer: ",
504 "Execute BUFFER as Lisp code. If BUFFER is nil, use the current buffer.\n\
505 Programs can pass argument PRINTFLAG which controls printing of output:\n\
506 nil means discard it; anything else is stream for print.\n\
508 If there is no error, point does not move. If there is an error,\n\
509 point remains at the end of the last character read from the buffer.")
511 Lisp_Object bufname
, printflag
;
513 int count
= specpdl_ptr
- specpdl
;
514 Lisp_Object tem
, buf
;
517 buf
= Fcurrent_buffer ();
519 buf
= Fget_buffer (bufname
);
521 error ("No such buffer.");
523 if (NIL_P (printflag
))
527 specbind (Qstandard_output
, tem
);
528 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
529 BUF_SET_PT (XBUFFER (buf
), BUF_BEGV (XBUFFER (buf
)));
530 readevalloop (buf
, 0, Feval
, !NIL_P (printflag
));
537 DEFUN ("eval-current-buffer", Feval_current_buffer
, Seval_current_buffer
, 0, 1, "",
538 "Execute the current buffer as Lisp code.\n\
539 Programs can pass argument PRINTFLAG which controls printing of output:\n\
540 nil means discard it; anything else is stream for print.\n\
542 If there is no error, point does not move. If there is an error,\n\
543 point remains at the end of the last character read from the buffer.")
545 Lisp_Object printflag
;
547 int count
= specpdl_ptr
- specpdl
;
550 if (NILP (printflag
))
554 specbind (Qstandard_output
, tem
);
555 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
557 readevalloop (Fcurrent_buffer (), 0, Feval
, !NILP (printflag
));
558 return unbind_to (count
, Qnil
);
562 DEFUN ("eval-region", Feval_region
, Seval_region
, 2, 3, "r",
563 "Execute the region as Lisp code.\n\
564 When called from programs, expects two arguments,\n\
565 giving starting and ending indices in the current buffer\n\
566 of the text to be executed.\n\
567 Programs can pass third argument PRINTFLAG which controls output:\n\
568 nil means discard it; anything else is stream for printing it.\n\
570 If there is no error, point does not move. If there is an error,\n\
571 point remains at the end of the last character read from the buffer.")
573 Lisp_Object b
, e
, printflag
;
575 int count
= specpdl_ptr
- specpdl
;
578 if (NILP (printflag
))
582 specbind (Qstandard_output
, tem
);
584 if (NILP (printflag
))
585 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
586 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
588 /* This both uses b and checks its type. */
590 Fnarrow_to_region (make_number (BEGV
), e
);
591 readevalloop (Fcurrent_buffer (), 0, Feval
, !NILP (printflag
));
593 return unbind_to (count
, Qnil
);
596 #endif /* standalone */
598 DEFUN ("read", Fread
, Sread
, 0, 1, 0,
599 "Read one Lisp expression as text from STREAM, return as Lisp object.\n\
600 If STREAM is nil, use the value of `standard-input' (which see).\n\
601 STREAM or the value of `standard-input' may be:\n\
602 a buffer (read from point and advance it)\n\
603 a marker (read from where it points and advance it)\n\
604 a function (call it with no arguments for each character,\n\
605 call it with a char as argument to push a char back)\n\
606 a string (takes text from string, starting at the beginning)\n\
607 t (read text line using minibuffer and use it).")
609 Lisp_Object readcharfun
;
611 extern Lisp_Object
Fread_minibuffer ();
613 if (NILP (readcharfun
))
614 readcharfun
= Vstandard_input
;
615 if (EQ (readcharfun
, Qt
))
616 readcharfun
= Qread_char
;
619 if (EQ (readcharfun
, Qread_char
))
620 return Fread_minibuffer (build_string ("Lisp expression: "), Qnil
);
623 if (XTYPE (readcharfun
) == Lisp_String
)
624 return Fcar (Fread_from_string (readcharfun
, Qnil
, Qnil
));
626 return read0 (readcharfun
);
629 DEFUN ("read-from-string", Fread_from_string
, Sread_from_string
, 1, 3, 0,
630 "Read one Lisp expression which is represented as text by STRING.\n\
631 Returns a cons: (OBJECT-READ . FINAL-STRING-INDEX).\n\
632 START and END optionally delimit a substring of STRING from which to read;\n\
633 they default to 0 and (length STRING) respectively.")
635 Lisp_Object string
, start
, end
;
637 int startval
, endval
;
640 CHECK_STRING (string
,0);
643 endval
= XSTRING (string
)->size
;
645 { CHECK_NUMBER (end
,2);
647 if (endval
< 0 || endval
> XSTRING (string
)->size
)
648 args_out_of_range (string
, end
);
654 { CHECK_NUMBER (start
,1);
655 startval
= XINT (start
);
656 if (startval
< 0 || startval
> endval
)
657 args_out_of_range (string
, start
);
660 read_from_string_index
= startval
;
661 read_from_string_limit
= endval
;
663 tem
= read0 (string
);
664 return Fcons (tem
, make_number (read_from_string_index
));
667 /* Use this for recursive reads, in contexts where internal tokens are not allowed. */
671 Lisp_Object readcharfun
;
673 register Lisp_Object val
;
676 val
= read1 (readcharfun
);
677 if (XTYPE (val
) == Lisp_Internal
)
680 return Fsignal (Qinvalid_read_syntax
, Fcons (make_string (&c
, 1), Qnil
));
686 static int read_buffer_size
;
687 static char *read_buffer
;
690 read_escape (readcharfun
)
691 Lisp_Object readcharfun
;
693 register int c
= READCHAR
;
718 error ("Invalid escape character syntax");
721 c
= read_escape (readcharfun
);
727 error ("Invalid escape character syntax");
731 c
= read_escape (readcharfun
);
735 return (c
& (0200 | 037));
745 /* An octal escape, as in ANSI C. */
747 register int i
= c
- '0';
748 register int count
= 0;
751 if ((c
= READCHAR
) >= '0' && c
<= '7')
766 /* A hex escape, as in ANSI C. */
772 if (c
>= '0' && c
<= '9')
777 else if ((c
>= 'a' && c
<= 'f')
778 || (c
>= 'A' && c
<= 'F'))
781 if (c
>= 'a' && c
<= 'f')
802 register Lisp_Object readcharfun
;
809 if (c
< 0) return Fsignal (Qend_of_file
, Qnil
);
814 return read_list (0, readcharfun
);
817 return read_vector (readcharfun
);
823 register Lisp_Object val
;
824 XSET (val
, Lisp_Internal
, c
);
832 /* Accept compiled functions at read-time so that we don't have to
833 build them using function calls. */
834 Lisp_Object tmp
= read_vector (readcharfun
);
835 return Fmake_byte_code (XVECTOR(tmp
)->size
, XVECTOR (tmp
)->contents
);
838 return Fsignal (Qinvalid_read_syntax
, Fcons (make_string ("#", 1), Qnil
));
841 while ((c
= READCHAR
) >= 0 && c
!= '\n');
846 return Fcons (Qquote
, Fcons (read0 (readcharfun
), Qnil
));
851 register Lisp_Object val
;
854 if (c
< 0) return Fsignal (Qend_of_file
, Qnil
);
857 XSET (val
, Lisp_Int
, read_escape (readcharfun
));
859 XSET (val
, Lisp_Int
, c
);
866 register char *p
= read_buffer
;
867 register char *end
= read_buffer
+ read_buffer_size
;
871 while ((c
= READCHAR
) >= 0
876 char *new = (char *) xrealloc (read_buffer
, read_buffer_size
*= 2);
877 p
+= new - read_buffer
;
878 read_buffer
+= new - read_buffer
;
879 end
= read_buffer
+ read_buffer_size
;
882 c
= read_escape (readcharfun
);
883 /* c is -1 if \ newline has just been seen */
886 if (p
== read_buffer
)
892 if (c
< 0) return Fsignal (Qend_of_file
, Qnil
);
894 /* If purifying, and string starts with \ newline,
895 return zero instead. This is for doc strings
896 that we are really going to find in etc/DOC.nn.nn */
897 if (!NILP (Vpurify_flag
) && NILP (Vdoc_file_name
) && cancel
)
898 return make_number (0);
901 return make_pure_string (read_buffer
, p
- read_buffer
);
903 return make_string (read_buffer
, p
- read_buffer
);
907 if (c
<= 040) goto retry
;
909 register char *p
= read_buffer
;
912 register char *end
= read_buffer
+ read_buffer_size
;
915 !(c
== '\"' || c
== '\'' || c
== ';' || c
== '?'
916 || c
== '(' || c
== ')'
917 #ifndef LISP_FLOAT_TYPE /* we need to see <number><dot><number> */
919 #endif /* not LISP_FLOAT_TYPE */
920 || c
== '[' || c
== ']' || c
== '#'
925 register char *new = (char *) xrealloc (read_buffer
, read_buffer_size
*= 2);
926 p
+= new - read_buffer
;
927 read_buffer
+= new - read_buffer
;
928 end
= read_buffer
+ read_buffer_size
;
938 char *new = (char *) xrealloc (read_buffer
, read_buffer_size
*= 2);
939 p
+= new - read_buffer
;
940 read_buffer
+= new - read_buffer
;
941 /* end = read_buffer + read_buffer_size; */
948 /* Is it an integer? */
951 register Lisp_Object val
;
953 if (*p1
== '+' || *p1
== '-') p1
++;
956 while (p1
!= p
&& (c
= *p1
) >= '0' && c
<= '9') p1
++;
960 XSET (val
, Lisp_Int
, atoi (read_buffer
));
964 #ifdef LISP_FLOAT_TYPE
965 if (isfloat_string (read_buffer
))
966 return make_float (atof (read_buffer
));
970 return intern (read_buffer
);
975 #ifdef LISP_FLOAT_TYPE
991 if (*cp
== '+' || *cp
== '-')
997 while (isdigit (*cp
))
1008 while (isdigit (*cp
))
1016 if ((*cp
== '+') || (*cp
== '-'))
1022 while (isdigit (*cp
))
1026 && (state
== (LEAD_INT
|DOT_CHAR
|TRAIL_INT
)
1027 || state
== (LEAD_INT
|E_CHAR
|EXP_INT
)
1028 || state
== (LEAD_INT
|DOT_CHAR
|TRAIL_INT
|E_CHAR
|EXP_INT
)));
1030 #endif /* LISP_FLOAT_TYPE */
1033 read_vector (readcharfun
)
1034 Lisp_Object readcharfun
;
1038 register Lisp_Object
*ptr
;
1039 register Lisp_Object tem
, vector
;
1040 register struct Lisp_Cons
*otem
;
1043 tem
= read_list (1, readcharfun
);
1044 len
= Flength (tem
);
1045 vector
= (read_pure
? make_pure_vector (XINT (len
)) : Fmake_vector (len
, Qnil
));
1048 size
= XVECTOR (vector
)->size
;
1049 ptr
= XVECTOR (vector
)->contents
;
1050 for (i
= 0; i
< size
; i
++)
1052 ptr
[i
] = read_pure
? Fpurecopy (Fcar (tem
)) : Fcar (tem
);
1060 /* flag = 1 means check for ] to terminate rather than ) and .
1061 flag = -1 means check for starting with defun
1062 and make structure pure. */
1065 read_list (flag
, readcharfun
)
1067 register Lisp_Object readcharfun
;
1069 /* -1 means check next element for defun,
1070 0 means don't check,
1071 1 means already checked and found defun. */
1072 int defunflag
= flag
< 0 ? -1 : 0;
1073 Lisp_Object val
, tail
;
1074 register Lisp_Object elt
, tem
;
1075 struct gcpro gcpro1
, gcpro2
;
1083 elt
= read1 (readcharfun
);
1085 if (XTYPE (elt
) == Lisp_Internal
)
1089 if (XINT (elt
) == ']')
1091 return Fsignal (Qinvalid_read_syntax
, Fcons (make_string (") or . in a vector", 18), Qnil
));
1093 if (XINT (elt
) == ')')
1095 if (XINT (elt
) == '.')
1099 XCONS (tail
)->cdr
= read0 (readcharfun
);
1101 val
= read0 (readcharfun
);
1102 elt
= read1 (readcharfun
);
1104 if (XTYPE (elt
) == Lisp_Internal
&& XINT (elt
) == ')')
1106 return Fsignal (Qinvalid_read_syntax
, Fcons (make_string (". in wrong context", 18), Qnil
));
1108 return Fsignal (Qinvalid_read_syntax
, Fcons (make_string ("] in a list", 11), Qnil
));
1110 tem
= (read_pure
&& flag
<= 0
1111 ? pure_cons (elt
, Qnil
)
1112 : Fcons (elt
, Qnil
));
1114 XCONS (tail
)->cdr
= tem
;
1119 defunflag
= EQ (elt
, Qdefun
);
1120 else if (defunflag
> 0)
1125 Lisp_Object Vobarray
;
1126 Lisp_Object initial_obarray
;
1129 check_obarray (obarray
)
1130 Lisp_Object obarray
;
1132 while (XTYPE (obarray
) != Lisp_Vector
|| XVECTOR (obarray
)->size
== 0)
1134 /* If Vobarray is now invalid, force it to be valid. */
1135 if (EQ (Vobarray
, obarray
)) Vobarray
= initial_obarray
;
1137 obarray
= wrong_type_argument (Qvectorp
, obarray
);
1142 static int hash_string ();
1143 Lisp_Object
oblookup ();
1150 int len
= strlen (str
);
1151 Lisp_Object obarray
= Vobarray
;
1153 if (XTYPE (obarray
) != Lisp_Vector
|| XVECTOR (obarray
)->size
== 0)
1154 obarray
= check_obarray (obarray
);
1155 tem
= oblookup (obarray
, str
, len
);
1156 if (XTYPE (tem
) == Lisp_Symbol
)
1158 return Fintern ((!NILP (Vpurify_flag
)
1159 ? make_pure_string (str
, len
)
1160 : make_string (str
, len
)),
1164 DEFUN ("intern", Fintern
, Sintern
, 1, 2, 0,
1165 "Return the canonical symbol whose name is STRING.\n\
1166 If there is none, one is created by this function and returned.\n\
1167 A second optional argument specifies the obarray to use;\n\
1168 it defaults to the value of `obarray'.")
1170 Lisp_Object str
, obarray
;
1172 register Lisp_Object tem
, sym
, *ptr
;
1174 if (NILP (obarray
)) obarray
= Vobarray
;
1175 obarray
= check_obarray (obarray
);
1177 CHECK_STRING (str
, 0);
1179 tem
= oblookup (obarray
, XSTRING (str
)->data
, XSTRING (str
)->size
);
1180 if (XTYPE (tem
) != Lisp_Int
)
1183 if (!NILP (Vpurify_flag
))
1184 str
= Fpurecopy (str
);
1185 sym
= Fmake_symbol (str
);
1187 ptr
= &XVECTOR (obarray
)->contents
[XINT (tem
)];
1188 if (XTYPE (*ptr
) == Lisp_Symbol
)
1189 XSYMBOL (sym
)->next
= XSYMBOL (*ptr
);
1191 XSYMBOL (sym
)->next
= 0;
1196 DEFUN ("intern-soft", Fintern_soft
, Sintern_soft
, 1, 2, 0,
1197 "Return the canonical symbol whose name is STRING, or nil if none exists.\n\
1198 A second optional argument specifies the obarray to use;\n\
1199 it defaults to the value of `obarray'.")
1201 Lisp_Object str
, obarray
;
1203 register Lisp_Object tem
;
1205 if (NILP (obarray
)) obarray
= Vobarray
;
1206 obarray
= check_obarray (obarray
);
1208 CHECK_STRING (str
, 0);
1210 tem
= oblookup (obarray
, XSTRING (str
)->data
, XSTRING (str
)->size
);
1211 if (XTYPE (tem
) != Lisp_Int
)
1217 oblookup (obarray
, ptr
, size
)
1218 Lisp_Object obarray
;
1223 register Lisp_Object tail
;
1224 Lisp_Object bucket
, tem
;
1226 if (XTYPE (obarray
) != Lisp_Vector
||
1227 (obsize
= XVECTOR (obarray
)->size
) == 0)
1229 obarray
= check_obarray (obarray
);
1230 obsize
= XVECTOR (obarray
)->size
;
1232 /* Combining next two lines breaks VMS C 2.3. */
1233 hash
= hash_string (ptr
, size
);
1235 bucket
= XVECTOR (obarray
)->contents
[hash
];
1236 if (XFASTINT (bucket
) == 0)
1238 else if (XTYPE (bucket
) != Lisp_Symbol
)
1239 error ("Bad data in guts of obarray"); /* Like CADR error message */
1240 else for (tail
= bucket
; ; XSET (tail
, Lisp_Symbol
, XSYMBOL (tail
)->next
))
1242 if (XSYMBOL (tail
)->name
->size
== size
&&
1243 !bcmp (XSYMBOL (tail
)->name
->data
, ptr
, size
))
1245 else if (XSYMBOL (tail
)->next
== 0)
1248 XSET (tem
, Lisp_Int
, hash
);
1253 hash_string (ptr
, len
)
1257 register unsigned char *p
= ptr
;
1258 register unsigned char *end
= p
+ len
;
1259 register unsigned char c
;
1260 register int hash
= 0;
1265 if (c
>= 0140) c
-= 40;
1266 hash
= ((hash
<<3) + (hash
>>28) + c
);
1268 return hash
& 07777777777;
1272 map_obarray (obarray
, fn
, arg
)
1273 Lisp_Object obarray
;
1278 register Lisp_Object tail
;
1279 CHECK_VECTOR (obarray
, 1);
1280 for (i
= XVECTOR (obarray
)->size
- 1; i
>= 0; i
--)
1282 tail
= XVECTOR (obarray
)->contents
[i
];
1283 if (XFASTINT (tail
) != 0)
1287 if (XSYMBOL (tail
)->next
== 0)
1289 XSET (tail
, Lisp_Symbol
, XSYMBOL (tail
)->next
);
1294 mapatoms_1 (sym
, function
)
1295 Lisp_Object sym
, function
;
1297 call1 (function
, sym
);
1300 DEFUN ("mapatoms", Fmapatoms
, Smapatoms
, 1, 2, 0,
1301 "Call FUNCTION on every symbol in OBARRAY.\n\
1302 OBARRAY defaults to the value of `obarray'.")
1304 Lisp_Object function
, obarray
;
1308 if (NILP (obarray
)) obarray
= Vobarray
;
1309 obarray
= check_obarray (obarray
);
1311 map_obarray (obarray
, mapatoms_1
, function
);
1315 #define OBARRAY_SIZE 509
1320 Lisp_Object oblength
;
1324 XFASTINT (oblength
) = OBARRAY_SIZE
;
1326 Qnil
= Fmake_symbol (make_pure_string ("nil", 3));
1327 Vobarray
= Fmake_vector (oblength
, make_number (0));
1328 initial_obarray
= Vobarray
;
1329 staticpro (&initial_obarray
);
1330 /* Intern nil in the obarray */
1331 /* These locals are to kludge around a pyramid compiler bug. */
1332 hash
= hash_string ("nil", 3);
1333 /* Separate statement here to avoid VAXC bug. */
1334 hash
%= OBARRAY_SIZE
;
1335 tem
= &XVECTOR (Vobarray
)->contents
[hash
];
1338 Qunbound
= Fmake_symbol (make_pure_string ("unbound", 7));
1339 XSYMBOL (Qnil
)->function
= Qunbound
;
1340 XSYMBOL (Qunbound
)->value
= Qunbound
;
1341 XSYMBOL (Qunbound
)->function
= Qunbound
;
1344 XSYMBOL (Qnil
)->value
= Qnil
;
1345 XSYMBOL (Qnil
)->plist
= Qnil
;
1346 XSYMBOL (Qt
)->value
= Qt
;
1348 /* Qt is correct even if CANNOT_DUMP. loadup.el will set to nil at end. */
1351 Qvariable_documentation
= intern ("variable-documentation");
1353 read_buffer_size
= 100;
1354 read_buffer
= (char *) malloc (read_buffer_size
);
1359 struct Lisp_Subr
*sname
;
1362 sym
= intern (sname
->symbol_name
);
1363 XSET (XSYMBOL (sym
)->function
, Lisp_Subr
, sname
);
1366 #ifdef NOTDEF /* use fset in subr.el now */
1368 defalias (sname
, string
)
1369 struct Lisp_Subr
*sname
;
1373 sym
= intern (string
);
1374 XSET (XSYMBOL (sym
)->function
, Lisp_Subr
, sname
);
1378 /* New replacement for DefIntVar; it ignores the doc string argument
1379 on the assumption that make-docfile will handle that. */
1380 /* Define an "integer variable"; a symbol whose value is forwarded
1381 to a C variable of type int. Sample call: */
1382 /* DEFVARINT ("indent-tabs-mode", &indent_tabs_mode, "Documentation"); */
1385 defvar_int (namestring
, address
, doc
)
1391 sym
= intern (namestring
);
1392 XSET (XSYMBOL (sym
)->value
, Lisp_Intfwd
, address
);
1395 /* Similar but define a variable whose value is T if address contains 1,
1396 NIL if address contains 0 */
1399 defvar_bool (namestring
, address
, doc
)
1405 sym
= intern (namestring
);
1406 XSET (XSYMBOL (sym
)->value
, Lisp_Boolfwd
, address
);
1409 /* Similar but define a variable whose value is the Lisp Object stored at address. */
1412 defvar_lisp (namestring
, address
, doc
)
1414 Lisp_Object
*address
;
1418 sym
= intern (namestring
);
1419 XSET (XSYMBOL (sym
)->value
, Lisp_Objfwd
, address
);
1420 staticpro (address
);
1423 /* Similar but don't request gc-marking of the C variable.
1424 Used when that variable will be gc-marked for some other reason,
1425 since marking the same slot twice can cause trouble with strings. */
1428 defvar_lisp_nopro (namestring
, address
, doc
)
1430 Lisp_Object
*address
;
1434 sym
= intern (namestring
);
1435 XSET (XSYMBOL (sym
)->value
, Lisp_Objfwd
, address
);
1440 /* Similar but define a variable whose value is the Lisp Object stored in
1441 the current buffer. address is the address of the slot in the buffer that is current now. */
1444 defvar_per_buffer (namestring
, address
, doc
)
1446 Lisp_Object
*address
;
1451 extern struct buffer buffer_local_symbols
;
1453 sym
= intern (namestring
);
1454 offset
= (char *)address
- (char *)current_buffer
;
1456 XSET (XSYMBOL (sym
)->value
, Lisp_Buffer_Objfwd
,
1457 (Lisp_Object
*) offset
);
1458 *(Lisp_Object
*)(offset
+ (char *)&buffer_local_symbols
) = sym
;
1459 if (*(int *)(offset
+ (char *)&buffer_local_flags
) == 0)
1460 /* Did a DEFVAR_PER_BUFFER without initializing the corresponding
1461 slot of buffer_local_flags */
1465 #endif /* standalone */
1471 /* Compute the default load-path. */
1473 normal
= PATH_LOADSEARCH
;
1474 Vload_path
= decode_env_path (0, normal
);
1476 if (NILP (Vpurify_flag
))
1477 normal
= PATH_LOADSEARCH
;
1479 normal
= PATH_DUMPLOADSEARCH
;
1481 /* In a dumped Emacs, we normally have to reset the value of
1482 Vload_path from PATH_LOADSEARCH, since the value that was dumped
1483 uses ../lisp, instead of the path of the installed elisp
1484 libraries. However, if it appears that Vload_path was changed
1485 from the default before dumping, don't override that value. */
1488 Lisp_Object dump_path
;
1490 dump_path
= decode_env_path (0, PATH_DUMPLOADSEARCH
);
1491 if (! NILP (Fequal (dump_path
, Vload_path
)))
1492 Vload_path
= decode_env_path (0, normal
);
1495 Vload_path
= decode_env_path (0, normal
);
1498 /* Warn if dirs in the *standard* path don't exist. */
1500 Lisp_Object path_tail
;
1502 for (path_tail
= Vload_path
;
1504 path_tail
= XCONS (path_tail
)->cdr
)
1506 Lisp_Object dirfile
;
1507 dirfile
= Fcar (path_tail
);
1508 if (XTYPE (dirfile
) == Lisp_String
)
1510 dirfile
= Fdirectory_file_name (dirfile
);
1511 if (access (XSTRING (dirfile
)->data
, 0) < 0)
1512 printf ("Warning: lisp library (%s) does not exist.\n",
1513 XSTRING (Fcar (path_tail
))->data
);
1518 /* If the EMACSLOADPATH environment variable is set, use its value.
1519 This doesn't apply if we're dumping. */
1520 if (NILP (Vpurify_flag
)
1521 && egetenv ("EMACSLOADPATH"))
1522 Vload_path
= decode_env_path ("EMACSLOADPATH", normal
);
1526 load_in_progress
= 0;
1533 defsubr (&Sread_from_string
);
1535 defsubr (&Sintern_soft
);
1537 defsubr (&Seval_buffer
);
1538 defsubr (&Seval_region
);
1539 defsubr (&Sread_char
);
1540 defsubr (&Sread_char_exclusive
);
1541 #ifdef HAVE_X_WINDOWS
1542 defsubr (&Sread_event
);
1543 #endif /* HAVE_X_WINDOWS */
1544 defsubr (&Sget_file_char
);
1545 defsubr (&Smapatoms
);
1547 DEFVAR_LISP ("obarray", &Vobarray
,
1548 "Symbol table for use by `intern' and `read'.\n\
1549 It is a vector whose length ought to be prime for best results.\n\
1550 The vector's contents don't make sense if examined from Lisp programs;\n\
1551 to find all the symbols in an obarray, use `mapatoms'.");
1553 DEFVAR_LISP ("values", &Vvalues
,
1554 "List of values of all expressions which were read, evaluated and printed.\n\
1555 Order is reverse chronological.");
1557 DEFVAR_LISP ("standard-input", &Vstandard_input
,
1558 "Stream for read to get input from.\n\
1559 See documentation of `read' for possible values.");
1560 Vstandard_input
= Qt
;
1562 DEFVAR_LISP ("load-path", &Vload_path
,
1563 "*List of directories to search for files to load.\n\
1564 Each element is a string (directory name) or nil (try default directory).\n\
1565 Initialized based on EMACSLOADPATH environment variable, if any,\n\
1566 otherwise to default specified in by file `paths.h' when Emacs was built.");
1568 DEFVAR_BOOL ("load-in-progress", &load_in_progress
,
1569 "Non-nil iff inside of `load'.");
1571 DEFVAR_LISP ("after-load-alist", &Vafter_load_alist
,
1572 "An alist of expressions to be evalled when particular files are loaded.\n\
1573 Each element looks like (FILENAME FORMS...).\n\
1574 When `load' is run and the file-name argument is FILENAME,\n\
1575 the FORMS in the corresponding element are executed at the end of loading.\n\n\
1576 FILENAME must match exactly! Normally FILENAME is the name of a library,\n\
1577 with no directory specified, since that is how `load' is normally called.\n\
1578 An error in FORMS does not undo the load,\n\
1579 but does prevent execution of the rest of the FORMS.");
1580 Vafter_load_alist
= Qnil
;
1582 Qstandard_input
= intern ("standard-input");
1583 staticpro (&Qstandard_input
);
1585 Qread_char
= intern ("read-char");
1586 staticpro (&Qread_char
);
1588 Qget_file_char
= intern ("get-file-char");
1589 staticpro (&Qget_file_char
);