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, 1, "",
504 "Execute the current buffer as Lisp code.\n\
505 Programs can pass two arguments, BUFFER and PRINTFLAG.\n\
506 BUFFER is the buffer to evaluate (nil means use current buffer).\n\
507 PRINTFLAG controls printing of output:\n\
508 nil means discard it; anything else is stream for print.\n\
510 If there is no error, point does not move. If there is an error,\n\
511 point remains at the end of the last character read from the buffer.")
513 Lisp_Object bufname
, printflag
;
515 int count
= specpdl_ptr
- specpdl
;
516 Lisp_Object tem
, buf
;
519 buf
= Fcurrent_buffer ();
521 buf
= Fget_buffer (bufname
);
523 error ("No such buffer.");
525 if (NILP (printflag
))
529 specbind (Qstandard_output
, tem
);
530 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
531 BUF_SET_PT (XBUFFER (buf
), BUF_BEGV (XBUFFER (buf
)));
532 readevalloop (buf
, 0, Feval
, !NILP (printflag
));
539 DEFUN ("eval-current-buffer", Feval_current_buffer
, Seval_current_buffer
, 0, 1, "",
540 "Execute the current buffer as Lisp code.\n\
541 Programs can pass argument PRINTFLAG which controls printing of output:\n\
542 nil means discard it; anything else is stream for print.\n\
544 If there is no error, point does not move. If there is an error,\n\
545 point remains at the end of the last character read from the buffer.")
547 Lisp_Object printflag
;
549 int count
= specpdl_ptr
- specpdl
;
552 if (NILP (printflag
))
556 specbind (Qstandard_output
, tem
);
557 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
559 readevalloop (Fcurrent_buffer (), 0, Feval
, !NILP (printflag
));
560 return unbind_to (count
, Qnil
);
564 DEFUN ("eval-region", Feval_region
, Seval_region
, 2, 3, "r",
565 "Execute the region as Lisp code.\n\
566 When called from programs, expects two arguments,\n\
567 giving starting and ending indices in the current buffer\n\
568 of the text to be executed.\n\
569 Programs can pass third argument PRINTFLAG which controls output:\n\
570 nil means discard it; anything else is stream for printing it.\n\
572 If there is no error, point does not move. If there is an error,\n\
573 point remains at the end of the last character read from the buffer.")
575 Lisp_Object b
, e
, printflag
;
577 int count
= specpdl_ptr
- specpdl
;
580 if (NILP (printflag
))
584 specbind (Qstandard_output
, tem
);
586 if (NILP (printflag
))
587 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
588 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
590 /* This both uses b and checks its type. */
592 Fnarrow_to_region (make_number (BEGV
), e
);
593 readevalloop (Fcurrent_buffer (), 0, Feval
, !NILP (printflag
));
595 return unbind_to (count
, Qnil
);
598 #endif /* standalone */
600 DEFUN ("read", Fread
, Sread
, 0, 1, 0,
601 "Read one Lisp expression as text from STREAM, return as Lisp object.\n\
602 If STREAM is nil, use the value of `standard-input' (which see).\n\
603 STREAM or the value of `standard-input' may be:\n\
604 a buffer (read from point and advance it)\n\
605 a marker (read from where it points and advance it)\n\
606 a function (call it with no arguments for each character,\n\
607 call it with a char as argument to push a char back)\n\
608 a string (takes text from string, starting at the beginning)\n\
609 t (read text line using minibuffer and use it).")
611 Lisp_Object readcharfun
;
613 extern Lisp_Object
Fread_minibuffer ();
615 if (NILP (readcharfun
))
616 readcharfun
= Vstandard_input
;
617 if (EQ (readcharfun
, Qt
))
618 readcharfun
= Qread_char
;
621 if (EQ (readcharfun
, Qread_char
))
622 return Fread_minibuffer (build_string ("Lisp expression: "), Qnil
);
625 if (XTYPE (readcharfun
) == Lisp_String
)
626 return Fcar (Fread_from_string (readcharfun
, Qnil
, Qnil
));
628 return read0 (readcharfun
);
631 DEFUN ("read-from-string", Fread_from_string
, Sread_from_string
, 1, 3, 0,
632 "Read one Lisp expression which is represented as text by STRING.\n\
633 Returns a cons: (OBJECT-READ . FINAL-STRING-INDEX).\n\
634 START and END optionally delimit a substring of STRING from which to read;\n\
635 they default to 0 and (length STRING) respectively.")
637 Lisp_Object string
, start
, end
;
639 int startval
, endval
;
642 CHECK_STRING (string
,0);
645 endval
= XSTRING (string
)->size
;
647 { CHECK_NUMBER (end
,2);
649 if (endval
< 0 || endval
> XSTRING (string
)->size
)
650 args_out_of_range (string
, end
);
656 { CHECK_NUMBER (start
,1);
657 startval
= XINT (start
);
658 if (startval
< 0 || startval
> endval
)
659 args_out_of_range (string
, start
);
662 read_from_string_index
= startval
;
663 read_from_string_limit
= endval
;
665 tem
= read0 (string
);
666 return Fcons (tem
, make_number (read_from_string_index
));
669 /* Use this for recursive reads, in contexts where internal tokens are not allowed. */
673 Lisp_Object readcharfun
;
675 register Lisp_Object val
;
678 val
= read1 (readcharfun
);
679 if (XTYPE (val
) == Lisp_Internal
)
682 return Fsignal (Qinvalid_read_syntax
, Fcons (make_string (&c
, 1), Qnil
));
688 static int read_buffer_size
;
689 static char *read_buffer
;
692 read_escape (readcharfun
)
693 Lisp_Object readcharfun
;
695 register int c
= READCHAR
;
720 error ("Invalid escape character syntax");
723 c
= read_escape (readcharfun
);
729 error ("Invalid escape character syntax");
733 c
= read_escape (readcharfun
);
737 return (c
& (0200 | 037));
747 /* An octal escape, as in ANSI C. */
749 register int i
= c
- '0';
750 register int count
= 0;
753 if ((c
= READCHAR
) >= '0' && c
<= '7')
768 /* A hex escape, as in ANSI C. */
774 if (c
>= '0' && c
<= '9')
779 else if ((c
>= 'a' && c
<= 'f')
780 || (c
>= 'A' && c
<= 'F'))
783 if (c
>= 'a' && c
<= 'f')
804 register Lisp_Object readcharfun
;
811 if (c
< 0) return Fsignal (Qend_of_file
, Qnil
);
816 return read_list (0, readcharfun
);
819 return read_vector (readcharfun
);
825 register Lisp_Object val
;
826 XSET (val
, Lisp_Internal
, c
);
834 /* Accept compiled functions at read-time so that we don't have to
835 build them using function calls. */
836 Lisp_Object tmp
= read_vector (readcharfun
);
837 return Fmake_byte_code (XVECTOR(tmp
)->size
, XVECTOR (tmp
)->contents
);
840 return Fsignal (Qinvalid_read_syntax
, Fcons (make_string ("#", 1), Qnil
));
843 while ((c
= READCHAR
) >= 0 && c
!= '\n');
848 return Fcons (Qquote
, Fcons (read0 (readcharfun
), Qnil
));
853 register Lisp_Object val
;
856 if (c
< 0) return Fsignal (Qend_of_file
, Qnil
);
859 XSET (val
, Lisp_Int
, read_escape (readcharfun
));
861 XSET (val
, Lisp_Int
, c
);
868 register char *p
= read_buffer
;
869 register char *end
= read_buffer
+ read_buffer_size
;
873 while ((c
= READCHAR
) >= 0
878 char *new = (char *) xrealloc (read_buffer
, read_buffer_size
*= 2);
879 p
+= new - read_buffer
;
880 read_buffer
+= new - read_buffer
;
881 end
= read_buffer
+ read_buffer_size
;
884 c
= read_escape (readcharfun
);
885 /* c is -1 if \ newline has just been seen */
888 if (p
== read_buffer
)
894 if (c
< 0) return Fsignal (Qend_of_file
, Qnil
);
896 /* If purifying, and string starts with \ newline,
897 return zero instead. This is for doc strings
898 that we are really going to find in etc/DOC.nn.nn */
899 if (!NILP (Vpurify_flag
) && NILP (Vdoc_file_name
) && cancel
)
900 return make_number (0);
903 return make_pure_string (read_buffer
, p
- read_buffer
);
905 return make_string (read_buffer
, p
- read_buffer
);
909 if (c
<= 040) goto retry
;
911 register char *p
= read_buffer
;
914 register char *end
= read_buffer
+ read_buffer_size
;
917 !(c
== '\"' || c
== '\'' || c
== ';' || c
== '?'
918 || c
== '(' || c
== ')'
919 #ifndef LISP_FLOAT_TYPE /* we need to see <number><dot><number> */
921 #endif /* not LISP_FLOAT_TYPE */
922 || c
== '[' || c
== ']' || c
== '#'
927 register char *new = (char *) xrealloc (read_buffer
, read_buffer_size
*= 2);
928 p
+= new - read_buffer
;
929 read_buffer
+= new - read_buffer
;
930 end
= read_buffer
+ read_buffer_size
;
940 char *new = (char *) xrealloc (read_buffer
, read_buffer_size
*= 2);
941 p
+= new - read_buffer
;
942 read_buffer
+= new - read_buffer
;
943 /* end = read_buffer + read_buffer_size; */
950 /* Is it an integer? */
953 register Lisp_Object val
;
955 if (*p1
== '+' || *p1
== '-') p1
++;
958 while (p1
!= p
&& (c
= *p1
) >= '0' && c
<= '9') p1
++;
962 XSET (val
, Lisp_Int
, atoi (read_buffer
));
966 #ifdef LISP_FLOAT_TYPE
967 if (isfloat_string (read_buffer
))
968 return make_float (atof (read_buffer
));
972 return intern (read_buffer
);
977 #ifdef LISP_FLOAT_TYPE
993 if (*cp
== '+' || *cp
== '-')
999 while (isdigit (*cp
))
1010 while (isdigit (*cp
))
1018 if ((*cp
== '+') || (*cp
== '-'))
1024 while (isdigit (*cp
))
1028 && (state
== (LEAD_INT
|DOT_CHAR
|TRAIL_INT
)
1029 || state
== (LEAD_INT
|E_CHAR
|EXP_INT
)
1030 || state
== (LEAD_INT
|DOT_CHAR
|TRAIL_INT
|E_CHAR
|EXP_INT
)));
1032 #endif /* LISP_FLOAT_TYPE */
1035 read_vector (readcharfun
)
1036 Lisp_Object readcharfun
;
1040 register Lisp_Object
*ptr
;
1041 register Lisp_Object tem
, vector
;
1042 register struct Lisp_Cons
*otem
;
1045 tem
= read_list (1, readcharfun
);
1046 len
= Flength (tem
);
1047 vector
= (read_pure
? make_pure_vector (XINT (len
)) : Fmake_vector (len
, Qnil
));
1050 size
= XVECTOR (vector
)->size
;
1051 ptr
= XVECTOR (vector
)->contents
;
1052 for (i
= 0; i
< size
; i
++)
1054 ptr
[i
] = read_pure
? Fpurecopy (Fcar (tem
)) : Fcar (tem
);
1062 /* flag = 1 means check for ] to terminate rather than ) and .
1063 flag = -1 means check for starting with defun
1064 and make structure pure. */
1067 read_list (flag
, readcharfun
)
1069 register Lisp_Object readcharfun
;
1071 /* -1 means check next element for defun,
1072 0 means don't check,
1073 1 means already checked and found defun. */
1074 int defunflag
= flag
< 0 ? -1 : 0;
1075 Lisp_Object val
, tail
;
1076 register Lisp_Object elt
, tem
;
1077 struct gcpro gcpro1
, gcpro2
;
1085 elt
= read1 (readcharfun
);
1087 if (XTYPE (elt
) == Lisp_Internal
)
1091 if (XINT (elt
) == ']')
1093 return Fsignal (Qinvalid_read_syntax
, Fcons (make_string (") or . in a vector", 18), Qnil
));
1095 if (XINT (elt
) == ')')
1097 if (XINT (elt
) == '.')
1101 XCONS (tail
)->cdr
= read0 (readcharfun
);
1103 val
= read0 (readcharfun
);
1104 elt
= read1 (readcharfun
);
1106 if (XTYPE (elt
) == Lisp_Internal
&& XINT (elt
) == ')')
1108 return Fsignal (Qinvalid_read_syntax
, Fcons (make_string (". in wrong context", 18), Qnil
));
1110 return Fsignal (Qinvalid_read_syntax
, Fcons (make_string ("] in a list", 11), Qnil
));
1112 tem
= (read_pure
&& flag
<= 0
1113 ? pure_cons (elt
, Qnil
)
1114 : Fcons (elt
, Qnil
));
1116 XCONS (tail
)->cdr
= tem
;
1121 defunflag
= EQ (elt
, Qdefun
);
1122 else if (defunflag
> 0)
1127 Lisp_Object Vobarray
;
1128 Lisp_Object initial_obarray
;
1131 check_obarray (obarray
)
1132 Lisp_Object obarray
;
1134 while (XTYPE (obarray
) != Lisp_Vector
|| XVECTOR (obarray
)->size
== 0)
1136 /* If Vobarray is now invalid, force it to be valid. */
1137 if (EQ (Vobarray
, obarray
)) Vobarray
= initial_obarray
;
1139 obarray
= wrong_type_argument (Qvectorp
, obarray
);
1144 static int hash_string ();
1145 Lisp_Object
oblookup ();
1152 int len
= strlen (str
);
1153 Lisp_Object obarray
= Vobarray
;
1155 if (XTYPE (obarray
) != Lisp_Vector
|| XVECTOR (obarray
)->size
== 0)
1156 obarray
= check_obarray (obarray
);
1157 tem
= oblookup (obarray
, str
, len
);
1158 if (XTYPE (tem
) == Lisp_Symbol
)
1160 return Fintern ((!NILP (Vpurify_flag
)
1161 ? make_pure_string (str
, len
)
1162 : make_string (str
, len
)),
1166 DEFUN ("intern", Fintern
, Sintern
, 1, 2, 0,
1167 "Return the canonical symbol whose name is STRING.\n\
1168 If there is none, one is created by this function and returned.\n\
1169 A second optional argument specifies the obarray to use;\n\
1170 it defaults to the value of `obarray'.")
1172 Lisp_Object str
, obarray
;
1174 register Lisp_Object tem
, sym
, *ptr
;
1176 if (NILP (obarray
)) obarray
= Vobarray
;
1177 obarray
= check_obarray (obarray
);
1179 CHECK_STRING (str
, 0);
1181 tem
= oblookup (obarray
, XSTRING (str
)->data
, XSTRING (str
)->size
);
1182 if (XTYPE (tem
) != Lisp_Int
)
1185 if (!NILP (Vpurify_flag
))
1186 str
= Fpurecopy (str
);
1187 sym
= Fmake_symbol (str
);
1189 ptr
= &XVECTOR (obarray
)->contents
[XINT (tem
)];
1190 if (XTYPE (*ptr
) == Lisp_Symbol
)
1191 XSYMBOL (sym
)->next
= XSYMBOL (*ptr
);
1193 XSYMBOL (sym
)->next
= 0;
1198 DEFUN ("intern-soft", Fintern_soft
, Sintern_soft
, 1, 2, 0,
1199 "Return the canonical symbol whose name is STRING, or nil if none exists.\n\
1200 A second optional argument specifies the obarray to use;\n\
1201 it defaults to the value of `obarray'.")
1203 Lisp_Object str
, obarray
;
1205 register Lisp_Object tem
;
1207 if (NILP (obarray
)) obarray
= Vobarray
;
1208 obarray
= check_obarray (obarray
);
1210 CHECK_STRING (str
, 0);
1212 tem
= oblookup (obarray
, XSTRING (str
)->data
, XSTRING (str
)->size
);
1213 if (XTYPE (tem
) != Lisp_Int
)
1219 oblookup (obarray
, ptr
, size
)
1220 Lisp_Object obarray
;
1225 register Lisp_Object tail
;
1226 Lisp_Object bucket
, tem
;
1228 if (XTYPE (obarray
) != Lisp_Vector
||
1229 (obsize
= XVECTOR (obarray
)->size
) == 0)
1231 obarray
= check_obarray (obarray
);
1232 obsize
= XVECTOR (obarray
)->size
;
1234 /* Combining next two lines breaks VMS C 2.3. */
1235 hash
= hash_string (ptr
, size
);
1237 bucket
= XVECTOR (obarray
)->contents
[hash
];
1238 if (XFASTINT (bucket
) == 0)
1240 else if (XTYPE (bucket
) != Lisp_Symbol
)
1241 error ("Bad data in guts of obarray"); /* Like CADR error message */
1242 else for (tail
= bucket
; ; XSET (tail
, Lisp_Symbol
, XSYMBOL (tail
)->next
))
1244 if (XSYMBOL (tail
)->name
->size
== size
&&
1245 !bcmp (XSYMBOL (tail
)->name
->data
, ptr
, size
))
1247 else if (XSYMBOL (tail
)->next
== 0)
1250 XSET (tem
, Lisp_Int
, hash
);
1255 hash_string (ptr
, len
)
1259 register unsigned char *p
= ptr
;
1260 register unsigned char *end
= p
+ len
;
1261 register unsigned char c
;
1262 register int hash
= 0;
1267 if (c
>= 0140) c
-= 40;
1268 hash
= ((hash
<<3) + (hash
>>28) + c
);
1270 return hash
& 07777777777;
1274 map_obarray (obarray
, fn
, arg
)
1275 Lisp_Object obarray
;
1280 register Lisp_Object tail
;
1281 CHECK_VECTOR (obarray
, 1);
1282 for (i
= XVECTOR (obarray
)->size
- 1; i
>= 0; i
--)
1284 tail
= XVECTOR (obarray
)->contents
[i
];
1285 if (XFASTINT (tail
) != 0)
1289 if (XSYMBOL (tail
)->next
== 0)
1291 XSET (tail
, Lisp_Symbol
, XSYMBOL (tail
)->next
);
1296 mapatoms_1 (sym
, function
)
1297 Lisp_Object sym
, function
;
1299 call1 (function
, sym
);
1302 DEFUN ("mapatoms", Fmapatoms
, Smapatoms
, 1, 2, 0,
1303 "Call FUNCTION on every symbol in OBARRAY.\n\
1304 OBARRAY defaults to the value of `obarray'.")
1306 Lisp_Object function
, obarray
;
1310 if (NILP (obarray
)) obarray
= Vobarray
;
1311 obarray
= check_obarray (obarray
);
1313 map_obarray (obarray
, mapatoms_1
, function
);
1317 #define OBARRAY_SIZE 509
1322 Lisp_Object oblength
;
1326 XFASTINT (oblength
) = OBARRAY_SIZE
;
1328 Qnil
= Fmake_symbol (make_pure_string ("nil", 3));
1329 Vobarray
= Fmake_vector (oblength
, make_number (0));
1330 initial_obarray
= Vobarray
;
1331 staticpro (&initial_obarray
);
1332 /* Intern nil in the obarray */
1333 /* These locals are to kludge around a pyramid compiler bug. */
1334 hash
= hash_string ("nil", 3);
1335 /* Separate statement here to avoid VAXC bug. */
1336 hash
%= OBARRAY_SIZE
;
1337 tem
= &XVECTOR (Vobarray
)->contents
[hash
];
1340 Qunbound
= Fmake_symbol (make_pure_string ("unbound", 7));
1341 XSYMBOL (Qnil
)->function
= Qunbound
;
1342 XSYMBOL (Qunbound
)->value
= Qunbound
;
1343 XSYMBOL (Qunbound
)->function
= Qunbound
;
1346 XSYMBOL (Qnil
)->value
= Qnil
;
1347 XSYMBOL (Qnil
)->plist
= Qnil
;
1348 XSYMBOL (Qt
)->value
= Qt
;
1350 /* Qt is correct even if CANNOT_DUMP. loadup.el will set to nil at end. */
1353 Qvariable_documentation
= intern ("variable-documentation");
1355 read_buffer_size
= 100;
1356 read_buffer
= (char *) malloc (read_buffer_size
);
1361 struct Lisp_Subr
*sname
;
1364 sym
= intern (sname
->symbol_name
);
1365 XSET (XSYMBOL (sym
)->function
, Lisp_Subr
, sname
);
1368 #ifdef NOTDEF /* use fset in subr.el now */
1370 defalias (sname
, string
)
1371 struct Lisp_Subr
*sname
;
1375 sym
= intern (string
);
1376 XSET (XSYMBOL (sym
)->function
, Lisp_Subr
, sname
);
1380 /* New replacement for DefIntVar; it ignores the doc string argument
1381 on the assumption that make-docfile will handle that. */
1382 /* Define an "integer variable"; a symbol whose value is forwarded
1383 to a C variable of type int. Sample call: */
1384 /* DEFVARINT ("indent-tabs-mode", &indent_tabs_mode, "Documentation"); */
1387 defvar_int (namestring
, address
, doc
)
1393 sym
= intern (namestring
);
1394 XSET (XSYMBOL (sym
)->value
, Lisp_Intfwd
, address
);
1397 /* Similar but define a variable whose value is T if address contains 1,
1398 NIL if address contains 0 */
1401 defvar_bool (namestring
, address
, doc
)
1407 sym
= intern (namestring
);
1408 XSET (XSYMBOL (sym
)->value
, Lisp_Boolfwd
, address
);
1411 /* Similar but define a variable whose value is the Lisp Object stored at address. */
1414 defvar_lisp (namestring
, address
, doc
)
1416 Lisp_Object
*address
;
1420 sym
= intern (namestring
);
1421 XSET (XSYMBOL (sym
)->value
, Lisp_Objfwd
, address
);
1422 staticpro (address
);
1425 /* Similar but don't request gc-marking of the C variable.
1426 Used when that variable will be gc-marked for some other reason,
1427 since marking the same slot twice can cause trouble with strings. */
1430 defvar_lisp_nopro (namestring
, address
, doc
)
1432 Lisp_Object
*address
;
1436 sym
= intern (namestring
);
1437 XSET (XSYMBOL (sym
)->value
, Lisp_Objfwd
, address
);
1442 /* Similar but define a variable whose value is the Lisp Object stored in
1443 the current buffer. address is the address of the slot in the buffer that is current now. */
1446 defvar_per_buffer (namestring
, address
, doc
)
1448 Lisp_Object
*address
;
1453 extern struct buffer buffer_local_symbols
;
1455 sym
= intern (namestring
);
1456 offset
= (char *)address
- (char *)current_buffer
;
1458 XSET (XSYMBOL (sym
)->value
, Lisp_Buffer_Objfwd
,
1459 (Lisp_Object
*) offset
);
1460 *(Lisp_Object
*)(offset
+ (char *)&buffer_local_symbols
) = sym
;
1461 if (*(int *)(offset
+ (char *)&buffer_local_flags
) == 0)
1462 /* Did a DEFVAR_PER_BUFFER without initializing the corresponding
1463 slot of buffer_local_flags */
1467 #endif /* standalone */
1473 /* Compute the default load-path. */
1475 normal
= PATH_LOADSEARCH
;
1476 Vload_path
= decode_env_path (0, normal
);
1478 if (NILP (Vpurify_flag
))
1479 normal
= PATH_LOADSEARCH
;
1481 normal
= PATH_DUMPLOADSEARCH
;
1483 /* In a dumped Emacs, we normally have to reset the value of
1484 Vload_path from PATH_LOADSEARCH, since the value that was dumped
1485 uses ../lisp, instead of the path of the installed elisp
1486 libraries. However, if it appears that Vload_path was changed
1487 from the default before dumping, don't override that value. */
1490 Lisp_Object dump_path
;
1492 dump_path
= decode_env_path (0, PATH_DUMPLOADSEARCH
);
1493 if (! NILP (Fequal (dump_path
, Vload_path
)))
1494 Vload_path
= decode_env_path (0, normal
);
1497 Vload_path
= decode_env_path (0, normal
);
1500 /* Warn if dirs in the *standard* path don't exist. */
1502 Lisp_Object path_tail
;
1504 for (path_tail
= Vload_path
;
1506 path_tail
= XCONS (path_tail
)->cdr
)
1508 Lisp_Object dirfile
;
1509 dirfile
= Fcar (path_tail
);
1510 if (XTYPE (dirfile
) == Lisp_String
)
1512 dirfile
= Fdirectory_file_name (dirfile
);
1513 if (access (XSTRING (dirfile
)->data
, 0) < 0)
1514 printf ("Warning: lisp library (%s) does not exist.\n",
1515 XSTRING (Fcar (path_tail
))->data
);
1520 /* If the EMACSLOADPATH environment variable is set, use its value.
1521 This doesn't apply if we're dumping. */
1522 if (NILP (Vpurify_flag
)
1523 && egetenv ("EMACSLOADPATH"))
1524 Vload_path
= decode_env_path ("EMACSLOADPATH", normal
);
1528 load_in_progress
= 0;
1535 defsubr (&Sread_from_string
);
1537 defsubr (&Sintern_soft
);
1539 defsubr (&Seval_buffer
);
1540 defsubr (&Seval_region
);
1541 defsubr (&Sread_char
);
1542 defsubr (&Sread_char_exclusive
);
1543 #ifdef HAVE_X_WINDOWS
1544 defsubr (&Sread_event
);
1545 #endif /* HAVE_X_WINDOWS */
1546 defsubr (&Sget_file_char
);
1547 defsubr (&Smapatoms
);
1549 DEFVAR_LISP ("obarray", &Vobarray
,
1550 "Symbol table for use by `intern' and `read'.\n\
1551 It is a vector whose length ought to be prime for best results.\n\
1552 The vector's contents don't make sense if examined from Lisp programs;\n\
1553 to find all the symbols in an obarray, use `mapatoms'.");
1555 DEFVAR_LISP ("values", &Vvalues
,
1556 "List of values of all expressions which were read, evaluated and printed.\n\
1557 Order is reverse chronological.");
1559 DEFVAR_LISP ("standard-input", &Vstandard_input
,
1560 "Stream for read to get input from.\n\
1561 See documentation of `read' for possible values.");
1562 Vstandard_input
= Qt
;
1564 DEFVAR_LISP ("load-path", &Vload_path
,
1565 "*List of directories to search for files to load.\n\
1566 Each element is a string (directory name) or nil (try default directory).\n\
1567 Initialized based on EMACSLOADPATH environment variable, if any,\n\
1568 otherwise to default specified in by file `paths.h' when Emacs was built.");
1570 DEFVAR_BOOL ("load-in-progress", &load_in_progress
,
1571 "Non-nil iff inside of `load'.");
1573 DEFVAR_LISP ("after-load-alist", &Vafter_load_alist
,
1574 "An alist of expressions to be evalled when particular files are loaded.\n\
1575 Each element looks like (FILENAME FORMS...).\n\
1576 When `load' is run and the file-name argument is FILENAME,\n\
1577 the FORMS in the corresponding element are executed at the end of loading.\n\n\
1578 FILENAME must match exactly! Normally FILENAME is the name of a library,\n\
1579 with no directory specified, since that is how `load' is normally called.\n\
1580 An error in FORMS does not undo the load,\n\
1581 but does prevent execution of the rest of the FORMS.");
1582 Vafter_load_alist
= Qnil
;
1584 Qstandard_input
= intern ("standard-input");
1585 staticpro (&Qstandard_input
);
1587 Qread_char
= intern ("read-char");
1588 staticpro (&Qread_char
);
1590 Qget_file_char
= intern ("get-file-char");
1591 staticpro (&Qget_file_char
);