1 /* Lisp parsing and input streams.
2 Copyright (C) 1985, 1986, 1987, 1988, 1989 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 1, 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
, !NULL (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 (NULL (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
&& NULL (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 (; !NULL (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 (!NULL (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 (NULL (printflag
))
520 specbind (Qstandard_output
, tem
);
521 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
523 readevalloop (Fcurrent_buffer (), 0, Feval
, !NULL (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 (NULL (printflag
))
547 specbind (Qstandard_output
, tem
);
549 if (NULL (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
, !NULL (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 (NULL (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
);
794 return Fsignal (Qinvalid_read_syntax
, Fcons (make_string ("#", 1), Qnil
));
797 while ((c
= READCHAR
) >= 0 && c
!= '\n');
802 return Fcons (Qquote
, Fcons (read0 (readcharfun
), Qnil
));
807 register Lisp_Object val
;
810 if (c
< 0) return Fsignal (Qend_of_file
, Qnil
);
813 XSET (val
, Lisp_Int
, read_escape (readcharfun
));
815 XSET (val
, Lisp_Int
, c
);
822 register char *p
= read_buffer
;
823 register char *end
= read_buffer
+ read_buffer_size
;
827 while ((c
= READCHAR
) >= 0
832 char *new = (char *) xrealloc (read_buffer
, read_buffer_size
*= 2);
833 p
+= new - read_buffer
;
834 read_buffer
+= new - read_buffer
;
835 end
= read_buffer
+ read_buffer_size
;
838 c
= read_escape (readcharfun
);
839 /* c is -1 if \ newline has just been seen */
842 if (p
== read_buffer
)
848 if (c
< 0) return Fsignal (Qend_of_file
, Qnil
);
850 /* If purifying, and string starts with \ newline,
851 return zero instead. This is for doc strings
852 that we are really going to find in etc/DOC.nn.nn */
853 if (!NULL (Vpurify_flag
) && NULL (Vdoc_file_name
) && cancel
)
854 return make_number (0);
857 return make_pure_string (read_buffer
, p
- read_buffer
);
859 return make_string (read_buffer
, p
- read_buffer
);
863 if (c
<= 040) goto retry
;
865 register char *p
= read_buffer
;
868 register char *end
= read_buffer
+ read_buffer_size
;
871 !(c
== '\"' || c
== '\'' || c
== ';' || c
== '?'
872 || c
== '(' || c
== ')'
873 #ifndef LISP_FLOAT_TYPE /* we need to see <number><dot><number> */
875 #endif /* not LISP_FLOAT_TYPE */
876 || c
== '[' || c
== ']' || c
== '#'
881 register char *new = (char *) xrealloc (read_buffer
, read_buffer_size
*= 2);
882 p
+= new - read_buffer
;
883 read_buffer
+= new - read_buffer
;
884 end
= read_buffer
+ read_buffer_size
;
894 char *new = (char *) xrealloc (read_buffer
, read_buffer_size
*= 2);
895 p
+= new - read_buffer
;
896 read_buffer
+= new - read_buffer
;
897 /* end = read_buffer + read_buffer_size; */
904 /* Is it an integer? */
907 register Lisp_Object val
;
909 if (*p1
== '+' || *p1
== '-') p1
++;
912 while (p1
!= p
&& (c
= *p1
) >= '0' && c
<= '9') p1
++;
916 XSET (val
, Lisp_Int
, atoi (read_buffer
));
920 #ifdef LISP_FLOAT_TYPE
921 if (isfloat_string (read_buffer
))
922 return make_float (atof (read_buffer
));
926 return intern (read_buffer
);
931 #ifdef LISP_FLOAT_TYPE
947 if (*cp
== '+' || *cp
== '-')
953 while (isdigit (*cp
))
964 while (isdigit (*cp
))
972 if ((*cp
== '+') || (*cp
== '-'))
978 while (isdigit (*cp
))
982 && (state
== (LEAD_INT
|DOT_CHAR
|TRAIL_INT
)
983 || state
== (LEAD_INT
|E_CHAR
|EXP_INT
)
984 || state
== (LEAD_INT
|DOT_CHAR
|TRAIL_INT
|E_CHAR
|EXP_INT
)));
986 #endif /* LISP_FLOAT_TYPE */
989 read_vector (readcharfun
)
990 Lisp_Object readcharfun
;
994 register Lisp_Object
*ptr
;
995 register Lisp_Object tem
, vector
;
996 register struct Lisp_Cons
*otem
;
999 tem
= read_list (1, readcharfun
);
1000 len
= Flength (tem
);
1001 vector
= (read_pure
? make_pure_vector (XINT (len
)) : Fmake_vector (len
, Qnil
));
1004 size
= XVECTOR (vector
)->size
;
1005 ptr
= XVECTOR (vector
)->contents
;
1006 for (i
= 0; i
< size
; i
++)
1008 ptr
[i
] = read_pure
? Fpurecopy (Fcar (tem
)) : Fcar (tem
);
1016 /* flag = 1 means check for ] to terminate rather than ) and .
1017 flag = -1 means check for starting with defun
1018 and make structure pure. */
1021 read_list (flag
, readcharfun
)
1023 register Lisp_Object readcharfun
;
1025 /* -1 means check next element for defun,
1026 0 means don't check,
1027 1 means already checked and found defun. */
1028 int defunflag
= flag
< 0 ? -1 : 0;
1029 Lisp_Object val
, tail
;
1030 register Lisp_Object elt
, tem
;
1031 struct gcpro gcpro1
, gcpro2
;
1039 elt
= read1 (readcharfun
);
1041 if (XTYPE (elt
) == Lisp_Internal
)
1045 if (XINT (elt
) == ']')
1047 return Fsignal (Qinvalid_read_syntax
, Fcons (make_string (") or . in a vector", 18), Qnil
));
1049 if (XINT (elt
) == ')')
1051 if (XINT (elt
) == '.')
1055 XCONS (tail
)->cdr
= read0 (readcharfun
);
1057 val
= read0 (readcharfun
);
1058 elt
= read1 (readcharfun
);
1060 if (XTYPE (elt
) == Lisp_Internal
&& XINT (elt
) == ')')
1062 return Fsignal (Qinvalid_read_syntax
, Fcons (make_string (". in wrong context", 18), Qnil
));
1064 return Fsignal (Qinvalid_read_syntax
, Fcons (make_string ("] in a list", 11), Qnil
));
1066 tem
= (read_pure
&& flag
<= 0
1067 ? pure_cons (elt
, Qnil
)
1068 : Fcons (elt
, Qnil
));
1070 XCONS (tail
)->cdr
= tem
;
1075 defunflag
= EQ (elt
, Qdefun
);
1076 else if (defunflag
> 0)
1081 Lisp_Object Vobarray
;
1082 Lisp_Object initial_obarray
;
1085 check_obarray (obarray
)
1086 Lisp_Object obarray
;
1088 while (XTYPE (obarray
) != Lisp_Vector
|| XVECTOR (obarray
)->size
== 0)
1090 /* If Vobarray is now invalid, force it to be valid. */
1091 if (EQ (Vobarray
, obarray
)) Vobarray
= initial_obarray
;
1093 obarray
= wrong_type_argument (Qvectorp
, obarray
);
1098 static int hash_string ();
1099 Lisp_Object
oblookup ();
1106 int len
= strlen (str
);
1107 Lisp_Object obarray
= Vobarray
;
1109 if (XTYPE (obarray
) != Lisp_Vector
|| XVECTOR (obarray
)->size
== 0)
1110 obarray
= check_obarray (obarray
);
1111 tem
= oblookup (obarray
, str
, len
);
1112 if (XTYPE (tem
) == Lisp_Symbol
)
1114 return Fintern ((!NULL (Vpurify_flag
)
1115 ? make_pure_string (str
, len
)
1116 : make_string (str
, len
)),
1120 DEFUN ("intern", Fintern
, Sintern
, 1, 2, 0,
1121 "Return the canonical symbol whose name is STRING.\n\
1122 If there is none, one is created by this function and returned.\n\
1123 A second optional argument specifies the obarray to use;\n\
1124 it defaults to the value of `obarray'.")
1126 Lisp_Object str
, obarray
;
1128 register Lisp_Object tem
, sym
, *ptr
;
1130 if (NULL (obarray
)) obarray
= Vobarray
;
1131 obarray
= check_obarray (obarray
);
1133 CHECK_STRING (str
, 0);
1135 tem
= oblookup (obarray
, XSTRING (str
)->data
, XSTRING (str
)->size
);
1136 if (XTYPE (tem
) != Lisp_Int
)
1139 if (!NULL (Vpurify_flag
))
1140 str
= Fpurecopy (str
);
1141 sym
= Fmake_symbol (str
);
1143 ptr
= &XVECTOR (obarray
)->contents
[XINT (tem
)];
1144 if (XTYPE (*ptr
) == Lisp_Symbol
)
1145 XSYMBOL (sym
)->next
= XSYMBOL (*ptr
);
1147 XSYMBOL (sym
)->next
= 0;
1152 DEFUN ("intern-soft", Fintern_soft
, Sintern_soft
, 1, 2, 0,
1153 "Return the canonical symbol whose name is STRING, or nil if none exists.\n\
1154 A second optional argument specifies the obarray to use;\n\
1155 it defaults to the value of `obarray'.")
1157 Lisp_Object str
, obarray
;
1159 register Lisp_Object tem
;
1161 if (NULL (obarray
)) obarray
= Vobarray
;
1162 obarray
= check_obarray (obarray
);
1164 CHECK_STRING (str
, 0);
1166 tem
= oblookup (obarray
, XSTRING (str
)->data
, XSTRING (str
)->size
);
1167 if (XTYPE (tem
) != Lisp_Int
)
1173 oblookup (obarray
, ptr
, size
)
1174 Lisp_Object obarray
;
1179 register Lisp_Object tail
;
1180 Lisp_Object bucket
, tem
;
1182 if (XTYPE (obarray
) != Lisp_Vector
||
1183 (obsize
= XVECTOR (obarray
)->size
) == 0)
1185 obarray
= check_obarray (obarray
);
1186 obsize
= XVECTOR (obarray
)->size
;
1188 /* Combining next two lines breaks VMS C 2.3. */
1189 hash
= hash_string (ptr
, size
);
1191 bucket
= XVECTOR (obarray
)->contents
[hash
];
1192 if (XFASTINT (bucket
) == 0)
1194 else if (XTYPE (bucket
) != Lisp_Symbol
)
1195 error ("Bad data in guts of obarray"); /* Like CADR error message */
1196 else for (tail
= bucket
; ; XSET (tail
, Lisp_Symbol
, XSYMBOL (tail
)->next
))
1198 if (XSYMBOL (tail
)->name
->size
== size
&&
1199 !bcmp (XSYMBOL (tail
)->name
->data
, ptr
, size
))
1201 else if (XSYMBOL (tail
)->next
== 0)
1204 XSET (tem
, Lisp_Int
, hash
);
1209 hash_string (ptr
, len
)
1213 register unsigned char *p
= ptr
;
1214 register unsigned char *end
= p
+ len
;
1215 register unsigned char c
;
1216 register int hash
= 0;
1221 if (c
>= 0140) c
-= 40;
1222 hash
= ((hash
<<3) + (hash
>>28) + c
);
1224 return hash
& 07777777777;
1228 map_obarray (obarray
, fn
, arg
)
1229 Lisp_Object obarray
;
1234 register Lisp_Object tail
;
1235 CHECK_VECTOR (obarray
, 1);
1236 for (i
= XVECTOR (obarray
)->size
- 1; i
>= 0; i
--)
1238 tail
= XVECTOR (obarray
)->contents
[i
];
1239 if (XFASTINT (tail
) != 0)
1243 if (XSYMBOL (tail
)->next
== 0)
1245 XSET (tail
, Lisp_Symbol
, XSYMBOL (tail
)->next
);
1250 mapatoms_1 (sym
, function
)
1251 Lisp_Object sym
, function
;
1253 call1 (function
, sym
);
1256 DEFUN ("mapatoms", Fmapatoms
, Smapatoms
, 1, 2, 0,
1257 "Call FUNCTION on every symbol in OBARRAY.\n\
1258 OBARRAY defaults to the value of `obarray'.")
1260 Lisp_Object function
, obarray
;
1264 if (NULL (obarray
)) obarray
= Vobarray
;
1265 obarray
= check_obarray (obarray
);
1267 map_obarray (obarray
, mapatoms_1
, function
);
1271 #define OBARRAY_SIZE 509
1276 Lisp_Object oblength
;
1280 XFASTINT (oblength
) = OBARRAY_SIZE
;
1282 Qnil
= Fmake_symbol (make_pure_string ("nil", 3));
1283 Vobarray
= Fmake_vector (oblength
, make_number (0));
1284 initial_obarray
= Vobarray
;
1285 staticpro (&initial_obarray
);
1286 /* Intern nil in the obarray */
1287 /* These locals are to kludge around a pyramid compiler bug. */
1288 hash
= hash_string ("nil", 3);
1289 /* Separate statement here to avoid VAXC bug. */
1290 hash
%= OBARRAY_SIZE
;
1291 tem
= &XVECTOR (Vobarray
)->contents
[hash
];
1294 Qunbound
= Fmake_symbol (make_pure_string ("unbound", 7));
1295 XSYMBOL (Qnil
)->function
= Qunbound
;
1296 XSYMBOL (Qunbound
)->value
= Qunbound
;
1297 XSYMBOL (Qunbound
)->function
= Qunbound
;
1300 XSYMBOL (Qnil
)->value
= Qnil
;
1301 XSYMBOL (Qnil
)->plist
= Qnil
;
1302 XSYMBOL (Qt
)->value
= Qt
;
1304 /* Qt is correct even if CANNOT_DUMP. loadup.el will set to nil at end. */
1307 Qvariable_documentation
= intern ("variable-documentation");
1309 read_buffer_size
= 100;
1310 read_buffer
= (char *) malloc (read_buffer_size
);
1315 struct Lisp_Subr
*sname
;
1318 sym
= intern (sname
->symbol_name
);
1319 XSET (XSYMBOL (sym
)->function
, Lisp_Subr
, sname
);
1322 #ifdef NOTDEF /* use fset in subr.el now */
1324 defalias (sname
, string
)
1325 struct Lisp_Subr
*sname
;
1329 sym
= intern (string
);
1330 XSET (XSYMBOL (sym
)->function
, Lisp_Subr
, sname
);
1334 /* New replacement for DefIntVar; it ignores the doc string argument
1335 on the assumption that make-docfile will handle that. */
1336 /* Define an "integer variable"; a symbol whose value is forwarded
1337 to a C variable of type int. Sample call: */
1338 /* DEFVARINT ("indent-tabs-mode", &indent_tabs_mode, "Documentation"); */
1341 defvar_int (namestring
, address
, doc
)
1347 sym
= intern (namestring
);
1348 XSET (XSYMBOL (sym
)->value
, Lisp_Intfwd
, address
);
1351 /* Similar but define a variable whose value is T if address contains 1,
1352 NIL if address contains 0 */
1355 defvar_bool (namestring
, address
, doc
)
1361 sym
= intern (namestring
);
1362 XSET (XSYMBOL (sym
)->value
, Lisp_Boolfwd
, address
);
1365 /* Similar but define a variable whose value is the Lisp Object stored at address. */
1368 defvar_lisp (namestring
, address
, doc
)
1370 Lisp_Object
*address
;
1374 sym
= intern (namestring
);
1375 XSET (XSYMBOL (sym
)->value
, Lisp_Objfwd
, address
);
1376 staticpro (address
);
1379 /* Similar but don't request gc-marking of the C variable.
1380 Used when that variable will be gc-marked for some other reason,
1381 since marking the same slot twice can cause trouble with strings. */
1384 defvar_lisp_nopro (namestring
, address
, doc
)
1386 Lisp_Object
*address
;
1390 sym
= intern (namestring
);
1391 XSET (XSYMBOL (sym
)->value
, Lisp_Objfwd
, address
);
1396 /* Similar but define a variable whose value is the Lisp Object stored in
1397 the current buffer. address is the address of the slot in the buffer that is current now. */
1400 defvar_per_buffer (namestring
, address
, doc
)
1402 Lisp_Object
*address
;
1407 extern struct buffer buffer_local_symbols
;
1409 sym
= intern (namestring
);
1410 offset
= (char *)address
- (char *)current_buffer
;
1412 XSET (XSYMBOL (sym
)->value
, Lisp_Buffer_Objfwd
,
1413 (Lisp_Object
*) offset
);
1414 *(Lisp_Object
*)(offset
+ (char *)&buffer_local_symbols
) = sym
;
1415 if (*(int *)(offset
+ (char *)&buffer_local_flags
) == 0)
1416 /* Did a DEFVAR_PER_BUFFER without initializing the corresponding
1417 slot of buffer_local_flags */
1421 #endif /* standalone */
1425 char *normal
= PATH_LOADSEARCH
;
1426 Lisp_Object normal_path
;
1428 /* Compute the default load-path. */
1430 /* If running a dumped Emacs in which load-path was set before dumping
1431 to a nonstandard value, use that value. */
1433 && !(XTYPE (Vload_path
) == Lisp_Cons
1434 && XTYPE (XCONS (Vload_path
)->car
) == Lisp_String
1435 && !strcmp (XSTRING (XCONS (Vload_path
)->car
)->data
, "../lisp")))
1436 normal_path
= Vload_path
;
1440 normal_path
= decode_env_path ("", normal
);
1442 Vload_path
= normal_path
;
1445 /* Warn if dirs in the *standard* path don't exist. */
1446 for (; !NULL (normal_path
); normal_path
= XCONS (normal_path
)->cdr
)
1448 Lisp_Object dirfile
;
1449 dirfile
= Fcar (normal_path
);
1450 if (!NULL (dirfile
))
1452 dirfile
= Fdirectory_file_name (dirfile
);
1453 if (access (XSTRING (dirfile
)->data
, 0) < 0)
1454 printf ("Warning: lisp library (%s) does not exist.\n",
1455 XSTRING (Fcar (normal_path
))->data
);
1459 if (egetenv ("EMACSLOADPATH"))
1460 Vload_path
= decode_env_path ("EMACSLOADPATH", normal
);
1462 if (!NULL (Vpurify_flag
))
1463 Vload_path
= Fcons (build_string ("../lisp"), Vload_path
);
1468 load_in_progress
= 0;
1475 defsubr (&Sread_from_string
);
1477 defsubr (&Sintern_soft
);
1479 defsubr (&Seval_current_buffer
);
1480 defsubr (&Seval_region
);
1481 defsubr (&Sread_char
);
1482 defsubr (&Sread_char_exclusive
);
1483 #ifdef HAVE_X_WINDOWS
1484 defsubr (&Sread_event
);
1485 #endif /* HAVE_X_WINDOWS */
1486 defsubr (&Sget_file_char
);
1487 defsubr (&Smapatoms
);
1489 DEFVAR_LISP ("obarray", &Vobarray
,
1490 "Symbol table for use by `intern' and `read'.\n\
1491 It is a vector whose length ought to be prime for best results.\n\
1492 The vector's contents don't make sense if examined from Lisp programs;\n\
1493 to find all the symbols in an obarray, use `mapatoms'.");
1495 DEFVAR_LISP ("values", &Vvalues
,
1496 "List of values of all expressions which were read, evaluated and printed.\n\
1497 Order is reverse chronological.");
1499 DEFVAR_LISP ("standard-input", &Vstandard_input
,
1500 "Stream for read to get input from.\n\
1501 See documentation of `read' for possible values.");
1502 Vstandard_input
= Qt
;
1504 DEFVAR_LISP ("load-path", &Vload_path
,
1505 "*List of directories to search for files to load.\n\
1506 Each element is a string (directory name) or nil (try default directory).\n\
1507 Initialized based on EMACSLOADPATH environment variable, if any,\n\
1508 otherwise to default specified in by file `paths.h' when Emacs was built.");
1510 DEFVAR_BOOL ("load-in-progress", &load_in_progress
,
1511 "Non-nil iff inside of `load'.");
1513 DEFVAR_LISP ("after-load-alist", &Vafter_load_alist
,
1514 "An alist of expressions to be evalled when particular files are loaded.\n\
1515 Each element looks like (FILENAME FORMS...).\n\
1516 When `load' is run and the file-name argument is FILENAME,\n\
1517 the FORMS in the corresponding element are executed at the end of loading.\n\n\
1518 FILENAME must match exactly! Normally FILENAME is the name of a library,\n\
1519 with no directory specified, since that is how `load' is normally called.\n\
1520 An error in FORMS does not undo the load,\n\
1521 but does prevent execution of the rest of the FORMS.");
1522 Vafter_load_alist
= Qnil
;
1524 Qstandard_input
= intern ("standard-input");
1525 staticpro (&Qstandard_input
);
1527 Qread_char
= intern ("read-char");
1528 staticpro (&Qread_char
);
1530 Qget_file_char
= intern ("get-file-char");
1531 staticpro (&Qget_file_char
);