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-current-buffer", Feval_current_buffer
, Seval_current_buffer
, 0, 1, "",
504 "Execute the current buffer as Lisp code.\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 printflag
;
513 int count
= specpdl_ptr
- specpdl
;
516 if (NILP (printflag
))
520 specbind (Qstandard_output
, tem
);
521 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
523 readevalloop (Fcurrent_buffer (), 0, Feval
, !NILP (printflag
));
524 return unbind_to (count
, Qnil
);
527 DEFUN ("eval-region", Feval_region
, Seval_region
, 2, 3, "r",
528 "Execute the region as Lisp code.\n\
529 When called from programs, expects two arguments,\n\
530 giving starting and ending indices in the current buffer\n\
531 of the text to be executed.\n\
532 Programs can pass third argument PRINTFLAG which controls output:\n\
533 nil means discard it; anything else is stream for printing it.\n\
535 If there is no error, point does not move. If there is an error,\n\
536 point remains at the end of the last character read from the buffer.")
538 Lisp_Object b
, e
, printflag
;
540 int count
= specpdl_ptr
- specpdl
;
543 if (NILP (printflag
))
547 specbind (Qstandard_output
, tem
);
549 if (NILP (printflag
))
550 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
551 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
553 /* This both uses b and checks its type. */
555 Fnarrow_to_region (make_number (BEGV
), e
);
556 readevalloop (Fcurrent_buffer (), 0, Feval
, !NILP (printflag
));
558 return unbind_to (count
, Qnil
);
561 #endif /* standalone */
563 DEFUN ("read", Fread
, Sread
, 0, 1, 0,
564 "Read one Lisp expression as text from STREAM, return as Lisp object.\n\
565 If STREAM is nil, use the value of `standard-input' (which see).\n\
566 STREAM or the value of `standard-input' may be:\n\
567 a buffer (read from point and advance it)\n\
568 a marker (read from where it points and advance it)\n\
569 a function (call it with no arguments for each character,\n\
570 call it with a char as argument to push a char back)\n\
571 a string (takes text from string, starting at the beginning)\n\
572 t (read text line using minibuffer and use it).")
574 Lisp_Object readcharfun
;
576 extern Lisp_Object
Fread_minibuffer ();
578 if (NILP (readcharfun
))
579 readcharfun
= Vstandard_input
;
580 if (EQ (readcharfun
, Qt
))
581 readcharfun
= Qread_char
;
584 if (EQ (readcharfun
, Qread_char
))
585 return Fread_minibuffer (build_string ("Lisp expression: "), Qnil
);
588 if (XTYPE (readcharfun
) == Lisp_String
)
589 return Fcar (Fread_from_string (readcharfun
, Qnil
, Qnil
));
591 return read0 (readcharfun
);
594 DEFUN ("read-from-string", Fread_from_string
, Sread_from_string
, 1, 3, 0,
595 "Read one Lisp expression which is represented as text by STRING.\n\
596 Returns a cons: (OBJECT-READ . FINAL-STRING-INDEX).\n\
597 START and END optionally delimit a substring of STRING from which to read;\n\
598 they default to 0 and (length STRING) respectively.")
600 Lisp_Object string
, start
, end
;
602 int startval
, endval
;
605 CHECK_STRING (string
,0);
608 endval
= XSTRING (string
)->size
;
610 { CHECK_NUMBER (end
,2);
612 if (endval
< 0 || endval
> XSTRING (string
)->size
)
613 args_out_of_range (string
, end
);
619 { CHECK_NUMBER (start
,1);
620 startval
= XINT (start
);
621 if (startval
< 0 || startval
> endval
)
622 args_out_of_range (string
, start
);
625 read_from_string_index
= startval
;
626 read_from_string_limit
= endval
;
628 tem
= read0 (string
);
629 return Fcons (tem
, make_number (read_from_string_index
));
632 /* Use this for recursive reads, in contexts where internal tokens are not allowed. */
636 Lisp_Object readcharfun
;
638 register Lisp_Object val
;
641 val
= read1 (readcharfun
);
642 if (XTYPE (val
) == Lisp_Internal
)
645 return Fsignal (Qinvalid_read_syntax
, Fcons (make_string (&c
, 1), Qnil
));
651 static int read_buffer_size
;
652 static char *read_buffer
;
655 read_escape (readcharfun
)
656 Lisp_Object readcharfun
;
658 register int c
= READCHAR
;
683 error ("Invalid escape character syntax");
686 c
= read_escape (readcharfun
);
692 error ("Invalid escape character syntax");
696 c
= read_escape (readcharfun
);
700 return (c
& (0200 | 037));
710 /* An octal escape, as in ANSI C. */
712 register int i
= c
- '0';
713 register int count
= 0;
716 if ((c
= READCHAR
) >= '0' && c
<= '7')
731 /* A hex escape, as in ANSI C. */
737 if (c
>= '0' && c
<= '9')
742 else if ((c
>= 'a' && c
<= 'f')
743 || (c
>= 'A' && c
<= 'F'))
746 if (c
>= 'a' && c
<= 'f')
767 register Lisp_Object readcharfun
;
774 if (c
< 0) return Fsignal (Qend_of_file
, Qnil
);
779 return read_list (0, readcharfun
);
782 return read_vector (readcharfun
);
788 register Lisp_Object val
;
789 XSET (val
, Lisp_Internal
, c
);
797 /* Accept compiled functions at read-time so that we don't have to
798 build them using function calls. */
799 Lisp_Object tmp
= read_vector (readcharfun
);
800 return Fmake_byte_code (XVECTOR(tmp
)->size
, XVECTOR (tmp
)->contents
);
803 return Fsignal (Qinvalid_read_syntax
, Fcons (make_string ("#", 1), Qnil
));
806 while ((c
= READCHAR
) >= 0 && c
!= '\n');
811 return Fcons (Qquote
, Fcons (read0 (readcharfun
), Qnil
));
816 register Lisp_Object val
;
819 if (c
< 0) return Fsignal (Qend_of_file
, Qnil
);
822 XSET (val
, Lisp_Int
, read_escape (readcharfun
));
824 XSET (val
, Lisp_Int
, c
);
831 register char *p
= read_buffer
;
832 register char *end
= read_buffer
+ read_buffer_size
;
836 while ((c
= READCHAR
) >= 0
841 char *new = (char *) xrealloc (read_buffer
, read_buffer_size
*= 2);
842 p
+= new - read_buffer
;
843 read_buffer
+= new - read_buffer
;
844 end
= read_buffer
+ read_buffer_size
;
847 c
= read_escape (readcharfun
);
848 /* c is -1 if \ newline has just been seen */
851 if (p
== read_buffer
)
857 if (c
< 0) return Fsignal (Qend_of_file
, Qnil
);
859 /* If purifying, and string starts with \ newline,
860 return zero instead. This is for doc strings
861 that we are really going to find in etc/DOC.nn.nn */
862 if (!NILP (Vpurify_flag
) && NILP (Vdoc_file_name
) && cancel
)
863 return make_number (0);
866 return make_pure_string (read_buffer
, p
- read_buffer
);
868 return make_string (read_buffer
, p
- read_buffer
);
872 if (c
<= 040) goto retry
;
874 register char *p
= read_buffer
;
877 register char *end
= read_buffer
+ read_buffer_size
;
880 !(c
== '\"' || c
== '\'' || c
== ';' || c
== '?'
881 || c
== '(' || c
== ')'
882 #ifndef LISP_FLOAT_TYPE /* we need to see <number><dot><number> */
884 #endif /* not LISP_FLOAT_TYPE */
885 || c
== '[' || c
== ']' || c
== '#'
890 register char *new = (char *) xrealloc (read_buffer
, read_buffer_size
*= 2);
891 p
+= new - read_buffer
;
892 read_buffer
+= new - read_buffer
;
893 end
= read_buffer
+ read_buffer_size
;
903 char *new = (char *) xrealloc (read_buffer
, read_buffer_size
*= 2);
904 p
+= new - read_buffer
;
905 read_buffer
+= new - read_buffer
;
906 /* end = read_buffer + read_buffer_size; */
913 /* Is it an integer? */
916 register Lisp_Object val
;
918 if (*p1
== '+' || *p1
== '-') p1
++;
921 while (p1
!= p
&& (c
= *p1
) >= '0' && c
<= '9') p1
++;
925 XSET (val
, Lisp_Int
, atoi (read_buffer
));
929 #ifdef LISP_FLOAT_TYPE
930 if (isfloat_string (read_buffer
))
931 return make_float (atof (read_buffer
));
935 return intern (read_buffer
);
940 #ifdef LISP_FLOAT_TYPE
956 if (*cp
== '+' || *cp
== '-')
962 while (isdigit (*cp
))
973 while (isdigit (*cp
))
981 if ((*cp
== '+') || (*cp
== '-'))
987 while (isdigit (*cp
))
991 && (state
== (LEAD_INT
|DOT_CHAR
|TRAIL_INT
)
992 || state
== (LEAD_INT
|E_CHAR
|EXP_INT
)
993 || state
== (LEAD_INT
|DOT_CHAR
|TRAIL_INT
|E_CHAR
|EXP_INT
)));
995 #endif /* LISP_FLOAT_TYPE */
998 read_vector (readcharfun
)
999 Lisp_Object readcharfun
;
1003 register Lisp_Object
*ptr
;
1004 register Lisp_Object tem
, vector
;
1005 register struct Lisp_Cons
*otem
;
1008 tem
= read_list (1, readcharfun
);
1009 len
= Flength (tem
);
1010 vector
= (read_pure
? make_pure_vector (XINT (len
)) : Fmake_vector (len
, Qnil
));
1013 size
= XVECTOR (vector
)->size
;
1014 ptr
= XVECTOR (vector
)->contents
;
1015 for (i
= 0; i
< size
; i
++)
1017 ptr
[i
] = read_pure
? Fpurecopy (Fcar (tem
)) : Fcar (tem
);
1025 /* flag = 1 means check for ] to terminate rather than ) and .
1026 flag = -1 means check for starting with defun
1027 and make structure pure. */
1030 read_list (flag
, readcharfun
)
1032 register Lisp_Object readcharfun
;
1034 /* -1 means check next element for defun,
1035 0 means don't check,
1036 1 means already checked and found defun. */
1037 int defunflag
= flag
< 0 ? -1 : 0;
1038 Lisp_Object val
, tail
;
1039 register Lisp_Object elt
, tem
;
1040 struct gcpro gcpro1
, gcpro2
;
1048 elt
= read1 (readcharfun
);
1050 if (XTYPE (elt
) == Lisp_Internal
)
1054 if (XINT (elt
) == ']')
1056 return Fsignal (Qinvalid_read_syntax
, Fcons (make_string (") or . in a vector", 18), Qnil
));
1058 if (XINT (elt
) == ')')
1060 if (XINT (elt
) == '.')
1064 XCONS (tail
)->cdr
= read0 (readcharfun
);
1066 val
= read0 (readcharfun
);
1067 elt
= read1 (readcharfun
);
1069 if (XTYPE (elt
) == Lisp_Internal
&& XINT (elt
) == ')')
1071 return Fsignal (Qinvalid_read_syntax
, Fcons (make_string (". in wrong context", 18), Qnil
));
1073 return Fsignal (Qinvalid_read_syntax
, Fcons (make_string ("] in a list", 11), Qnil
));
1075 tem
= (read_pure
&& flag
<= 0
1076 ? pure_cons (elt
, Qnil
)
1077 : Fcons (elt
, Qnil
));
1079 XCONS (tail
)->cdr
= tem
;
1084 defunflag
= EQ (elt
, Qdefun
);
1085 else if (defunflag
> 0)
1090 Lisp_Object Vobarray
;
1091 Lisp_Object initial_obarray
;
1094 check_obarray (obarray
)
1095 Lisp_Object obarray
;
1097 while (XTYPE (obarray
) != Lisp_Vector
|| XVECTOR (obarray
)->size
== 0)
1099 /* If Vobarray is now invalid, force it to be valid. */
1100 if (EQ (Vobarray
, obarray
)) Vobarray
= initial_obarray
;
1102 obarray
= wrong_type_argument (Qvectorp
, obarray
);
1107 static int hash_string ();
1108 Lisp_Object
oblookup ();
1115 int len
= strlen (str
);
1116 Lisp_Object obarray
= Vobarray
;
1118 if (XTYPE (obarray
) != Lisp_Vector
|| XVECTOR (obarray
)->size
== 0)
1119 obarray
= check_obarray (obarray
);
1120 tem
= oblookup (obarray
, str
, len
);
1121 if (XTYPE (tem
) == Lisp_Symbol
)
1123 return Fintern ((!NILP (Vpurify_flag
)
1124 ? make_pure_string (str
, len
)
1125 : make_string (str
, len
)),
1129 DEFUN ("intern", Fintern
, Sintern
, 1, 2, 0,
1130 "Return the canonical symbol whose name is STRING.\n\
1131 If there is none, one is created by this function and returned.\n\
1132 A second optional argument specifies the obarray to use;\n\
1133 it defaults to the value of `obarray'.")
1135 Lisp_Object str
, obarray
;
1137 register Lisp_Object tem
, sym
, *ptr
;
1139 if (NILP (obarray
)) obarray
= Vobarray
;
1140 obarray
= check_obarray (obarray
);
1142 CHECK_STRING (str
, 0);
1144 tem
= oblookup (obarray
, XSTRING (str
)->data
, XSTRING (str
)->size
);
1145 if (XTYPE (tem
) != Lisp_Int
)
1148 if (!NILP (Vpurify_flag
))
1149 str
= Fpurecopy (str
);
1150 sym
= Fmake_symbol (str
);
1152 ptr
= &XVECTOR (obarray
)->contents
[XINT (tem
)];
1153 if (XTYPE (*ptr
) == Lisp_Symbol
)
1154 XSYMBOL (sym
)->next
= XSYMBOL (*ptr
);
1156 XSYMBOL (sym
)->next
= 0;
1161 DEFUN ("intern-soft", Fintern_soft
, Sintern_soft
, 1, 2, 0,
1162 "Return the canonical symbol whose name is STRING, or nil if none exists.\n\
1163 A second optional argument specifies the obarray to use;\n\
1164 it defaults to the value of `obarray'.")
1166 Lisp_Object str
, obarray
;
1168 register Lisp_Object tem
;
1170 if (NILP (obarray
)) obarray
= Vobarray
;
1171 obarray
= check_obarray (obarray
);
1173 CHECK_STRING (str
, 0);
1175 tem
= oblookup (obarray
, XSTRING (str
)->data
, XSTRING (str
)->size
);
1176 if (XTYPE (tem
) != Lisp_Int
)
1182 oblookup (obarray
, ptr
, size
)
1183 Lisp_Object obarray
;
1188 register Lisp_Object tail
;
1189 Lisp_Object bucket
, tem
;
1191 if (XTYPE (obarray
) != Lisp_Vector
||
1192 (obsize
= XVECTOR (obarray
)->size
) == 0)
1194 obarray
= check_obarray (obarray
);
1195 obsize
= XVECTOR (obarray
)->size
;
1197 /* Combining next two lines breaks VMS C 2.3. */
1198 hash
= hash_string (ptr
, size
);
1200 bucket
= XVECTOR (obarray
)->contents
[hash
];
1201 if (XFASTINT (bucket
) == 0)
1203 else if (XTYPE (bucket
) != Lisp_Symbol
)
1204 error ("Bad data in guts of obarray"); /* Like CADR error message */
1205 else for (tail
= bucket
; ; XSET (tail
, Lisp_Symbol
, XSYMBOL (tail
)->next
))
1207 if (XSYMBOL (tail
)->name
->size
== size
&&
1208 !bcmp (XSYMBOL (tail
)->name
->data
, ptr
, size
))
1210 else if (XSYMBOL (tail
)->next
== 0)
1213 XSET (tem
, Lisp_Int
, hash
);
1218 hash_string (ptr
, len
)
1222 register unsigned char *p
= ptr
;
1223 register unsigned char *end
= p
+ len
;
1224 register unsigned char c
;
1225 register int hash
= 0;
1230 if (c
>= 0140) c
-= 40;
1231 hash
= ((hash
<<3) + (hash
>>28) + c
);
1233 return hash
& 07777777777;
1237 map_obarray (obarray
, fn
, arg
)
1238 Lisp_Object obarray
;
1243 register Lisp_Object tail
;
1244 CHECK_VECTOR (obarray
, 1);
1245 for (i
= XVECTOR (obarray
)->size
- 1; i
>= 0; i
--)
1247 tail
= XVECTOR (obarray
)->contents
[i
];
1248 if (XFASTINT (tail
) != 0)
1252 if (XSYMBOL (tail
)->next
== 0)
1254 XSET (tail
, Lisp_Symbol
, XSYMBOL (tail
)->next
);
1259 mapatoms_1 (sym
, function
)
1260 Lisp_Object sym
, function
;
1262 call1 (function
, sym
);
1265 DEFUN ("mapatoms", Fmapatoms
, Smapatoms
, 1, 2, 0,
1266 "Call FUNCTION on every symbol in OBARRAY.\n\
1267 OBARRAY defaults to the value of `obarray'.")
1269 Lisp_Object function
, obarray
;
1273 if (NILP (obarray
)) obarray
= Vobarray
;
1274 obarray
= check_obarray (obarray
);
1276 map_obarray (obarray
, mapatoms_1
, function
);
1280 #define OBARRAY_SIZE 509
1285 Lisp_Object oblength
;
1289 XFASTINT (oblength
) = OBARRAY_SIZE
;
1291 Qnil
= Fmake_symbol (make_pure_string ("nil", 3));
1292 Vobarray
= Fmake_vector (oblength
, make_number (0));
1293 initial_obarray
= Vobarray
;
1294 staticpro (&initial_obarray
);
1295 /* Intern nil in the obarray */
1296 /* These locals are to kludge around a pyramid compiler bug. */
1297 hash
= hash_string ("nil", 3);
1298 /* Separate statement here to avoid VAXC bug. */
1299 hash
%= OBARRAY_SIZE
;
1300 tem
= &XVECTOR (Vobarray
)->contents
[hash
];
1303 Qunbound
= Fmake_symbol (make_pure_string ("unbound", 7));
1304 XSYMBOL (Qnil
)->function
= Qunbound
;
1305 XSYMBOL (Qunbound
)->value
= Qunbound
;
1306 XSYMBOL (Qunbound
)->function
= Qunbound
;
1309 XSYMBOL (Qnil
)->value
= Qnil
;
1310 XSYMBOL (Qnil
)->plist
= Qnil
;
1311 XSYMBOL (Qt
)->value
= Qt
;
1313 /* Qt is correct even if CANNOT_DUMP. loadup.el will set to nil at end. */
1316 Qvariable_documentation
= intern ("variable-documentation");
1318 read_buffer_size
= 100;
1319 read_buffer
= (char *) malloc (read_buffer_size
);
1324 struct Lisp_Subr
*sname
;
1327 sym
= intern (sname
->symbol_name
);
1328 XSET (XSYMBOL (sym
)->function
, Lisp_Subr
, sname
);
1331 #ifdef NOTDEF /* use fset in subr.el now */
1333 defalias (sname
, string
)
1334 struct Lisp_Subr
*sname
;
1338 sym
= intern (string
);
1339 XSET (XSYMBOL (sym
)->function
, Lisp_Subr
, sname
);
1343 /* New replacement for DefIntVar; it ignores the doc string argument
1344 on the assumption that make-docfile will handle that. */
1345 /* Define an "integer variable"; a symbol whose value is forwarded
1346 to a C variable of type int. Sample call: */
1347 /* DEFVARINT ("indent-tabs-mode", &indent_tabs_mode, "Documentation"); */
1350 defvar_int (namestring
, address
, doc
)
1356 sym
= intern (namestring
);
1357 XSET (XSYMBOL (sym
)->value
, Lisp_Intfwd
, address
);
1360 /* Similar but define a variable whose value is T if address contains 1,
1361 NIL if address contains 0 */
1364 defvar_bool (namestring
, address
, doc
)
1370 sym
= intern (namestring
);
1371 XSET (XSYMBOL (sym
)->value
, Lisp_Boolfwd
, address
);
1374 /* Similar but define a variable whose value is the Lisp Object stored at address. */
1377 defvar_lisp (namestring
, address
, doc
)
1379 Lisp_Object
*address
;
1383 sym
= intern (namestring
);
1384 XSET (XSYMBOL (sym
)->value
, Lisp_Objfwd
, address
);
1385 staticpro (address
);
1388 /* Similar but don't request gc-marking of the C variable.
1389 Used when that variable will be gc-marked for some other reason,
1390 since marking the same slot twice can cause trouble with strings. */
1393 defvar_lisp_nopro (namestring
, address
, doc
)
1395 Lisp_Object
*address
;
1399 sym
= intern (namestring
);
1400 XSET (XSYMBOL (sym
)->value
, Lisp_Objfwd
, address
);
1405 /* Similar but define a variable whose value is the Lisp Object stored in
1406 the current buffer. address is the address of the slot in the buffer that is current now. */
1409 defvar_per_buffer (namestring
, address
, doc
)
1411 Lisp_Object
*address
;
1416 extern struct buffer buffer_local_symbols
;
1418 sym
= intern (namestring
);
1419 offset
= (char *)address
- (char *)current_buffer
;
1421 XSET (XSYMBOL (sym
)->value
, Lisp_Buffer_Objfwd
,
1422 (Lisp_Object
*) offset
);
1423 *(Lisp_Object
*)(offset
+ (char *)&buffer_local_symbols
) = sym
;
1424 if (*(int *)(offset
+ (char *)&buffer_local_flags
) == 0)
1425 /* Did a DEFVAR_PER_BUFFER without initializing the corresponding
1426 slot of buffer_local_flags */
1430 #endif /* standalone */
1436 /* Compute the default load-path. */
1438 normal
= PATH_LOADSEARCH
;
1439 Vload_path
= decode_env_path ("", normal
);
1441 if (NILP (Vpurify_flag
))
1442 normal
= PATH_LOADSEARCH
;
1444 normal
= PATH_DUMPLOADSEARCH
;
1446 /* In a dumped Emacs, we normally have to reset the value of
1447 Vload_path from PATH_LOADSEARCH, since the value that was dumped
1448 uses ../lisp, instead of the path of the installed elisp
1449 libraries. However, if it appears that Vload_path was changed
1450 from the default before dumping, don't override that value. */
1453 Lisp_Object dump_path
;
1455 dump_path
= decode_env_path ("", PATH_DUMPLOADSEARCH
);
1456 if (! NILP (Fequal (dump_path
, Vload_path
)))
1457 Vload_path
= decode_env_path ("", normal
);
1460 Vload_path
= decode_env_path ("", normal
);
1463 /* Warn if dirs in the *standard* path don't exist. */
1465 Lisp_Object path_tail
;
1467 for (path_tail
= Vload_path
;
1469 path_tail
= XCONS (path_tail
)->cdr
)
1471 Lisp_Object dirfile
;
1472 dirfile
= Fcar (path_tail
);
1473 if (XTYPE (dirfile
) == Lisp_String
)
1475 dirfile
= Fdirectory_file_name (dirfile
);
1476 if (access (XSTRING (dirfile
)->data
, 0) < 0)
1477 printf ("Warning: lisp library (%s) does not exist.\n",
1478 XSTRING (Fcar (path_tail
))->data
);
1483 /* If the EMACSLOADPATH environment variable is set, use its value.
1484 This doesn't apply if we're dumping. */
1485 if (NILP (Vpurify_flag
)
1486 && egetenv ("EMACSLOADPATH"))
1487 Vload_path
= decode_env_path ("EMACSLOADPATH", normal
);
1491 load_in_progress
= 0;
1498 defsubr (&Sread_from_string
);
1500 defsubr (&Sintern_soft
);
1502 defsubr (&Seval_current_buffer
);
1503 defsubr (&Seval_region
);
1504 defsubr (&Sread_char
);
1505 defsubr (&Sread_char_exclusive
);
1506 #ifdef HAVE_X_WINDOWS
1507 defsubr (&Sread_event
);
1508 #endif /* HAVE_X_WINDOWS */
1509 defsubr (&Sget_file_char
);
1510 defsubr (&Smapatoms
);
1512 DEFVAR_LISP ("obarray", &Vobarray
,
1513 "Symbol table for use by `intern' and `read'.\n\
1514 It is a vector whose length ought to be prime for best results.\n\
1515 The vector's contents don't make sense if examined from Lisp programs;\n\
1516 to find all the symbols in an obarray, use `mapatoms'.");
1518 DEFVAR_LISP ("values", &Vvalues
,
1519 "List of values of all expressions which were read, evaluated and printed.\n\
1520 Order is reverse chronological.");
1522 DEFVAR_LISP ("standard-input", &Vstandard_input
,
1523 "Stream for read to get input from.\n\
1524 See documentation of `read' for possible values.");
1525 Vstandard_input
= Qt
;
1527 DEFVAR_LISP ("load-path", &Vload_path
,
1528 "*List of directories to search for files to load.\n\
1529 Each element is a string (directory name) or nil (try default directory).\n\
1530 Initialized based on EMACSLOADPATH environment variable, if any,\n\
1531 otherwise to default specified in by file `paths.h' when Emacs was built.");
1533 DEFVAR_BOOL ("load-in-progress", &load_in_progress
,
1534 "Non-nil iff inside of `load'.");
1536 DEFVAR_LISP ("after-load-alist", &Vafter_load_alist
,
1537 "An alist of expressions to be evalled when particular files are loaded.\n\
1538 Each element looks like (FILENAME FORMS...).\n\
1539 When `load' is run and the file-name argument is FILENAME,\n\
1540 the FORMS in the corresponding element are executed at the end of loading.\n\n\
1541 FILENAME must match exactly! Normally FILENAME is the name of a library,\n\
1542 with no directory specified, since that is how `load' is normally called.\n\
1543 An error in FORMS does not undo the load,\n\
1544 but does prevent execution of the rest of the FORMS.");
1545 Vafter_load_alist
= Qnil
;
1547 Qstandard_input
= intern ("standard-input");
1548 staticpro (&Qstandard_input
);
1550 Qread_char
= intern ("read-char");
1551 staticpro (&Qread_char
);
1553 Qget_file_char
= intern ("get-file-char");
1554 staticpro (&Qget_file_char
);