Fix previous change.
[emacs.git] / src / lread.c
blobad8ba2a98388eba37cc347687a9bdeffea0274f9
1 /* Lisp parsing and input streams.
2 Copyright (C) 1985, 1986, 1987, 1988, 1989,
3 1993, 1994 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
10 any later version.
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs; see the file COPYING. If not, write to
19 the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
22 #include <config.h>
23 #include <stdio.h>
24 #include <sys/types.h>
25 #include <sys/stat.h>
26 #include <sys/file.h>
27 #include <errno.h>
28 #include "lisp.h"
30 #ifndef standalone
31 #include "buffer.h"
32 #include <paths.h>
33 #include "commands.h"
34 #include "keyboard.h"
35 #include "termhooks.h"
36 #endif
38 #ifdef lint
39 #include <sys/inode.h>
40 #endif /* lint */
42 #ifndef X_OK
43 #define X_OK 01
44 #endif
46 #ifdef LISP_FLOAT_TYPE
47 #ifdef STDC_HEADERS
48 #include <stdlib.h>
49 #endif
51 #ifdef MSDOS
52 #include "msdos.h"
53 /* These are redefined (correctly, but differently) in values.h. */
54 #undef INTBITS
55 #undef LONGBITS
56 #undef SHORTBITS
57 #endif
59 #include <math.h>
60 #endif /* LISP_FLOAT_TYPE */
62 #ifndef O_RDONLY
63 #define O_RDONLY 0
64 #endif
66 extern int errno;
68 Lisp_Object Qread_char, Qget_file_char, Qstandard_input, Qcurrent_load_list;
69 Lisp_Object Qvariable_documentation, Vvalues, Vstandard_input, Vafter_load_alist;
70 Lisp_Object Qascii_character, Qload, Qload_file_name;
72 extern Lisp_Object Qevent_symbol_element_mask;
74 /* non-zero if inside `load' */
75 int load_in_progress;
77 /* Search path for files to be loaded. */
78 Lisp_Object Vload_path;
80 /* This is the user-visible association list that maps features to
81 lists of defs in their load files. */
82 Lisp_Object Vload_history;
84 /* This is used to build the load history. */
85 Lisp_Object Vcurrent_load_list;
87 /* Name of file actually being read by `load'. */
88 Lisp_Object Vload_file_name;
90 /* List of descriptors now open for Fload. */
91 static Lisp_Object load_descriptor_list;
93 /* File for get_file_char to read from. Use by load */
94 static FILE *instream;
96 /* When nonzero, read conses in pure space */
97 static int read_pure;
99 /* For use within read-from-string (this reader is non-reentrant!!) */
100 static int read_from_string_index;
101 static int read_from_string_limit;
103 /* Handle unreading and rereading of characters.
104 Write READCHAR to read a character,
105 UNREAD(c) to unread c to be read again. */
107 #define READCHAR readchar (readcharfun)
108 #define UNREAD(c) unreadchar (readcharfun, c)
110 static int
111 readchar (readcharfun)
112 Lisp_Object readcharfun;
114 Lisp_Object tem;
115 register struct buffer *inbuffer;
116 register int c, mpos;
118 if (BUFFERP (readcharfun))
120 inbuffer = XBUFFER (readcharfun);
122 if (BUF_PT (inbuffer) >= BUF_ZV (inbuffer))
123 return -1;
124 c = *(unsigned char *) BUF_CHAR_ADDRESS (inbuffer, BUF_PT (inbuffer));
125 SET_BUF_PT (inbuffer, BUF_PT (inbuffer) + 1);
127 return c;
129 if (MARKERP (readcharfun))
131 inbuffer = XMARKER (readcharfun)->buffer;
133 mpos = marker_position (readcharfun);
135 if (mpos > BUF_ZV (inbuffer) - 1)
136 return -1;
137 c = *(unsigned char *) BUF_CHAR_ADDRESS (inbuffer, mpos);
138 if (mpos != BUF_GPT (inbuffer))
139 XMARKER (readcharfun)->bufpos++;
140 else
141 Fset_marker (readcharfun, make_number (mpos + 1),
142 Fmarker_buffer (readcharfun));
143 return c;
145 if (EQ (readcharfun, Qget_file_char))
147 c = getc (instream);
148 #ifdef EINTR
149 /* Interrupted reads have been observed while reading over the network */
150 while (c == EOF && ferror (instream) && errno == EINTR)
152 clearerr (instream);
153 c = getc (instream);
155 #endif
156 return c;
159 if (STRINGP (readcharfun))
161 register int c;
162 /* This used to be return of a conditional expression,
163 but that truncated -1 to a char on VMS. */
164 if (read_from_string_index < read_from_string_limit)
165 c = XSTRING (readcharfun)->data[read_from_string_index++];
166 else
167 c = -1;
168 return c;
171 tem = call0 (readcharfun);
173 if (NILP (tem))
174 return -1;
175 return XINT (tem);
178 /* Unread the character C in the way appropriate for the stream READCHARFUN.
179 If the stream is a user function, call it with the char as argument. */
181 static void
182 unreadchar (readcharfun, c)
183 Lisp_Object readcharfun;
184 int c;
186 if (c == -1)
187 /* Don't back up the pointer if we're unreading the end-of-input mark,
188 since readchar didn't advance it when we read it. */
190 else if (BUFFERP (readcharfun))
192 if (XBUFFER (readcharfun) == current_buffer)
193 SET_PT (point - 1);
194 else
195 SET_BUF_PT (XBUFFER (readcharfun), BUF_PT (XBUFFER (readcharfun)) - 1);
197 else if (MARKERP (readcharfun))
198 XMARKER (readcharfun)->bufpos--;
199 else if (STRINGP (readcharfun))
200 read_from_string_index--;
201 else if (EQ (readcharfun, Qget_file_char))
202 ungetc (c, instream);
203 else
204 call1 (readcharfun, make_number (c));
207 static Lisp_Object read0 (), read1 (), read_list (), read_vector ();
209 /* get a character from the tty */
211 extern Lisp_Object read_char ();
213 /* Read input events until we get one that's acceptable for our purposes.
215 If NO_SWITCH_FRAME is non-zero, switch-frame events are stashed
216 until we get a character we like, and then stuffed into
217 unread_switch_frame.
219 If ASCII_REQUIRED is non-zero, we check function key events to see
220 if the unmodified version of the symbol has a Qascii_character
221 property, and use that character, if present.
223 If ERROR_NONASCII is non-zero, we signal an error if the input we
224 get isn't an ASCII character with modifiers. If it's zero but
225 ASCII_REQUIRED is non-zero, we just re-read until we get an ASCII
226 character. */
227 Lisp_Object
228 read_filtered_event (no_switch_frame, ascii_required, error_nonascii)
229 int no_switch_frame, ascii_required, error_nonascii;
231 #ifdef standalone
232 return make_number (getchar ());
233 #else
234 register Lisp_Object val, delayed_switch_frame;
236 delayed_switch_frame = Qnil;
238 /* Read until we get an acceptable event. */
239 retry:
240 val = read_char (0, 0, 0, Qnil, 0);
242 if (BUFFERP (val))
243 goto retry;
245 /* switch-frame events are put off until after the next ASCII
246 character. This is better than signalling an error just because
247 the last characters were typed to a separate minibuffer frame,
248 for example. Eventually, some code which can deal with
249 switch-frame events will read it and process it. */
250 if (no_switch_frame
251 && EVENT_HAS_PARAMETERS (val)
252 && EQ (EVENT_HEAD (val), Qswitch_frame))
254 delayed_switch_frame = val;
255 goto retry;
258 if (ascii_required)
260 /* Convert certain symbols to their ASCII equivalents. */
261 if (SYMBOLP (val))
263 Lisp_Object tem, tem1, tem2;
264 tem = Fget (val, Qevent_symbol_element_mask);
265 if (!NILP (tem))
267 tem1 = Fget (Fcar (tem), Qascii_character);
268 /* Merge this symbol's modifier bits
269 with the ASCII equivalent of its basic code. */
270 if (!NILP (tem1))
271 XSETFASTINT (val, XINT (tem1) | XINT (Fcar (Fcdr (tem))));
275 /* If we don't have a character now, deal with it appropriately. */
276 if (!INTEGERP (val))
278 if (error_nonascii)
280 Vunread_command_events = Fcons (val, Qnil);
281 error ("Non-character input-event");
283 else
284 goto retry;
288 if (! NILP (delayed_switch_frame))
289 unread_switch_frame = delayed_switch_frame;
291 return val;
292 #endif
295 DEFUN ("read-char", Fread_char, Sread_char, 0, 0, 0,
296 "Read a character from the command input (keyboard or macro).\n\
297 It is returned as a number.\n\
298 If the user generates an event which is not a character (i.e. a mouse\n\
299 click or function key event), `read-char' signals an error. As an\n\
300 exception, switch-frame events are put off until non-ASCII events can\n\
301 be read.\n\
302 If you want to read non-character events, or ignore them, call\n\
303 `read-event' or `read-char-exclusive' instead.")
306 return read_filtered_event (1, 1, 1);
309 DEFUN ("read-event", Fread_event, Sread_event, 0, 0, 0,
310 "Read an event object from the input stream.")
313 return read_filtered_event (0, 0, 0);
316 DEFUN ("read-char-exclusive", Fread_char_exclusive, Sread_char_exclusive, 0, 0, 0,
317 "Read a character from the command input (keyboard or macro).\n\
318 It is returned as a number. Non character events are ignored.")
321 return read_filtered_event (1, 1, 0);
324 DEFUN ("get-file-char", Fget_file_char, Sget_file_char, 0, 0, 0,
325 "Don't use this yourself.")
328 register Lisp_Object val;
329 XSETINT (val, getc (instream));
330 return val;
333 static void readevalloop ();
334 static Lisp_Object load_unwind ();
335 static Lisp_Object load_descriptor_unwind ();
337 DEFUN ("load", Fload, Sload, 1, 4, 0,
338 "Execute a file of Lisp code named FILE.\n\
339 First try FILE with `.elc' appended, then try with `.el',\n\
340 then try FILE unmodified.\n\
341 This function searches the directories in `load-path'.\n\
342 If optional second arg NOERROR is non-nil,\n\
343 report no error if FILE doesn't exist.\n\
344 Print messages at start and end of loading unless\n\
345 optional third arg NOMESSAGE is non-nil.\n\
346 If optional fourth arg NOSUFFIX is non-nil, don't try adding\n\
347 suffixes `.elc' or `.el' to the specified name FILE.\n\
348 Return t if file exists.")
349 (str, noerror, nomessage, nosuffix)
350 Lisp_Object str, noerror, nomessage, nosuffix;
352 register FILE *stream;
353 register int fd = -1;
354 register Lisp_Object lispstream;
355 int count = specpdl_ptr - specpdl;
356 Lisp_Object temp;
357 struct gcpro gcpro1;
358 Lisp_Object found;
359 /* 1 means inhibit the message at the beginning. */
360 int nomessage1 = 0;
361 Lisp_Object handler;
362 #ifdef DOS_NT
363 char *dosmode = "rt";
364 #endif /* DOS_NT */
366 CHECK_STRING (str, 0);
368 /* If file name is magic, call the handler. */
369 handler = Ffind_file_name_handler (str, Qload);
370 if (!NILP (handler))
371 return call5 (handler, Qload, str, noerror, nomessage, nosuffix);
373 /* Do this after the handler to avoid
374 the need to gcpro noerror, nomessage and nosuffix.
375 (Below here, we care only whether they are nil or not.) */
376 str = Fsubstitute_in_file_name (str);
378 /* Avoid weird lossage with null string as arg,
379 since it would try to load a directory as a Lisp file */
380 if (XSTRING (str)->size > 0)
382 GCPRO1 (str);
383 fd = openp (Vload_path, str, !NILP (nosuffix) ? "" : ".elc:.el:",
384 &found, 0);
385 UNGCPRO;
388 if (fd < 0)
390 if (NILP (noerror))
391 while (1)
392 Fsignal (Qfile_error, Fcons (build_string ("Cannot open load file"),
393 Fcons (str, Qnil)));
394 else
395 return Qnil;
398 if (!bcmp (&(XSTRING (found)->data[XSTRING (found)->size - 4]),
399 ".elc", 4))
401 struct stat s1, s2;
402 int result;
404 #ifdef DOS_NT
405 dosmode = "rb";
406 #endif /* DOS_NT */
407 stat ((char *)XSTRING (found)->data, &s1);
408 XSTRING (found)->data[XSTRING (found)->size - 1] = 0;
409 result = stat ((char *)XSTRING (found)->data, &s2);
410 if (result >= 0 && (unsigned) s1.st_mtime < (unsigned) s2.st_mtime)
412 message ("Source file `%s' newer than byte-compiled file",
413 XSTRING (found)->data);
414 /* Don't immediately overwrite this message. */
415 if (!noninteractive)
416 nomessage1 = 1;
418 XSTRING (found)->data[XSTRING (found)->size - 1] = 'c';
421 #ifdef DOS_NT
422 close (fd);
423 stream = fopen ((char *) XSTRING (found)->data, dosmode);
424 #else /* not DOS_NT */
425 stream = fdopen (fd, "r");
426 #endif /* not DOS_NT */
427 if (stream == 0)
429 close (fd);
430 error ("Failure to create stdio stream for %s", XSTRING (str)->data);
433 if (NILP (nomessage) && !nomessage1)
434 message ("Loading %s...", XSTRING (str)->data);
436 GCPRO1 (str);
437 lispstream = Fcons (Qnil, Qnil);
438 XSETFASTINT (XCONS (lispstream)->car, (EMACS_UINT)stream >> 16);
439 XSETFASTINT (XCONS (lispstream)->cdr, (EMACS_UINT)stream & 0xffff);
440 record_unwind_protect (load_unwind, lispstream);
441 record_unwind_protect (load_descriptor_unwind, load_descriptor_list);
442 specbind (Qload_file_name, found);
443 load_descriptor_list
444 = Fcons (make_number (fileno (stream)), load_descriptor_list);
445 load_in_progress++;
446 readevalloop (Qget_file_char, stream, str, Feval, 0);
447 unbind_to (count, Qnil);
449 /* Run any load-hooks for this file. */
450 temp = Fassoc (str, Vafter_load_alist);
451 if (!NILP (temp))
452 Fprogn (Fcdr (temp));
453 UNGCPRO;
455 if (!noninteractive && NILP (nomessage))
456 message ("Loading %s...done", XSTRING (str)->data);
457 return Qt;
460 static Lisp_Object
461 load_unwind (stream) /* used as unwind-protect function in load */
462 Lisp_Object stream;
464 fclose ((FILE *) (XFASTINT (XCONS (stream)->car) << 16
465 | XFASTINT (XCONS (stream)->cdr)));
466 if (--load_in_progress < 0) load_in_progress = 0;
467 return Qnil;
470 static Lisp_Object
471 load_descriptor_unwind (oldlist)
472 Lisp_Object oldlist;
474 load_descriptor_list = oldlist;
475 return Qnil;
478 /* Close all descriptors in use for Floads.
479 This is used when starting a subprocess. */
481 void
482 close_load_descs ()
484 Lisp_Object tail;
485 for (tail = load_descriptor_list; !NILP (tail); tail = XCONS (tail)->cdr)
486 close (XFASTINT (XCONS (tail)->car));
489 static int
490 complete_filename_p (pathname)
491 Lisp_Object pathname;
493 register unsigned char *s = XSTRING (pathname)->data;
494 return (IS_DIRECTORY_SEP (s[0])
495 || (XSTRING (pathname)->size > 2
496 && IS_DEVICE_SEP (s[1]) && IS_DIRECTORY_SEP (s[2]))
497 #ifdef ALTOS
498 || *s == '@'
499 #endif
500 #ifdef VMS
501 || index (s, ':')
502 #endif /* VMS */
506 /* Search for a file whose name is STR, looking in directories
507 in the Lisp list PATH, and trying suffixes from SUFFIX.
508 SUFFIX is a string containing possible suffixes separated by colons.
509 On success, returns a file descriptor. On failure, returns -1.
511 EXEC_ONLY nonzero means don't open the files,
512 just look for one that is executable. In this case,
513 returns 1 on success.
515 If STOREPTR is nonzero, it points to a slot where the name of
516 the file actually found should be stored as a Lisp string.
517 Nil is stored there on failure. */
520 openp (path, str, suffix, storeptr, exec_only)
521 Lisp_Object path, str;
522 char *suffix;
523 Lisp_Object *storeptr;
524 int exec_only;
526 register int fd;
527 int fn_size = 100;
528 char buf[100];
529 register char *fn = buf;
530 int absolute = 0;
531 int want_size;
532 register Lisp_Object filename;
533 struct stat st;
534 struct gcpro gcpro1;
536 GCPRO1 (str);
537 if (storeptr)
538 *storeptr = Qnil;
540 if (complete_filename_p (str))
541 absolute = 1;
543 for (; !NILP (path); path = Fcdr (path))
545 char *nsuffix;
547 filename = Fexpand_file_name (str, Fcar (path));
548 if (!complete_filename_p (filename))
549 /* If there are non-absolute elts in PATH (eg ".") */
550 /* Of course, this could conceivably lose if luser sets
551 default-directory to be something non-absolute... */
553 filename = Fexpand_file_name (filename, current_buffer->directory);
554 if (!complete_filename_p (filename))
555 /* Give up on this path element! */
556 continue;
559 /* Calculate maximum size of any filename made from
560 this path element/specified file name and any possible suffix. */
561 want_size = strlen (suffix) + XSTRING (filename)->size + 1;
562 if (fn_size < want_size)
563 fn = (char *) alloca (fn_size = 100 + want_size);
565 nsuffix = suffix;
567 /* Loop over suffixes. */
568 while (1)
570 char *esuffix = (char *) index (nsuffix, ':');
571 int lsuffix = esuffix ? esuffix - nsuffix : strlen (nsuffix);
573 /* Concatenate path element/specified name with the suffix. */
574 strncpy (fn, XSTRING (filename)->data, XSTRING (filename)->size);
575 fn[XSTRING (filename)->size] = 0;
576 if (lsuffix != 0) /* Bug happens on CCI if lsuffix is 0. */
577 strncat (fn, nsuffix, lsuffix);
579 /* Ignore file if it's a directory. */
580 if (stat (fn, &st) >= 0
581 && (st.st_mode & S_IFMT) != S_IFDIR)
583 /* Check that we can access or open it. */
584 if (exec_only)
585 fd = (access (fn, X_OK) == 0) ? 1 : -1;
586 else
587 fd = open (fn, O_RDONLY, 0);
589 if (fd >= 0)
591 /* We succeeded; return this descriptor and filename. */
592 if (storeptr)
593 *storeptr = build_string (fn);
594 UNGCPRO;
595 return fd;
599 /* Advance to next suffix. */
600 if (esuffix == 0)
601 break;
602 nsuffix += lsuffix + 1;
604 if (absolute)
605 break;
608 UNGCPRO;
609 return -1;
613 /* Merge the list we've accumulated of globals from the current input source
614 into the load_history variable. The details depend on whether
615 the source has an associated file name or not. */
617 static void
618 build_load_history (stream, source)
619 FILE *stream;
620 Lisp_Object source;
622 register Lisp_Object tail, prev, newelt;
623 register Lisp_Object tem, tem2;
624 register int foundit, loading;
626 /* Don't bother recording anything for preloaded files. */
627 if (!NILP (Vpurify_flag))
628 return;
630 loading = stream || !NARROWED;
632 tail = Vload_history;
633 prev = Qnil;
634 foundit = 0;
635 while (!NILP (tail))
637 tem = Fcar (tail);
639 /* Find the feature's previous assoc list... */
640 if (!NILP (Fequal (source, Fcar (tem))))
642 foundit = 1;
644 /* If we're loading, remove it. */
645 if (loading)
647 if (NILP (prev))
648 Vload_history = Fcdr (tail);
649 else
650 Fsetcdr (prev, Fcdr (tail));
653 /* Otherwise, cons on new symbols that are not already members. */
654 else
656 tem2 = Vcurrent_load_list;
658 while (CONSP (tem2))
660 newelt = Fcar (tem2);
662 if (NILP (Fmemq (newelt, tem)))
663 Fsetcar (tail, Fcons (Fcar (tem),
664 Fcons (newelt, Fcdr (tem))));
666 tem2 = Fcdr (tem2);
667 QUIT;
671 else
672 prev = tail;
673 tail = Fcdr (tail);
674 QUIT;
677 /* If we're loading, cons the new assoc onto the front of load-history,
678 the most-recently-loaded position. Also do this if we didn't find
679 an existing member for the current source. */
680 if (loading || !foundit)
681 Vload_history = Fcons (Fnreverse (Vcurrent_load_list),
682 Vload_history);
685 Lisp_Object
686 unreadpure () /* Used as unwind-protect function in readevalloop */
688 read_pure = 0;
689 return Qnil;
692 static void
693 readevalloop (readcharfun, stream, sourcename, evalfun, printflag)
694 Lisp_Object readcharfun;
695 FILE *stream;
696 Lisp_Object sourcename;
697 Lisp_Object (*evalfun) ();
698 int printflag;
700 register int c;
701 register Lisp_Object val;
702 int count = specpdl_ptr - specpdl;
703 struct gcpro gcpro1;
704 struct buffer *b = 0;
706 if (BUFFERP (readcharfun))
707 b = XBUFFER (readcharfun);
708 else if (MARKERP (readcharfun))
709 b = XMARKER (readcharfun)->buffer;
711 specbind (Qstandard_input, readcharfun);
712 specbind (Qcurrent_load_list, Qnil);
714 GCPRO1 (sourcename);
716 LOADHIST_ATTACH (sourcename);
718 while (1)
720 if (b != 0 && NILP (b->name))
721 error ("Reading from killed buffer");
723 instream = stream;
724 c = READCHAR;
725 if (c == ';')
727 while ((c = READCHAR) != '\n' && c != -1);
728 continue;
730 if (c < 0) break;
732 /* Ignore whitespace here, so we can detect eof. */
733 if (c == ' ' || c == '\t' || c == '\n' || c == '\f' || c == '\r')
734 continue;
736 if (!NILP (Vpurify_flag) && c == '(')
738 int count1 = specpdl_ptr - specpdl;
739 record_unwind_protect (unreadpure, Qnil);
740 val = read_list (-1, readcharfun);
741 unbind_to (count1, Qnil);
743 else
745 UNREAD (c);
746 val = read0 (readcharfun);
749 val = (*evalfun) (val);
750 if (printflag)
752 Vvalues = Fcons (val, Vvalues);
753 if (EQ (Vstandard_output, Qt))
754 Fprin1 (val, Qnil);
755 else
756 Fprint (val, Qnil);
760 build_load_history (stream, sourcename);
761 UNGCPRO;
763 unbind_to (count, Qnil);
766 #ifndef standalone
768 DEFUN ("eval-buffer", Feval_buffer, Seval_buffer, 0, 2, "",
769 "Execute the current buffer as Lisp code.\n\
770 Programs can pass two arguments, BUFFER and PRINTFLAG.\n\
771 BUFFER is the buffer to evaluate (nil means use current buffer).\n\
772 PRINTFLAG controls printing of output:\n\
773 nil means discard it; anything else is stream for print.\n\
775 If there is no error, point does not move. If there is an error,\n\
776 point remains at the end of the last character read from the buffer.")
777 (bufname, printflag)
778 Lisp_Object bufname, printflag;
780 int count = specpdl_ptr - specpdl;
781 Lisp_Object tem, buf;
783 if (NILP (bufname))
784 buf = Fcurrent_buffer ();
785 else
786 buf = Fget_buffer (bufname);
787 if (NILP (buf))
788 error ("No such buffer.");
790 if (NILP (printflag))
791 tem = Qsymbolp;
792 else
793 tem = printflag;
794 specbind (Qstandard_output, tem);
795 record_unwind_protect (save_excursion_restore, save_excursion_save ());
796 BUF_SET_PT (XBUFFER (buf), BUF_BEGV (XBUFFER (buf)));
797 readevalloop (buf, 0, XBUFFER (buf)->filename, Feval, !NILP (printflag));
798 unbind_to (count, Qnil);
800 return Qnil;
803 #if 0
804 DEFUN ("eval-current-buffer", Feval_current_buffer, Seval_current_buffer, 0, 1, "",
805 "Execute the current buffer as Lisp code.\n\
806 Programs can pass argument PRINTFLAG which controls printing of output:\n\
807 nil means discard it; anything else is stream for print.\n\
809 If there is no error, point does not move. If there is an error,\n\
810 point remains at the end of the last character read from the buffer.")
811 (printflag)
812 Lisp_Object printflag;
814 int count = specpdl_ptr - specpdl;
815 Lisp_Object tem, cbuf;
817 cbuf = Fcurrent_buffer ()
819 if (NILP (printflag))
820 tem = Qsymbolp;
821 else
822 tem = printflag;
823 specbind (Qstandard_output, tem);
824 record_unwind_protect (save_excursion_restore, save_excursion_save ());
825 SET_PT (BEGV);
826 readevalloop (cbuf, 0, XBUFFER (cbuf)->filename, Feval, !NILP (printflag));
827 return unbind_to (count, Qnil);
829 #endif
831 DEFUN ("eval-region", Feval_region, Seval_region, 2, 3, "r",
832 "Execute the region as Lisp code.\n\
833 When called from programs, expects two arguments,\n\
834 giving starting and ending indices in the current buffer\n\
835 of the text to be executed.\n\
836 Programs can pass third argument PRINTFLAG which controls output:\n\
837 nil means discard it; anything else is stream for printing it.\n\
839 If there is no error, point does not move. If there is an error,\n\
840 point remains at the end of the last character read from the buffer.")
841 (b, e, printflag)
842 Lisp_Object b, e, printflag;
844 int count = specpdl_ptr - specpdl;
845 Lisp_Object tem, cbuf;
847 cbuf = Fcurrent_buffer ();
849 if (NILP (printflag))
850 tem = Qsymbolp;
851 else
852 tem = printflag;
853 specbind (Qstandard_output, tem);
855 if (NILP (printflag))
856 record_unwind_protect (save_excursion_restore, save_excursion_save ());
857 record_unwind_protect (save_restriction_restore, save_restriction_save ());
859 /* This both uses b and checks its type. */
860 Fgoto_char (b);
861 Fnarrow_to_region (make_number (BEGV), e);
862 readevalloop (cbuf, 0, XBUFFER (cbuf)->filename, Feval, !NILP (printflag));
864 return unbind_to (count, Qnil);
867 #endif /* standalone */
869 DEFUN ("read", Fread, Sread, 0, 1, 0,
870 "Read one Lisp expression as text from STREAM, return as Lisp object.\n\
871 If STREAM is nil, use the value of `standard-input' (which see).\n\
872 STREAM or the value of `standard-input' may be:\n\
873 a buffer (read from point and advance it)\n\
874 a marker (read from where it points and advance it)\n\
875 a function (call it with no arguments for each character,\n\
876 call it with a char as argument to push a char back)\n\
877 a string (takes text from string, starting at the beginning)\n\
878 t (read text line using minibuffer and use it).")
879 (readcharfun)
880 Lisp_Object readcharfun;
882 extern Lisp_Object Fread_minibuffer ();
884 if (NILP (readcharfun))
885 readcharfun = Vstandard_input;
886 if (EQ (readcharfun, Qt))
887 readcharfun = Qread_char;
889 #ifndef standalone
890 if (EQ (readcharfun, Qread_char))
891 return Fread_minibuffer (build_string ("Lisp expression: "), Qnil);
892 #endif
894 if (STRINGP (readcharfun))
895 return Fcar (Fread_from_string (readcharfun, Qnil, Qnil));
897 return read0 (readcharfun);
900 DEFUN ("read-from-string", Fread_from_string, Sread_from_string, 1, 3, 0,
901 "Read one Lisp expression which is represented as text by STRING.\n\
902 Returns a cons: (OBJECT-READ . FINAL-STRING-INDEX).\n\
903 START and END optionally delimit a substring of STRING from which to read;\n\
904 they default to 0 and (length STRING) respectively.")
905 (string, start, end)
906 Lisp_Object string, start, end;
908 int startval, endval;
909 Lisp_Object tem;
911 CHECK_STRING (string,0);
913 if (NILP (end))
914 endval = XSTRING (string)->size;
915 else
916 { CHECK_NUMBER (end,2);
917 endval = XINT (end);
918 if (endval < 0 || endval > XSTRING (string)->size)
919 args_out_of_range (string, end);
922 if (NILP (start))
923 startval = 0;
924 else
925 { CHECK_NUMBER (start,1);
926 startval = XINT (start);
927 if (startval < 0 || startval > endval)
928 args_out_of_range (string, start);
931 read_from_string_index = startval;
932 read_from_string_limit = endval;
934 tem = read0 (string);
935 return Fcons (tem, make_number (read_from_string_index));
938 /* Use this for recursive reads, in contexts where internal tokens
939 are not allowed. */
940 static Lisp_Object
941 read0 (readcharfun)
942 Lisp_Object readcharfun;
944 register Lisp_Object val;
945 char c;
947 val = read1 (readcharfun, &c);
948 if (c)
949 Fsignal (Qinvalid_read_syntax, Fcons (make_string (&c, 1), Qnil));
951 return val;
954 static int read_buffer_size;
955 static char *read_buffer;
957 static int
958 read_escape (readcharfun)
959 Lisp_Object readcharfun;
961 register int c = READCHAR;
962 switch (c)
964 case 'a':
965 return '\007';
966 case 'b':
967 return '\b';
968 case 'd':
969 return 0177;
970 case 'e':
971 return 033;
972 case 'f':
973 return '\f';
974 case 'n':
975 return '\n';
976 case 'r':
977 return '\r';
978 case 't':
979 return '\t';
980 case 'v':
981 return '\v';
982 case '\n':
983 return -1;
985 case 'M':
986 c = READCHAR;
987 if (c != '-')
988 error ("Invalid escape character syntax");
989 c = READCHAR;
990 if (c == '\\')
991 c = read_escape (readcharfun);
992 return c | meta_modifier;
994 case 'S':
995 c = READCHAR;
996 if (c != '-')
997 error ("Invalid escape character syntax");
998 c = READCHAR;
999 if (c == '\\')
1000 c = read_escape (readcharfun);
1001 if ((c & 0xff) >= 'a' && (c & 0xff) <= 'z')
1002 return c - ('a' - 'A');
1003 return c | shift_modifier;
1005 case 'H':
1006 c = READCHAR;
1007 if (c != '-')
1008 error ("Invalid escape character syntax");
1009 c = READCHAR;
1010 if (c == '\\')
1011 c = read_escape (readcharfun);
1012 return c | hyper_modifier;
1014 case 'A':
1015 c = READCHAR;
1016 if (c != '-')
1017 error ("Invalid escape character syntax");
1018 c = READCHAR;
1019 if (c == '\\')
1020 c = read_escape (readcharfun);
1021 return c | alt_modifier;
1023 case 's':
1024 c = READCHAR;
1025 if (c != '-')
1026 error ("Invalid escape character syntax");
1027 c = READCHAR;
1028 if (c == '\\')
1029 c = read_escape (readcharfun);
1030 return c | super_modifier;
1032 case 'C':
1033 c = READCHAR;
1034 if (c != '-')
1035 error ("Invalid escape character syntax");
1036 case '^':
1037 c = READCHAR;
1038 if (c == '\\')
1039 c = read_escape (readcharfun);
1040 if ((c & 0177) == '?')
1041 return 0177 | c;
1042 /* ASCII control chars are made from letters (both cases),
1043 as well as the non-letters within 0100...0137. */
1044 else if ((c & 0137) >= 0101 && (c & 0137) <= 0132)
1045 return (c & (037 | ~0177));
1046 else if ((c & 0177) >= 0100 && (c & 0177) <= 0137)
1047 return (c & (037 | ~0177));
1048 else
1049 return c | ctrl_modifier;
1051 case '0':
1052 case '1':
1053 case '2':
1054 case '3':
1055 case '4':
1056 case '5':
1057 case '6':
1058 case '7':
1059 /* An octal escape, as in ANSI C. */
1061 register int i = c - '0';
1062 register int count = 0;
1063 while (++count < 3)
1065 if ((c = READCHAR) >= '0' && c <= '7')
1067 i *= 8;
1068 i += c - '0';
1070 else
1072 UNREAD (c);
1073 break;
1076 return i;
1079 case 'x':
1080 /* A hex escape, as in ANSI C. */
1082 int i = 0;
1083 while (1)
1085 c = READCHAR;
1086 if (c >= '0' && c <= '9')
1088 i *= 16;
1089 i += c - '0';
1091 else if ((c >= 'a' && c <= 'f')
1092 || (c >= 'A' && c <= 'F'))
1094 i *= 16;
1095 if (c >= 'a' && c <= 'f')
1096 i += c - 'a' + 10;
1097 else
1098 i += c - 'A' + 10;
1100 else
1102 UNREAD (c);
1103 break;
1106 return i;
1109 default:
1110 return c;
1114 /* If the next token is ')' or ']' or '.', we store that character
1115 in *PCH and the return value is not interesting. Else, we store
1116 zero in *PCH and we read and return one lisp object. */
1117 static Lisp_Object
1118 read1 (readcharfun, pch)
1119 register Lisp_Object readcharfun;
1120 char *pch;
1122 register int c;
1123 *pch = 0;
1125 retry:
1127 c = READCHAR;
1128 if (c < 0) return Fsignal (Qend_of_file, Qnil);
1130 switch (c)
1132 case '(':
1133 return read_list (0, readcharfun);
1135 case '[':
1136 return read_vector (readcharfun);
1138 case ')':
1139 case ']':
1141 *pch = c;
1142 return Qnil;
1145 case '#':
1146 c = READCHAR;
1147 if (c == '[')
1149 /* Accept compiled functions at read-time so that we don't have to
1150 build them using function calls. */
1151 Lisp_Object tmp;
1152 tmp = read_vector (readcharfun);
1153 return Fmake_byte_code (XVECTOR (tmp)->size,
1154 XVECTOR (tmp)->contents);
1156 #ifdef USE_TEXT_PROPERTIES
1157 if (c == '(')
1159 Lisp_Object tmp;
1160 struct gcpro gcpro1;
1161 char ch;
1163 /* Read the string itself. */
1164 tmp = read1 (readcharfun, &ch);
1165 if (ch != 0 || !STRINGP (tmp))
1166 Fsignal (Qinvalid_read_syntax, Fcons (make_string ("#", 1), Qnil));
1167 GCPRO1 (tmp);
1168 /* Read the intervals and their properties. */
1169 while (1)
1171 Lisp_Object beg, end, plist;
1173 beg = read1 (readcharfun, &ch);
1174 if (ch == ')')
1175 break;
1176 if (ch == 0)
1177 end = read1 (readcharfun, &ch);
1178 if (ch == 0)
1179 plist = read1 (readcharfun, &ch);
1180 if (ch)
1181 Fsignal (Qinvalid_read_syntax,
1182 Fcons (build_string ("invalid string property list"),
1183 Qnil));
1184 Fset_text_properties (beg, end, plist, tmp);
1186 UNGCPRO;
1187 return tmp;
1189 #endif
1190 /* #@NUMBER is used to skip NUMBER following characters.
1191 That's used in .elc files to skip over doc strings
1192 and function definitions. */
1193 if (c == '@')
1195 int i, nskip = 0;
1197 /* Read a decimal integer. */
1198 while ((c = READCHAR) >= 0
1199 && c >= '0' && c <= '9')
1201 nskip *= 10;
1202 nskip += c - '0';
1204 if (c >= 0)
1205 UNREAD (c);
1207 /* Skip that many characters. */
1208 for (i = 0; i < nskip && c >= 0; i++)
1209 c = READCHAR;
1210 goto retry;
1212 if (c == '$')
1213 return Vload_file_name;
1215 UNREAD (c);
1216 Fsignal (Qinvalid_read_syntax, Fcons (make_string ("#", 1), Qnil));
1218 case ';':
1219 while ((c = READCHAR) >= 0 && c != '\n');
1220 goto retry;
1222 case '\'':
1224 return Fcons (Qquote, Fcons (read0 (readcharfun), Qnil));
1227 case '?':
1229 register Lisp_Object val;
1231 c = READCHAR;
1232 if (c < 0) return Fsignal (Qend_of_file, Qnil);
1234 if (c == '\\')
1235 XSETINT (val, read_escape (readcharfun));
1236 else
1237 XSETINT (val, c);
1239 return val;
1242 case '\"':
1244 register char *p = read_buffer;
1245 register char *end = read_buffer + read_buffer_size;
1246 register int c;
1247 int cancel = 0;
1249 while ((c = READCHAR) >= 0
1250 && c != '\"')
1252 if (p == end)
1254 char *new = (char *) xrealloc (read_buffer, read_buffer_size *= 2);
1255 p += new - read_buffer;
1256 read_buffer += new - read_buffer;
1257 end = read_buffer + read_buffer_size;
1259 if (c == '\\')
1260 c = read_escape (readcharfun);
1261 /* c is -1 if \ newline has just been seen */
1262 if (c == -1)
1264 if (p == read_buffer)
1265 cancel = 1;
1267 else
1269 /* Allow `\C- ' and `\C-?'. */
1270 if (c == (CHAR_CTL | ' '))
1271 c = 0;
1272 else if (c == (CHAR_CTL | '?'))
1273 c = 127;
1275 if (c & CHAR_META)
1276 /* Move the meta bit to the right place for a string. */
1277 c = (c & ~CHAR_META) | 0x80;
1278 if (c & ~0xff)
1279 error ("Invalid modifier in string");
1280 *p++ = c;
1283 if (c < 0) return Fsignal (Qend_of_file, Qnil);
1285 /* If purifying, and string starts with \ newline,
1286 return zero instead. This is for doc strings
1287 that we are really going to find in etc/DOC.nn.nn */
1288 if (!NILP (Vpurify_flag) && NILP (Vdoc_file_name) && cancel)
1289 return make_number (0);
1291 if (read_pure)
1292 return make_pure_string (read_buffer, p - read_buffer);
1293 else
1294 return make_string (read_buffer, p - read_buffer);
1297 case '.':
1299 #ifdef LISP_FLOAT_TYPE
1300 /* If a period is followed by a number, then we should read it
1301 as a floating point number. Otherwise, it denotes a dotted
1302 pair. */
1303 int next_char = READCHAR;
1304 UNREAD (next_char);
1306 if (! (next_char >= '0' && next_char <= '9'))
1307 #endif
1309 *pch = c;
1310 return Qnil;
1313 /* Otherwise, we fall through! Note that the atom-reading loop
1314 below will now loop at least once, assuring that we will not
1315 try to UNREAD two characters in a row. */
1317 default:
1318 if (c <= 040) goto retry;
1320 register char *p = read_buffer;
1321 int quoted = 0;
1324 register char *end = read_buffer + read_buffer_size;
1326 while (c > 040 &&
1327 !(c == '\"' || c == '\'' || c == ';' || c == '?'
1328 || c == '(' || c == ')'
1329 #ifndef LISP_FLOAT_TYPE
1330 /* If we have floating-point support, then we need
1331 to allow <digits><dot><digits>. */
1332 || c =='.'
1333 #endif /* not LISP_FLOAT_TYPE */
1334 || c == '[' || c == ']' || c == '#'
1337 if (p == end)
1339 register char *new = (char *) xrealloc (read_buffer, read_buffer_size *= 2);
1340 p += new - read_buffer;
1341 read_buffer += new - read_buffer;
1342 end = read_buffer + read_buffer_size;
1344 if (c == '\\')
1346 c = READCHAR;
1347 quoted = 1;
1349 *p++ = c;
1350 c = READCHAR;
1353 if (p == end)
1355 char *new = (char *) xrealloc (read_buffer, read_buffer_size *= 2);
1356 p += new - read_buffer;
1357 read_buffer += new - read_buffer;
1358 /* end = read_buffer + read_buffer_size; */
1360 *p = 0;
1361 if (c >= 0)
1362 UNREAD (c);
1365 if (!quoted)
1367 register char *p1;
1368 register Lisp_Object val;
1369 p1 = read_buffer;
1370 if (*p1 == '+' || *p1 == '-') p1++;
1371 /* Is it an integer? */
1372 if (p1 != p)
1374 while (p1 != p && (c = *p1) >= '0' && c <= '9') p1++;
1375 #ifdef LISP_FLOAT_TYPE
1376 /* Integers can have trailing decimal points. */
1377 if (p1 > read_buffer && p1 < p && *p1 == '.') p1++;
1378 #endif
1379 if (p1 == p)
1380 /* It is an integer. */
1382 #ifdef LISP_FLOAT_TYPE
1383 if (p1[-1] == '.')
1384 p1[-1] = '\0';
1385 #endif
1386 XSETINT (val, atoi (read_buffer));
1387 return val;
1390 #ifdef LISP_FLOAT_TYPE
1391 if (isfloat_string (read_buffer))
1392 return make_float (atof (read_buffer));
1393 #endif
1396 return intern (read_buffer);
1401 #ifdef LISP_FLOAT_TYPE
1403 #define LEAD_INT 1
1404 #define DOT_CHAR 2
1405 #define TRAIL_INT 4
1406 #define E_CHAR 8
1407 #define EXP_INT 16
1410 isfloat_string (cp)
1411 register char *cp;
1413 register state;
1415 state = 0;
1416 if (*cp == '+' || *cp == '-')
1417 cp++;
1419 if (*cp >= '0' && *cp <= '9')
1421 state |= LEAD_INT;
1422 while (*cp >= '0' && *cp <= '9')
1423 cp++;
1425 if (*cp == '.')
1427 state |= DOT_CHAR;
1428 cp++;
1430 if (*cp >= '0' && *cp <= '9')
1432 state |= TRAIL_INT;
1433 while (*cp >= '0' && *cp <= '9')
1434 cp++;
1436 if (*cp == 'e')
1438 state |= E_CHAR;
1439 cp++;
1441 if ((*cp == '+') || (*cp == '-'))
1442 cp++;
1444 if (*cp >= '0' && *cp <= '9')
1446 state |= EXP_INT;
1447 while (*cp >= '0' && *cp <= '9')
1448 cp++;
1450 return (*cp == 0
1451 && (state == (LEAD_INT|DOT_CHAR|TRAIL_INT)
1452 || state == (DOT_CHAR|TRAIL_INT)
1453 || state == (LEAD_INT|E_CHAR|EXP_INT)
1454 || state == (LEAD_INT|DOT_CHAR|TRAIL_INT|E_CHAR|EXP_INT)
1455 || state == (DOT_CHAR|TRAIL_INT|E_CHAR|EXP_INT)));
1457 #endif /* LISP_FLOAT_TYPE */
1459 static Lisp_Object
1460 read_vector (readcharfun)
1461 Lisp_Object readcharfun;
1463 register int i;
1464 register int size;
1465 register Lisp_Object *ptr;
1466 register Lisp_Object tem, vector;
1467 register struct Lisp_Cons *otem;
1468 Lisp_Object len;
1470 tem = read_list (1, readcharfun);
1471 len = Flength (tem);
1472 vector = (read_pure ? make_pure_vector (XINT (len)) : Fmake_vector (len, Qnil));
1475 size = XVECTOR (vector)->size;
1476 ptr = XVECTOR (vector)->contents;
1477 for (i = 0; i < size; i++)
1479 ptr[i] = read_pure ? Fpurecopy (Fcar (tem)) : Fcar (tem);
1480 otem = XCONS (tem);
1481 tem = Fcdr (tem);
1482 free_cons (otem);
1484 return vector;
1487 /* flag = 1 means check for ] to terminate rather than ) and .
1488 flag = -1 means check for starting with defun
1489 and make structure pure. */
1491 static Lisp_Object
1492 read_list (flag, readcharfun)
1493 int flag;
1494 register Lisp_Object readcharfun;
1496 /* -1 means check next element for defun,
1497 0 means don't check,
1498 1 means already checked and found defun. */
1499 int defunflag = flag < 0 ? -1 : 0;
1500 Lisp_Object val, tail;
1501 register Lisp_Object elt, tem;
1502 struct gcpro gcpro1, gcpro2;
1503 int cancel = 0;
1505 val = Qnil;
1506 tail = Qnil;
1508 while (1)
1510 char ch;
1511 GCPRO2 (val, tail);
1512 elt = read1 (readcharfun, &ch);
1513 UNGCPRO;
1515 /* If purifying, and the list starts with #$,
1516 return 0 instead. This is a doc string reference
1517 and it will be replaced anyway by Snarf-documentation,
1518 so don't waste pure space with it. */
1519 if (EQ (elt, Vload_file_name)
1520 && !NILP (Vpurify_flag) && NILP (Vdoc_file_name))
1521 cancel = 1;
1523 if (ch)
1525 if (flag > 0)
1527 if (ch == ']')
1528 return val;
1529 Fsignal (Qinvalid_read_syntax, Fcons (make_string (") or . in a vector", 18), Qnil));
1531 if (ch == ')')
1532 return val;
1533 if (ch == '.')
1535 GCPRO2 (val, tail);
1536 if (!NILP (tail))
1537 XCONS (tail)->cdr = read0 (readcharfun);
1538 else
1539 val = read0 (readcharfun);
1540 read1 (readcharfun, &ch);
1541 UNGCPRO;
1542 if (ch == ')')
1543 return (cancel ? make_number (0) : val);
1544 return Fsignal (Qinvalid_read_syntax, Fcons (make_string (". in wrong context", 18), Qnil));
1546 return Fsignal (Qinvalid_read_syntax, Fcons (make_string ("] in a list", 11), Qnil));
1548 tem = (read_pure && flag <= 0
1549 ? pure_cons (elt, Qnil)
1550 : Fcons (elt, Qnil));
1551 if (!NILP (tail))
1552 XCONS (tail)->cdr = tem;
1553 else
1554 val = tem;
1555 tail = tem;
1556 if (defunflag < 0)
1557 defunflag = EQ (elt, Qdefun);
1558 else if (defunflag > 0)
1559 read_pure = 1;
1563 Lisp_Object Vobarray;
1564 Lisp_Object initial_obarray;
1566 Lisp_Object
1567 check_obarray (obarray)
1568 Lisp_Object obarray;
1570 while (!VECTORP (obarray) || XVECTOR (obarray)->size == 0)
1572 /* If Vobarray is now invalid, force it to be valid. */
1573 if (EQ (Vobarray, obarray)) Vobarray = initial_obarray;
1575 obarray = wrong_type_argument (Qvectorp, obarray);
1577 return obarray;
1580 static int hash_string ();
1581 Lisp_Object oblookup ();
1583 Lisp_Object
1584 intern (str)
1585 char *str;
1587 Lisp_Object tem;
1588 int len = strlen (str);
1589 Lisp_Object obarray;
1591 obarray = Vobarray;
1592 if (!VECTORP (obarray) || XVECTOR (obarray)->size == 0)
1593 obarray = check_obarray (obarray);
1594 tem = oblookup (obarray, str, len);
1595 if (SYMBOLP (tem))
1596 return tem;
1597 return Fintern ((!NILP (Vpurify_flag)
1598 ? make_pure_string (str, len)
1599 : make_string (str, len)),
1600 obarray);
1603 DEFUN ("intern", Fintern, Sintern, 1, 2, 0,
1604 "Return the canonical symbol whose name is STRING.\n\
1605 If there is none, one is created by this function and returned.\n\
1606 A second optional argument specifies the obarray to use;\n\
1607 it defaults to the value of `obarray'.")
1608 (str, obarray)
1609 Lisp_Object str, obarray;
1611 register Lisp_Object tem, sym, *ptr;
1613 if (NILP (obarray)) obarray = Vobarray;
1614 obarray = check_obarray (obarray);
1616 CHECK_STRING (str, 0);
1618 tem = oblookup (obarray, XSTRING (str)->data, XSTRING (str)->size);
1619 if (!INTEGERP (tem))
1620 return tem;
1622 if (!NILP (Vpurify_flag))
1623 str = Fpurecopy (str);
1624 sym = Fmake_symbol (str);
1626 ptr = &XVECTOR (obarray)->contents[XINT (tem)];
1627 if (SYMBOLP (*ptr))
1628 XSYMBOL (sym)->next = XSYMBOL (*ptr);
1629 else
1630 XSYMBOL (sym)->next = 0;
1631 *ptr = sym;
1632 return sym;
1635 DEFUN ("intern-soft", Fintern_soft, Sintern_soft, 1, 2, 0,
1636 "Return the canonical symbol whose name is STRING, or nil if none exists.\n\
1637 A second optional argument specifies the obarray to use;\n\
1638 it defaults to the value of `obarray'.")
1639 (str, obarray)
1640 Lisp_Object str, obarray;
1642 register Lisp_Object tem;
1644 if (NILP (obarray)) obarray = Vobarray;
1645 obarray = check_obarray (obarray);
1647 CHECK_STRING (str, 0);
1649 tem = oblookup (obarray, XSTRING (str)->data, XSTRING (str)->size);
1650 if (!INTEGERP (tem))
1651 return tem;
1652 return Qnil;
1655 Lisp_Object
1656 oblookup (obarray, ptr, size)
1657 Lisp_Object obarray;
1658 register char *ptr;
1659 register int size;
1661 int hash;
1662 int obsize;
1663 register Lisp_Object tail;
1664 Lisp_Object bucket, tem;
1666 if (!VECTORP (obarray)
1667 || (obsize = XVECTOR (obarray)->size) == 0)
1669 obarray = check_obarray (obarray);
1670 obsize = XVECTOR (obarray)->size;
1672 /* Combining next two lines breaks VMS C 2.3. */
1673 hash = hash_string (ptr, size);
1674 hash %= obsize;
1675 bucket = XVECTOR (obarray)->contents[hash];
1676 if (XFASTINT (bucket) == 0)
1678 else if (!SYMBOLP (bucket))
1679 error ("Bad data in guts of obarray"); /* Like CADR error message */
1680 else for (tail = bucket; ; XSETSYMBOL (tail, XSYMBOL (tail)->next))
1682 if (XSYMBOL (tail)->name->size == size &&
1683 !bcmp (XSYMBOL (tail)->name->data, ptr, size))
1684 return tail;
1685 else if (XSYMBOL (tail)->next == 0)
1686 break;
1688 XSETINT (tem, hash);
1689 return tem;
1692 static int
1693 hash_string (ptr, len)
1694 unsigned char *ptr;
1695 int len;
1697 register unsigned char *p = ptr;
1698 register unsigned char *end = p + len;
1699 register unsigned char c;
1700 register int hash = 0;
1702 while (p != end)
1704 c = *p++;
1705 if (c >= 0140) c -= 40;
1706 hash = ((hash<<3) + (hash>>28) + c);
1708 return hash & 07777777777;
1711 void
1712 map_obarray (obarray, fn, arg)
1713 Lisp_Object obarray;
1714 int (*fn) ();
1715 Lisp_Object arg;
1717 register int i;
1718 register Lisp_Object tail;
1719 CHECK_VECTOR (obarray, 1);
1720 for (i = XVECTOR (obarray)->size - 1; i >= 0; i--)
1722 tail = XVECTOR (obarray)->contents[i];
1723 if (XFASTINT (tail) != 0)
1724 while (1)
1726 (*fn) (tail, arg);
1727 if (XSYMBOL (tail)->next == 0)
1728 break;
1729 XSETSYMBOL (tail, XSYMBOL (tail)->next);
1734 mapatoms_1 (sym, function)
1735 Lisp_Object sym, function;
1737 call1 (function, sym);
1740 DEFUN ("mapatoms", Fmapatoms, Smapatoms, 1, 2, 0,
1741 "Call FUNCTION on every symbol in OBARRAY.\n\
1742 OBARRAY defaults to the value of `obarray'.")
1743 (function, obarray)
1744 Lisp_Object function, obarray;
1746 Lisp_Object tem;
1748 if (NILP (obarray)) obarray = Vobarray;
1749 obarray = check_obarray (obarray);
1751 map_obarray (obarray, mapatoms_1, function);
1752 return Qnil;
1755 #define OBARRAY_SIZE 1511
1757 void
1758 init_obarray ()
1760 Lisp_Object oblength;
1761 int hash;
1762 Lisp_Object *tem;
1764 XSETFASTINT (oblength, OBARRAY_SIZE);
1766 Qnil = Fmake_symbol (make_pure_string ("nil", 3));
1767 Vobarray = Fmake_vector (oblength, make_number (0));
1768 initial_obarray = Vobarray;
1769 staticpro (&initial_obarray);
1770 /* Intern nil in the obarray */
1771 /* These locals are to kludge around a pyramid compiler bug. */
1772 hash = hash_string ("nil", 3);
1773 /* Separate statement here to avoid VAXC bug. */
1774 hash %= OBARRAY_SIZE;
1775 tem = &XVECTOR (Vobarray)->contents[hash];
1776 *tem = Qnil;
1778 Qunbound = Fmake_symbol (make_pure_string ("unbound", 7));
1779 XSYMBOL (Qnil)->function = Qunbound;
1780 XSYMBOL (Qunbound)->value = Qunbound;
1781 XSYMBOL (Qunbound)->function = Qunbound;
1783 Qt = intern ("t");
1784 XSYMBOL (Qnil)->value = Qnil;
1785 XSYMBOL (Qnil)->plist = Qnil;
1786 XSYMBOL (Qt)->value = Qt;
1788 /* Qt is correct even if CANNOT_DUMP. loadup.el will set to nil at end. */
1789 Vpurify_flag = Qt;
1791 Qvariable_documentation = intern ("variable-documentation");
1793 read_buffer_size = 100;
1794 read_buffer = (char *) malloc (read_buffer_size);
1797 void
1798 defsubr (sname)
1799 struct Lisp_Subr *sname;
1801 Lisp_Object sym;
1802 sym = intern (sname->symbol_name);
1803 XSETSUBR (XSYMBOL (sym)->function, sname);
1806 #ifdef NOTDEF /* use fset in subr.el now */
1807 void
1808 defalias (sname, string)
1809 struct Lisp_Subr *sname;
1810 char *string;
1812 Lisp_Object sym;
1813 sym = intern (string);
1814 XSETSUBR (XSYMBOL (sym)->function, sname);
1816 #endif /* NOTDEF */
1818 /* Define an "integer variable"; a symbol whose value is forwarded
1819 to a C variable of type int. Sample call: */
1820 /* DEFVAR_INT ("indent-tabs-mode", &indent_tabs_mode, "Documentation"); */
1821 void
1822 defvar_int (namestring, address)
1823 char *namestring;
1824 int *address;
1826 Lisp_Object sym, val;
1827 sym = intern (namestring);
1828 val = allocate_misc ();
1829 XMISC (val)->type = Lisp_Misc_Intfwd;
1830 XINTFWD (val)->intvar = address;
1831 XSYMBOL (sym)->value = val;
1834 /* Similar but define a variable whose value is T if address contains 1,
1835 NIL if address contains 0 */
1836 void
1837 defvar_bool (namestring, address)
1838 char *namestring;
1839 int *address;
1841 Lisp_Object sym, val;
1842 sym = intern (namestring);
1843 val = allocate_misc ();
1844 XMISC (val)->type = Lisp_Misc_Boolfwd;
1845 XBOOLFWD (val)->boolvar = address;
1846 XSYMBOL (sym)->value = val;
1849 /* Similar but define a variable whose value is the Lisp Object stored
1850 at address. Two versions: with and without gc-marking of the C
1851 variable. The nopro version is used when that variable will be
1852 gc-marked for some other reason, since marking the same slot twice
1853 can cause trouble with strings. */
1854 void
1855 defvar_lisp_nopro (namestring, address)
1856 char *namestring;
1857 Lisp_Object *address;
1859 Lisp_Object sym, val;
1860 sym = intern (namestring);
1861 val = allocate_misc ();
1862 XMISC (val)->type = Lisp_Misc_Objfwd;
1863 XOBJFWD (val)->objvar = address;
1864 XSYMBOL (sym)->value = val;
1867 void
1868 defvar_lisp (namestring, address)
1869 char *namestring;
1870 Lisp_Object *address;
1872 defvar_lisp_nopro (namestring, address);
1873 staticpro (address);
1876 #ifndef standalone
1878 /* Similar but define a variable whose value is the Lisp Object stored in
1879 the current buffer. address is the address of the slot in the buffer
1880 that is current now. */
1882 void
1883 defvar_per_buffer (namestring, address, type, doc)
1884 char *namestring;
1885 Lisp_Object *address;
1886 Lisp_Object type;
1887 char *doc;
1889 Lisp_Object sym, val;
1890 int offset;
1891 extern struct buffer buffer_local_symbols;
1893 sym = intern (namestring);
1894 val = allocate_misc ();
1895 offset = (char *)address - (char *)current_buffer;
1897 XMISC (val)->type = Lisp_Misc_Buffer_Objfwd;
1898 XBUFFER_OBJFWD (val)->offset = offset;
1899 XSYMBOL (sym)->value = val;
1900 *(Lisp_Object *)(offset + (char *)&buffer_local_symbols) = sym;
1901 *(Lisp_Object *)(offset + (char *)&buffer_local_types) = type;
1902 if (XINT (*(Lisp_Object *)(offset + (char *)&buffer_local_flags)) == 0)
1903 /* Did a DEFVAR_PER_BUFFER without initializing the corresponding
1904 slot of buffer_local_flags */
1905 abort ();
1908 #endif /* standalone */
1910 /* Similar but define a variable whose value is the Lisp Object stored
1911 at a particular offset in the current perdisplay object. */
1913 void
1914 defvar_display (namestring, offset)
1915 char *namestring;
1916 int offset;
1918 Lisp_Object sym, val;
1919 sym = intern (namestring);
1920 val = allocate_misc ();
1921 XMISC (val)->type = Lisp_Misc_Display_Objfwd;
1922 XDISPLAY_OBJFWD (val)->offset = offset;
1923 XSYMBOL (sym)->value = val;
1926 init_lread ()
1928 char *normal;
1930 /* Compute the default load-path. */
1931 #ifdef CANNOT_DUMP
1932 normal = PATH_LOADSEARCH;
1933 Vload_path = decode_env_path (0, normal);
1934 #else
1935 if (NILP (Vpurify_flag))
1936 normal = PATH_LOADSEARCH;
1937 else
1938 normal = PATH_DUMPLOADSEARCH;
1940 /* In a dumped Emacs, we normally have to reset the value of
1941 Vload_path from PATH_LOADSEARCH, since the value that was dumped
1942 uses ../lisp, instead of the path of the installed elisp
1943 libraries. However, if it appears that Vload_path was changed
1944 from the default before dumping, don't override that value. */
1945 if (initialized)
1947 Lisp_Object dump_path;
1949 dump_path = decode_env_path (0, PATH_DUMPLOADSEARCH);
1950 if (! NILP (Fequal (dump_path, Vload_path)))
1952 Vload_path = decode_env_path (0, normal);
1953 if (!NILP (Vinstallation_directory))
1955 /* Add to the path the lisp subdir of the
1956 installation dir, if it exists. */
1957 Lisp_Object tem, tem1;
1958 tem = Fexpand_file_name (build_string ("lisp"),
1959 Vinstallation_directory);
1960 tem1 = Ffile_exists_p (tem);
1961 if (!NILP (tem1))
1963 if (NILP (Fmember (tem, Vload_path)))
1964 Vload_path = nconc2 (Vload_path, Fcons (tem, Qnil));
1966 else
1967 /* That dir doesn't exist, so add the build-time
1968 Lisp dirs instead. */
1969 Vload_path = nconc2 (Vload_path, dump_path);
1973 else
1974 Vload_path = decode_env_path (0, normal);
1975 #endif
1977 #ifndef WINDOWSNT
1978 /* When Emacs is invoked over network shares on NT, PATH_LOADSEARCH is
1979 almost never correct, thereby causing a warning to be printed out that
1980 confuses users. Since PATH_LOADSEARCH is always overriden by the
1981 EMACSLOADPATH environment variable below, disable the warning on NT. */
1983 /* Warn if dirs in the *standard* path don't exist. */
1985 Lisp_Object path_tail;
1987 for (path_tail = Vload_path;
1988 !NILP (path_tail);
1989 path_tail = XCONS (path_tail)->cdr)
1991 Lisp_Object dirfile;
1992 dirfile = Fcar (path_tail);
1993 if (STRINGP (dirfile))
1995 dirfile = Fdirectory_file_name (dirfile);
1996 if (access (XSTRING (dirfile)->data, 0) < 0)
1997 fprintf (stderr,
1998 "Warning: Lisp directory `%s' does not exist.\n",
1999 XSTRING (Fcar (path_tail))->data);
2003 #endif /* WINDOWSNT */
2005 /* If the EMACSLOADPATH environment variable is set, use its value.
2006 This doesn't apply if we're dumping. */
2007 if (NILP (Vpurify_flag)
2008 && egetenv ("EMACSLOADPATH"))
2009 Vload_path = decode_env_path ("EMACSLOADPATH", normal);
2011 Vvalues = Qnil;
2013 load_in_progress = 0;
2015 load_descriptor_list = Qnil;
2018 void
2019 syms_of_lread ()
2021 defsubr (&Sread);
2022 defsubr (&Sread_from_string);
2023 defsubr (&Sintern);
2024 defsubr (&Sintern_soft);
2025 defsubr (&Sload);
2026 defsubr (&Seval_buffer);
2027 defsubr (&Seval_region);
2028 defsubr (&Sread_char);
2029 defsubr (&Sread_char_exclusive);
2030 defsubr (&Sread_event);
2031 defsubr (&Sget_file_char);
2032 defsubr (&Smapatoms);
2034 DEFVAR_LISP ("obarray", &Vobarray,
2035 "Symbol table for use by `intern' and `read'.\n\
2036 It is a vector whose length ought to be prime for best results.\n\
2037 The vector's contents don't make sense if examined from Lisp programs;\n\
2038 to find all the symbols in an obarray, use `mapatoms'.");
2040 DEFVAR_LISP ("values", &Vvalues,
2041 "List of values of all expressions which were read, evaluated and printed.\n\
2042 Order is reverse chronological.");
2044 DEFVAR_LISP ("standard-input", &Vstandard_input,
2045 "Stream for read to get input from.\n\
2046 See documentation of `read' for possible values.");
2047 Vstandard_input = Qt;
2049 DEFVAR_LISP ("load-path", &Vload_path,
2050 "*List of directories to search for files to load.\n\
2051 Each element is a string (directory name) or nil (try default directory).\n\
2052 Initialized based on EMACSLOADPATH environment variable, if any,\n\
2053 otherwise to default specified by file `paths.h' when Emacs was built.");
2055 DEFVAR_BOOL ("load-in-progress", &load_in_progress,
2056 "Non-nil iff inside of `load'.");
2058 DEFVAR_LISP ("after-load-alist", &Vafter_load_alist,
2059 "An alist of expressions to be evalled when particular files are loaded.\n\
2060 Each element looks like (FILENAME FORMS...).\n\
2061 When `load' is run and the file-name argument is FILENAME,\n\
2062 the FORMS in the corresponding element are executed at the end of loading.\n\n\
2063 FILENAME must match exactly! Normally FILENAME is the name of a library,\n\
2064 with no directory specified, since that is how `load' is normally called.\n\
2065 An error in FORMS does not undo the load,\n\
2066 but does prevent execution of the rest of the FORMS.");
2067 Vafter_load_alist = Qnil;
2069 DEFVAR_LISP ("load-history", &Vload_history,
2070 "Alist mapping source file names to symbols and features.\n\
2071 Each alist element is a list that starts with a file name,\n\
2072 except for one element (optional) that starts with nil and describes\n\
2073 definitions evaluated from buffers not visiting files.\n\
2074 The remaining elements of each list are symbols defined as functions\n\
2075 or variables, and cons cells `(provide . FEATURE)' and `(require . FEATURE)'.");
2076 Vload_history = Qnil;
2078 DEFVAR_LISP ("load-file-name", &Vload_file_name,
2079 "Full name of file being loaded by `load'.");
2080 Vload_file_name = Qnil;
2082 DEFVAR_LISP ("current-load-list", &Vcurrent_load_list,
2083 "Used for internal purposes by `load'.");
2084 Vcurrent_load_list = Qnil;
2086 load_descriptor_list = Qnil;
2087 staticpro (&load_descriptor_list);
2089 Qcurrent_load_list = intern ("current-load-list");
2090 staticpro (&Qcurrent_load_list);
2092 Qstandard_input = intern ("standard-input");
2093 staticpro (&Qstandard_input);
2095 Qread_char = intern ("read-char");
2096 staticpro (&Qread_char);
2098 Qget_file_char = intern ("get-file-char");
2099 staticpro (&Qget_file_char);
2101 Qascii_character = intern ("ascii-character");
2102 staticpro (&Qascii_character);
2104 Qload = intern ("load");
2105 staticpro (&Qload);
2107 Qload_file_name = intern ("load-file-name");
2108 staticpro (&Qload_file_name);