/* Lisp parsing and input streams.
- Copyright (C) 1985, 1986, 1987, 1988, 1989,
- 1992 Free Software Foundation, Inc.
+ Copyright (C) 1985, 1986, 1987, 1988, 1989,
+ 1993, 1994, 1995 Free Software Foundation, Inc.
This file is part of GNU Emacs.
the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+#include <config.h>
#include <stdio.h>
#include <sys/types.h>
#include <sys/stat.h>
#include <sys/file.h>
-#include <ctype.h>
-#undef NULL
-#include "config.h"
+#include <errno.h>
#include "lisp.h"
#ifndef standalone
#include "buffer.h"
-#include "paths.h"
+#include <paths.h>
#include "commands.h"
#include "keyboard.h"
+#include "termhooks.h"
#endif
#ifdef lint
#endif
#ifdef LISP_FLOAT_TYPE
+#ifdef STDC_HEADERS
+#include <stdlib.h>
+#endif
+
+#ifdef MSDOS
+#include "msdos.h"
+#endif
+
#include <math.h>
#endif /* LISP_FLOAT_TYPE */
-Lisp_Object Qread_char, Qget_file_char, Qstandard_input;
+#ifndef O_RDONLY
+#define O_RDONLY 0
+#endif
+
+extern int errno;
+
+Lisp_Object Qread_char, Qget_file_char, Qstandard_input, Qcurrent_load_list;
Lisp_Object Qvariable_documentation, Vvalues, Vstandard_input, Vafter_load_alist;
+Lisp_Object Qascii_character, Qload, Qload_file_name;
+Lisp_Object Qbackquote, Qcomma, Qcomma_at, Qcomma_dot, Qfunction;
+
+extern Lisp_Object Qevent_symbol_element_mask;
/* non-zero if inside `load' */
int load_in_progress;
+/* Directory in which the sources were found. */
+Lisp_Object Vsource_directory;
+
/* Search path for files to be loaded. */
Lisp_Object Vload_path;
-/* File for get_file_char to read from. Use by load */
+/* This is the user-visible association list that maps features to
+ lists of defs in their load files. */
+Lisp_Object Vload_history;
+
+/* This is used to build the load history. */
+Lisp_Object Vcurrent_load_list;
+
+/* Name of file actually being read by `load'. */
+Lisp_Object Vload_file_name;
+
+/* Function to use for reading, in `load' and friends. */
+Lisp_Object Vload_read_function;
+
+/* Nonzero means load should forcibly load all dynamic doc strings. */
+static int load_force_doc_strings;
+
+/* List of descriptors now open for Fload. */
+static Lisp_Object load_descriptor_list;
+
+/* File for get_file_char to read from. Use by load. */
static FILE *instream;
/* When nonzero, read conses in pure space */
static int read_pure;
-/* For use within read-from-string (this reader is non-reentrant!!) */
+/* For use within read-from-string (this reader is non-reentrant!!) */
static int read_from_string_index;
static int read_from_string_limit;
+
+/* This contains the last string skipped with #@. */
+static char *saved_doc_string;
+/* Length of buffer allocated in saved_doc_string. */
+static int saved_doc_string_size;
+/* Length of actual data in saved_doc_string. */
+static int saved_doc_string_length;
+/* This is the file position that string came from. */
+static int saved_doc_string_position;
+
+/* Nonzero means inside a new-style backquote
+ with no surrounding parentheses.
+ Fread initializes this to zero, so we need not specbind it
+ or worry about what happens to it when there is an error. */
+static int new_backquote_flag;
\f
/* Handle unreading and rereading of characters.
Write READCHAR to read a character,
register struct buffer *inbuffer;
register int c, mpos;
- if (XTYPE (readcharfun) == Lisp_Buffer)
+ if (BUFFERP (readcharfun))
{
inbuffer = XBUFFER (readcharfun);
return c;
}
- if (XTYPE (readcharfun) == Lisp_Marker)
+ if (MARKERP (readcharfun))
{
inbuffer = XMARKER (readcharfun)->buffer;
return c;
}
if (EQ (readcharfun, Qget_file_char))
- return getc (instream);
+ {
+ c = getc (instream);
+#ifdef EINTR
+ /* Interrupted reads have been observed while reading over the network */
+ while (c == EOF && ferror (instream) && errno == EINTR)
+ {
+ clearerr (instream);
+ c = getc (instream);
+ }
+#endif
+ return c;
+ }
- if (XTYPE (readcharfun) == Lisp_String)
+ if (STRINGP (readcharfun))
{
register int c;
/* This used to be return of a conditional expression,
Lisp_Object readcharfun;
int c;
{
- if (XTYPE (readcharfun) == Lisp_Buffer)
+ if (c == -1)
+ /* Don't back up the pointer if we're unreading the end-of-input mark,
+ since readchar didn't advance it when we read it. */
+ ;
+ else if (BUFFERP (readcharfun))
{
if (XBUFFER (readcharfun) == current_buffer)
SET_PT (point - 1);
else
SET_BUF_PT (XBUFFER (readcharfun), BUF_PT (XBUFFER (readcharfun)) - 1);
}
- else if (XTYPE (readcharfun) == Lisp_Marker)
+ else if (MARKERP (readcharfun))
XMARKER (readcharfun)->bufpos--;
- else if (XTYPE (readcharfun) == Lisp_String)
+ else if (STRINGP (readcharfun))
read_from_string_index--;
else if (EQ (readcharfun, Qget_file_char))
ungetc (c, instream);
extern Lisp_Object read_char ();
+/* Read input events until we get one that's acceptable for our purposes.
+
+ If NO_SWITCH_FRAME is non-zero, switch-frame events are stashed
+ until we get a character we like, and then stuffed into
+ unread_switch_frame.
+
+ If ASCII_REQUIRED is non-zero, we check function key events to see
+ if the unmodified version of the symbol has a Qascii_character
+ property, and use that character, if present.
+
+ If ERROR_NONASCII is non-zero, we signal an error if the input we
+ get isn't an ASCII character with modifiers. If it's zero but
+ ASCII_REQUIRED is non-zero, we just re-read until we get an ASCII
+ character. */
+Lisp_Object
+read_filtered_event (no_switch_frame, ascii_required, error_nonascii)
+ int no_switch_frame, ascii_required, error_nonascii;
+{
+#ifdef standalone
+ return make_number (getchar ());
+#else
+ register Lisp_Object val, delayed_switch_frame;
+
+ delayed_switch_frame = Qnil;
+
+ /* Read until we get an acceptable event. */
+ retry:
+ val = read_char (0, 0, 0, Qnil, 0);
+
+ if (BUFFERP (val))
+ goto retry;
+
+ /* switch-frame events are put off until after the next ASCII
+ character. This is better than signaling an error just because
+ the last characters were typed to a separate minibuffer frame,
+ for example. Eventually, some code which can deal with
+ switch-frame events will read it and process it. */
+ if (no_switch_frame
+ && EVENT_HAS_PARAMETERS (val)
+ && EQ (EVENT_HEAD (val), Qswitch_frame))
+ {
+ delayed_switch_frame = val;
+ goto retry;
+ }
+
+ if (ascii_required)
+ {
+ /* Convert certain symbols to their ASCII equivalents. */
+ if (SYMBOLP (val))
+ {
+ Lisp_Object tem, tem1, tem2;
+ tem = Fget (val, Qevent_symbol_element_mask);
+ if (!NILP (tem))
+ {
+ tem1 = Fget (Fcar (tem), Qascii_character);
+ /* Merge this symbol's modifier bits
+ with the ASCII equivalent of its basic code. */
+ if (!NILP (tem1))
+ XSETFASTINT (val, XINT (tem1) | XINT (Fcar (Fcdr (tem))));
+ }
+ }
+
+ /* If we don't have a character now, deal with it appropriately. */
+ if (!INTEGERP (val))
+ {
+ if (error_nonascii)
+ {
+ Vunread_command_events = Fcons (val, Qnil);
+ error ("Non-character input-event");
+ }
+ else
+ goto retry;
+ }
+ }
+
+ if (! NILP (delayed_switch_frame))
+ unread_switch_frame = delayed_switch_frame;
+
+ return val;
+#endif
+}
+
DEFUN ("read-char", Fread_char, Sread_char, 0, 0, 0,
"Read a character from the command input (keyboard or macro).\n\
It is returned as a number.\n\
`read-event' or `read-char-exclusive' instead.")
()
{
- register Lisp_Object val;
-
-#ifndef standalone
- {
- register Lisp_Object delayed_switch_frame;
-
- delayed_switch_frame = Qnil;
-
- for (;;)
- {
- val = read_char (0, 0, 0, Qnil, 0);
-
- /* switch-frame events are put off until after the next ASCII
- character. This is better than signalling an error just
- because the last characters were typed to a separate
- minibuffer frame, for example. Eventually, some code which
- can deal with switch-frame events will read it and process
- it. */
- if (EVENT_HAS_PARAMETERS (val)
- && EQ (EVENT_HEAD (val), Qswitch_frame))
- delayed_switch_frame = val;
- else
- break;
- }
-
- if (! NILP (delayed_switch_frame))
- unread_switch_frame = delayed_switch_frame;
-
- /* Only ASCII characters are acceptable. */
- if (XTYPE (val) != Lisp_Int)
- {
- unread_command_event = val;
- error ("Object read was not a character");
- }
- }
-#else
- val = getchar ();
-#endif
-
- return val;
+ return read_filtered_event (1, 1, 1);
}
DEFUN ("read-event", Fread_event, Sread_event, 0, 0, 0,
"Read an event object from the input stream.")
()
{
- register Lisp_Object val;
-
- val = read_char (0, 0, 0, Qnil, 0);
- return val;
+ return read_filtered_event (0, 0, 0);
}
DEFUN ("read-char-exclusive", Fread_char_exclusive, Sread_char_exclusive, 0, 0, 0,
It is returned as a number. Non character events are ignored.")
()
{
- register Lisp_Object val;
-
-#ifndef standalone
- {
- Lisp_Object delayed_switch_frame;
-
- delayed_switch_frame = Qnil;
-
- for (;;)
- {
- val = read_char (0, 0, 0, Qnil, 0);
-
- if (XTYPE (val) == Lisp_Int)
- break;
-
- /* switch-frame events are put off until after the next ASCII
- character. This is better than signalling an error just
- because the last characters were typed to a separate
- minibuffer frame, for example. Eventually, some code which
- can deal with switch-frame events will read it and process
- it. */
- else if (EVENT_HAS_PARAMETERS (val)
- && EQ (EVENT_HEAD (val), Qswitch_frame))
- delayed_switch_frame = val;
-
- /* Drop everything else. */
- }
-
- if (! NILP (delayed_switch_frame))
- unread_switch_frame = delayed_switch_frame;
- }
-#else
- val = getchar ();
-#endif
-
- return val;
+ return read_filtered_event (1, 1, 0);
}
DEFUN ("get-file-char", Fget_file_char, Sget_file_char, 0, 0, 0,
()
{
register Lisp_Object val;
- XSET (val, Lisp_Int, getc (instream));
+ XSETINT (val, getc (instream));
return val;
}
\f
static void readevalloop ();
static Lisp_Object load_unwind ();
+static Lisp_Object load_descriptor_unwind ();
DEFUN ("load", Fload, Sload, 1, 4, 0,
"Execute a file of Lisp code named FILE.\n\
If optional fourth arg NOSUFFIX is non-nil, don't try adding\n\
suffixes `.elc' or `.el' to the specified name FILE.\n\
Return t if file exists.")
- (str, noerror, nomessage, nosuffix)
- Lisp_Object str, noerror, nomessage, nosuffix;
+ (file, noerror, nomessage, nosuffix)
+ Lisp_Object file, noerror, nomessage, nosuffix;
{
register FILE *stream;
register int fd = -1;
register Lisp_Object lispstream;
- register FILE **ptr;
int count = specpdl_ptr - specpdl;
Lisp_Object temp;
struct gcpro gcpro1;
Lisp_Object found;
+ /* 1 means inhibit the message at the beginning. */
+ int nomessage1 = 0;
+ Lisp_Object handler;
+#ifdef DOS_NT
+ char *dosmode = "rt";
+#endif /* DOS_NT */
- CHECK_STRING (str, 0);
- str = Fsubstitute_in_file_name (str);
+ CHECK_STRING (file, 0);
+
+ /* If file name is magic, call the handler. */
+ handler = Ffind_file_name_handler (file, Qload);
+ if (!NILP (handler))
+ return call5 (handler, Qload, file, noerror, nomessage, nosuffix);
+
+ /* Do this after the handler to avoid
+ the need to gcpro noerror, nomessage and nosuffix.
+ (Below here, we care only whether they are nil or not.) */
+ file = Fsubstitute_in_file_name (file);
/* Avoid weird lossage with null string as arg,
since it would try to load a directory as a Lisp file */
- if (XSTRING (str)->size > 0)
+ if (XSTRING (file)->size > 0)
{
- fd = openp (Vload_path, str, !NILP (nosuffix) ? "" : ".elc:.el:",
+ GCPRO1 (file);
+ fd = openp (Vload_path, file, !NILP (nosuffix) ? "" : ".elc:.el:",
&found, 0);
+ UNGCPRO;
}
if (fd < 0)
if (NILP (noerror))
while (1)
Fsignal (Qfile_error, Fcons (build_string ("Cannot open load file"),
- Fcons (str, Qnil)));
+ Fcons (file, Qnil)));
else
return Qnil;
}
struct stat s1, s2;
int result;
- stat (XSTRING (found)->data, &s1);
+#ifdef DOS_NT
+ dosmode = "rb";
+#endif /* DOS_NT */
+ stat ((char *)XSTRING (found)->data, &s1);
XSTRING (found)->data[XSTRING (found)->size - 1] = 0;
- result = stat (XSTRING (found)->data, &s2);
+ result = stat ((char *)XSTRING (found)->data, &s2);
if (result >= 0 && (unsigned) s1.st_mtime < (unsigned) s2.st_mtime)
- message ("Source file `%s' newer than byte-compiled file",
- XSTRING (found)->data);
+ {
+ message ("Source file `%s' newer than byte-compiled file",
+ XSTRING (found)->data);
+ /* Don't immediately overwrite this message. */
+ if (!noninteractive)
+ nomessage1 = 1;
+ }
XSTRING (found)->data[XSTRING (found)->size - 1] = 'c';
}
+#ifdef DOS_NT
+ close (fd);
+ stream = fopen ((char *) XSTRING (found)->data, dosmode);
+#else /* not DOS_NT */
stream = fdopen (fd, "r");
+#endif /* not DOS_NT */
if (stream == 0)
{
close (fd);
- error ("Failure to create stdio stream for %s", XSTRING (str)->data);
+ error ("Failure to create stdio stream for %s", XSTRING (file)->data);
}
- if (NILP (nomessage))
- message ("Loading %s...", XSTRING (str)->data);
+ if (NILP (nomessage) && !nomessage1)
+ message ("Loading %s...", XSTRING (file)->data);
- GCPRO1 (str);
- /* We may not be able to store STREAM itself as a Lisp_Object pointer
- since that is guaranteed to work only for data that has been malloc'd.
- So malloc a full-size pointer, and record the address of that pointer. */
- ptr = (FILE **) xmalloc (sizeof (FILE *));
- *ptr = stream;
- XSET (lispstream, Lisp_Internal_Stream, (int) ptr);
+ GCPRO1 (file);
+ lispstream = Fcons (Qnil, Qnil);
+ XSETFASTINT (XCONS (lispstream)->car, (EMACS_UINT)stream >> 16);
+ XSETFASTINT (XCONS (lispstream)->cdr, (EMACS_UINT)stream & 0xffff);
record_unwind_protect (load_unwind, lispstream);
+ record_unwind_protect (load_descriptor_unwind, load_descriptor_list);
+ specbind (Qload_file_name, found);
+ load_descriptor_list
+ = Fcons (make_number (fileno (stream)), load_descriptor_list);
load_in_progress++;
- readevalloop (Qget_file_char, stream, Feval, 0);
+ readevalloop (Qget_file_char, stream, file, Feval, 0);
unbind_to (count, Qnil);
/* Run any load-hooks for this file. */
- temp = Fassoc (str, Vafter_load_alist);
+ temp = Fassoc (file, Vafter_load_alist);
if (!NILP (temp))
Fprogn (Fcdr (temp));
UNGCPRO;
+ if (saved_doc_string)
+ free (saved_doc_string);
+ saved_doc_string = 0;
+ saved_doc_string_size = 0;
+
if (!noninteractive && NILP (nomessage))
- message ("Loading %s...done", XSTRING (str)->data);
+ message ("Loading %s...done", XSTRING (file)->data);
return Qt;
}
load_unwind (stream) /* used as unwind-protect function in load */
Lisp_Object stream;
{
- fclose (*(FILE **) XSTRING (stream));
- free (XPNTR (stream));
+ fclose ((FILE *) (XFASTINT (XCONS (stream)->car) << 16
+ | XFASTINT (XCONS (stream)->cdr)));
if (--load_in_progress < 0) load_in_progress = 0;
return Qnil;
}
+static Lisp_Object
+load_descriptor_unwind (oldlist)
+ Lisp_Object oldlist;
+{
+ load_descriptor_list = oldlist;
+ return Qnil;
+}
+
+/* Close all descriptors in use for Floads.
+ This is used when starting a subprocess. */
+
+void
+close_load_descs ()
+{
+ Lisp_Object tail;
+ for (tail = load_descriptor_list; !NILP (tail); tail = XCONS (tail)->cdr)
+ close (XFASTINT (XCONS (tail)->car));
+}
\f
static int
complete_filename_p (pathname)
Lisp_Object pathname;
{
register unsigned char *s = XSTRING (pathname)->data;
- return (*s == '/'
+ return (IS_DIRECTORY_SEP (s[0])
+ || (XSTRING (pathname)->size > 2
+ && IS_DEVICE_SEP (s[1]) && IS_DIRECTORY_SEP (s[2]))
#ifdef ALTOS
|| *s == '@'
#endif
int want_size;
register Lisp_Object filename;
struct stat st;
+ struct gcpro gcpro1;
+ GCPRO1 (str);
if (storeptr)
*storeptr = Qnil;
if (exec_only)
fd = (access (fn, X_OK) == 0) ? 1 : -1;
else
- fd = open (fn, 0, 0);
+ fd = open (fn, O_RDONLY, 0);
if (fd >= 0)
{
/* We succeeded; return this descriptor and filename. */
if (storeptr)
*storeptr = build_string (fn);
+ UNGCPRO;
return fd;
}
}
break;
nsuffix += lsuffix + 1;
}
- if (absolute) return -1;
+ if (absolute)
+ break;
}
+ UNGCPRO;
return -1;
}
\f
+/* Merge the list we've accumulated of globals from the current input source
+ into the load_history variable. The details depend on whether
+ the source has an associated file name or not. */
+
+static void
+build_load_history (stream, source)
+ FILE *stream;
+ Lisp_Object source;
+{
+ register Lisp_Object tail, prev, newelt;
+ register Lisp_Object tem, tem2;
+ register int foundit, loading;
+
+ /* Don't bother recording anything for preloaded files. */
+ if (!NILP (Vpurify_flag))
+ return;
+
+ loading = stream || !NARROWED;
+
+ tail = Vload_history;
+ prev = Qnil;
+ foundit = 0;
+ while (!NILP (tail))
+ {
+ tem = Fcar (tail);
+
+ /* Find the feature's previous assoc list... */
+ if (!NILP (Fequal (source, Fcar (tem))))
+ {
+ foundit = 1;
+
+ /* If we're loading, remove it. */
+ if (loading)
+ {
+ if (NILP (prev))
+ Vload_history = Fcdr (tail);
+ else
+ Fsetcdr (prev, Fcdr (tail));
+ }
+
+ /* Otherwise, cons on new symbols that are not already members. */
+ else
+ {
+ tem2 = Vcurrent_load_list;
+
+ while (CONSP (tem2))
+ {
+ newelt = Fcar (tem2);
+
+ if (NILP (Fmemq (newelt, tem)))
+ Fsetcar (tail, Fcons (Fcar (tem),
+ Fcons (newelt, Fcdr (tem))));
+
+ tem2 = Fcdr (tem2);
+ QUIT;
+ }
+ }
+ }
+ else
+ prev = tail;
+ tail = Fcdr (tail);
+ QUIT;
+ }
+
+ /* If we're loading, cons the new assoc onto the front of load-history,
+ the most-recently-loaded position. Also do this if we didn't find
+ an existing member for the current source. */
+ if (loading || !foundit)
+ Vload_history = Fcons (Fnreverse (Vcurrent_load_list),
+ Vload_history);
+}
+
Lisp_Object
unreadpure () /* Used as unwind-protect function in readevalloop */
{
}
static void
-readevalloop (readcharfun, stream, evalfun, printflag)
+readevalloop (readcharfun, stream, sourcename, evalfun, printflag)
Lisp_Object readcharfun;
- FILE *stream;
+ FILE *stream;
+ Lisp_Object sourcename;
Lisp_Object (*evalfun) ();
int printflag;
{
register int c;
register Lisp_Object val;
int count = specpdl_ptr - specpdl;
+ struct gcpro gcpro1;
+ struct buffer *b = 0;
+
+ if (BUFFERP (readcharfun))
+ b = XBUFFER (readcharfun);
+ else if (MARKERP (readcharfun))
+ b = XMARKER (readcharfun)->buffer;
specbind (Qstandard_input, readcharfun);
+ specbind (Qcurrent_load_list, Qnil);
+
+ GCPRO1 (sourcename);
+
+ LOADHIST_ATTACH (sourcename);
while (1)
{
+ if (b != 0 && NILP (b->name))
+ error ("Reading from killed buffer");
+
instream = stream;
c = READCHAR;
if (c == ';')
continue;
}
if (c < 0) break;
- if (c == ' ' || c == '\t' || c == '\n' || c == '\f') continue;
+
+ /* Ignore whitespace here, so we can detect eof. */
+ if (c == ' ' || c == '\t' || c == '\n' || c == '\f' || c == '\r')
+ continue;
if (!NILP (Vpurify_flag) && c == '(')
{
+ int count1 = specpdl_ptr - specpdl;
record_unwind_protect (unreadpure, Qnil);
val = read_list (-1, readcharfun);
- unbind_to (count + 1, Qnil);
+ unbind_to (count1, Qnil);
}
else
{
UNREAD (c);
- val = read0 (readcharfun);
+ if (NILP (Vload_read_function))
+ val = read0 (readcharfun);
+ else
+ val = call1 (Vload_read_function, readcharfun);
}
val = (*evalfun) (val);
}
}
+ build_load_history (stream, sourcename);
+ UNGCPRO;
+
unbind_to (count, Qnil);
}
\n\
If there is no error, point does not move. If there is an error,\n\
point remains at the end of the last character read from the buffer.")
- (bufname, printflag)
- Lisp_Object bufname, printflag;
+ (buffer, printflag)
+ Lisp_Object buffer, printflag;
{
int count = specpdl_ptr - specpdl;
Lisp_Object tem, buf;
- if (NILP (bufname))
+ if (NILP (buffer))
buf = Fcurrent_buffer ();
else
- buf = Fget_buffer (bufname);
+ buf = Fget_buffer (buffer);
if (NILP (buf))
error ("No such buffer.");
specbind (Qstandard_output, tem);
record_unwind_protect (save_excursion_restore, save_excursion_save ());
BUF_SET_PT (XBUFFER (buf), BUF_BEGV (XBUFFER (buf)));
- readevalloop (buf, 0, Feval, !NILP (printflag));
- unbind_to (count);
+ readevalloop (buf, 0, XBUFFER (buf)->filename, Feval, !NILP (printflag));
+ unbind_to (count, Qnil);
return Qnil;
}
Lisp_Object printflag;
{
int count = specpdl_ptr - specpdl;
- Lisp_Object tem;
+ Lisp_Object tem, cbuf;
+
+ cbuf = Fcurrent_buffer ()
if (NILP (printflag))
tem = Qsymbolp;
specbind (Qstandard_output, tem);
record_unwind_protect (save_excursion_restore, save_excursion_save ());
SET_PT (BEGV);
- readevalloop (Fcurrent_buffer (), 0, Feval, !NILP (printflag));
+ readevalloop (cbuf, 0, XBUFFER (cbuf)->filename, Feval, !NILP (printflag));
return unbind_to (count, Qnil);
}
#endif
\n\
If there is no error, point does not move. If there is an error,\n\
point remains at the end of the last character read from the buffer.")
- (b, e, printflag)
- Lisp_Object b, e, printflag;
+ (start, end, printflag)
+ Lisp_Object start, end, printflag;
{
int count = specpdl_ptr - specpdl;
- Lisp_Object tem;
+ Lisp_Object tem, cbuf;
+
+ cbuf = Fcurrent_buffer ();
if (NILP (printflag))
tem = Qsymbolp;
record_unwind_protect (save_excursion_restore, save_excursion_save ());
record_unwind_protect (save_restriction_restore, save_restriction_save ());
- /* This both uses b and checks its type. */
- Fgoto_char (b);
- Fnarrow_to_region (make_number (BEGV), e);
- readevalloop (Fcurrent_buffer (), 0, Feval, !NILP (printflag));
+ /* This both uses start and checks its type. */
+ Fgoto_char (start);
+ Fnarrow_to_region (make_number (BEGV), end);
+ readevalloop (cbuf, 0, XBUFFER (cbuf)->filename, Feval, !NILP (printflag));
return unbind_to (count, Qnil);
}
call it with a char as argument to push a char back)\n\
a string (takes text from string, starting at the beginning)\n\
t (read text line using minibuffer and use it).")
- (readcharfun)
- Lisp_Object readcharfun;
+ (stream)
+ Lisp_Object stream;
{
extern Lisp_Object Fread_minibuffer ();
- if (NILP (readcharfun))
- readcharfun = Vstandard_input;
- if (EQ (readcharfun, Qt))
- readcharfun = Qread_char;
+ if (NILP (stream))
+ stream = Vstandard_input;
+ if (EQ (stream, Qt))
+ stream = Qread_char;
+
+ new_backquote_flag = 0;
#ifndef standalone
- if (EQ (readcharfun, Qread_char))
+ if (EQ (stream, Qread_char))
return Fread_minibuffer (build_string ("Lisp expression: "), Qnil);
#endif
- if (XTYPE (readcharfun) == Lisp_String)
- return Fcar (Fread_from_string (readcharfun, Qnil, Qnil));
+ if (STRINGP (stream))
+ return Fcar (Fread_from_string (stream, Qnil, Qnil));
- return read0 (readcharfun);
+ return read0 (stream);
}
DEFUN ("read-from-string", Fread_from_string, Sread_from_string, 1, 3, 0,
read_from_string_index = startval;
read_from_string_limit = endval;
+ new_backquote_flag = 0;
+
tem = read0 (string);
return Fcons (tem, make_number (read_from_string_index));
}
\f
-/* Use this for recursive reads, in contexts where internal tokens are not allowed. */
-
+/* Use this for recursive reads, in contexts where internal tokens
+ are not allowed. */
static Lisp_Object
read0 (readcharfun)
Lisp_Object readcharfun;
register Lisp_Object val;
char c;
- val = read1 (readcharfun);
- if (XTYPE (val) == Lisp_Internal)
- {
- c = XINT (val);
- return Fsignal (Qinvalid_read_syntax, Fcons (make_string (&c, 1), Qnil));
- }
+ val = read1 (readcharfun, &c, 0);
+ if (c)
+ Fsignal (Qinvalid_read_syntax, Fcons (make_string (&c, 1), Qnil));
return val;
}
return '\007';
case 'b':
return '\b';
+ case 'd':
+ return 0177;
case 'e':
return 033;
case 'f':
c = READCHAR;
if (c == '\\')
c = read_escape (readcharfun);
- return c | 0200;
+ return c | meta_modifier;
+
+ case 'S':
+ c = READCHAR;
+ if (c != '-')
+ error ("Invalid escape character syntax");
+ c = READCHAR;
+ if (c == '\\')
+ c = read_escape (readcharfun);
+ return c | shift_modifier;
+
+ case 'H':
+ c = READCHAR;
+ if (c != '-')
+ error ("Invalid escape character syntax");
+ c = READCHAR;
+ if (c == '\\')
+ c = read_escape (readcharfun);
+ return c | hyper_modifier;
+
+ case 'A':
+ c = READCHAR;
+ if (c != '-')
+ error ("Invalid escape character syntax");
+ c = READCHAR;
+ if (c == '\\')
+ c = read_escape (readcharfun);
+ return c | alt_modifier;
+
+ case 's':
+ c = READCHAR;
+ if (c != '-')
+ error ("Invalid escape character syntax");
+ c = READCHAR;
+ if (c == '\\')
+ c = read_escape (readcharfun);
+ return c | super_modifier;
case 'C':
c = READCHAR;
c = READCHAR;
if (c == '\\')
c = read_escape (readcharfun);
- if (c == '?')
- return 0177;
+ if ((c & 0177) == '?')
+ return 0177 | c;
+ /* ASCII control chars are made from letters (both cases),
+ as well as the non-letters within 0100...0137. */
+ else if ((c & 0137) >= 0101 && (c & 0137) <= 0132)
+ return (c & (037 | ~0177));
+ else if ((c & 0177) >= 0100 && (c & 0177) <= 0137)
+ return (c & (037 | ~0177));
else
- return (c & (0200 | 037));
+ return c | ctrl_modifier;
case '0':
case '1':
}
}
+/* If the next token is ')' or ']' or '.', we store that character
+ in *PCH and the return value is not interesting. Else, we store
+ zero in *PCH and we read and return one lisp object.
+
+ FIRST_IN_LIST is nonzero if this is the first element of a list. */
+
static Lisp_Object
-read1 (readcharfun)
+read1 (readcharfun, pch, first_in_list)
register Lisp_Object readcharfun;
+ char *pch;
+ int first_in_list;
{
register int c;
+ *pch = 0;
retry:
case ')':
case ']':
{
- register Lisp_Object val;
- XSET (val, Lisp_Internal, c);
- return val;
+ *pch = c;
+ return Qnil;
}
case '#':
c = READCHAR;
+ if (c == '^')
+ {
+ c = READCHAR;
+ if (c == '[')
+ {
+ Lisp_Object tmp;
+ tmp = read_vector (readcharfun);
+ if (XVECTOR (tmp)->size < CHAR_TABLE_STANDARD_SLOTS
+ || XVECTOR (tmp)->size > CHAR_TABLE_STANDARD_SLOTS + 10)
+ error ("Invalid size char-table");
+ XSETCHAR_TABLE (tmp, XCHAR_TABLE (tmp));
+ return tmp;
+ }
+ Fsignal (Qinvalid_read_syntax, Fcons (make_string ("#^", 2), Qnil));
+ }
+ if (c == '&')
+ {
+ Lisp_Object length;
+ length = read1 (readcharfun, pch, first_in_list);
+ c = READCHAR;
+ if (c == '"')
+ {
+ Lisp_Object tmp, val;
+ int size_in_chars = ((XFASTINT (length) + BITS_PER_CHAR)
+ / BITS_PER_CHAR);
+
+ UNREAD (c);
+ tmp = read1 (readcharfun, pch, first_in_list);
+ if (size_in_chars != XSTRING (tmp)->size)
+ Fsignal (Qinvalid_read_syntax,
+ Fcons (make_string ("#&", 2), Qnil));
+
+ val = Fmake_bool_vector (length, Qnil);
+ bcopy (XSTRING (tmp)->data, XBOOL_VECTOR (val)->data,
+ size_in_chars);
+ return val;
+ }
+ Fsignal (Qinvalid_read_syntax, Fcons (make_string ("#&", 2), Qnil));
+ }
if (c == '[')
{
/* Accept compiled functions at read-time so that we don't have to
build them using function calls. */
- Lisp_Object tmp = read_vector (readcharfun);
- return Fmake_byte_code (XVECTOR(tmp)->size, XVECTOR (tmp)->contents);
+ Lisp_Object tmp;
+ tmp = read_vector (readcharfun);
+ return Fmake_byte_code (XVECTOR (tmp)->size,
+ XVECTOR (tmp)->contents);
+ }
+#ifdef USE_TEXT_PROPERTIES
+ if (c == '(')
+ {
+ Lisp_Object tmp;
+ struct gcpro gcpro1;
+ char ch;
+
+ /* Read the string itself. */
+ tmp = read1 (readcharfun, &ch, 0);
+ if (ch != 0 || !STRINGP (tmp))
+ Fsignal (Qinvalid_read_syntax, Fcons (make_string ("#", 1), Qnil));
+ GCPRO1 (tmp);
+ /* Read the intervals and their properties. */
+ while (1)
+ {
+ Lisp_Object beg, end, plist;
+
+ beg = read1 (readcharfun, &ch, 0);
+ if (ch == ')')
+ break;
+ if (ch == 0)
+ end = read1 (readcharfun, &ch, 0);
+ if (ch == 0)
+ plist = read1 (readcharfun, &ch, 0);
+ if (ch)
+ Fsignal (Qinvalid_read_syntax,
+ Fcons (build_string ("invalid string property list"),
+ Qnil));
+ Fset_text_properties (beg, end, plist, tmp);
+ }
+ UNGCPRO;
+ return tmp;
+ }
+#endif
+ /* #@NUMBER is used to skip NUMBER following characters.
+ That's used in .elc files to skip over doc strings
+ and function definitions. */
+ if (c == '@')
+ {
+ int i, nskip = 0;
+
+ /* Read a decimal integer. */
+ while ((c = READCHAR) >= 0
+ && c >= '0' && c <= '9')
+ {
+ nskip *= 10;
+ nskip += c - '0';
+ }
+ if (c >= 0)
+ UNREAD (c);
+
+#ifndef DOS_NT /* I don't know if filepos works right on MSDOS and Windoze. */
+ if (load_force_doc_strings && EQ (readcharfun, Qget_file_char))
+ {
+ /* If we are supposed to force doc strings into core right now,
+ record the last string that we skipped,
+ and record where in the file it comes from. */
+ if (saved_doc_string_size == 0)
+ {
+ saved_doc_string_size = nskip + 100;
+ saved_doc_string = (char *) malloc (saved_doc_string_size);
+ }
+ if (nskip > saved_doc_string_size)
+ {
+ saved_doc_string_size = nskip + 100;
+ saved_doc_string = (char *) realloc (saved_doc_string,
+ saved_doc_string_size);
+ }
+
+ saved_doc_string_position = ftell (instream);
+
+ /* Copy that many characters into saved_doc_string. */
+ for (i = 0; i < nskip && c >= 0; i++)
+ saved_doc_string[i] = c = READCHAR;
+
+ saved_doc_string_length = i;
+ }
+ else
+#endif /* not DOS_NT */
+ {
+ /* Skip that many characters. */
+ for (i = 0; i < nskip && c >= 0; i++)
+ c = READCHAR;
+ }
+ goto retry;
}
+ if (c == '$')
+ return Vload_file_name;
+ if (c == '\'')
+ return Fcons (Qfunction, Fcons (read0 (readcharfun), Qnil));
+
+
UNREAD (c);
- return Fsignal (Qinvalid_read_syntax, Fcons (make_string ("#", 1), Qnil));
+ Fsignal (Qinvalid_read_syntax, Fcons (make_string ("#", 1), Qnil));
case ';':
while ((c = READCHAR) >= 0 && c != '\n');
return Fcons (Qquote, Fcons (read0 (readcharfun), Qnil));
}
+ case '`':
+ if (first_in_list)
+ goto default_label;
+ else
+ {
+ Lisp_Object value;
+
+ new_backquote_flag = 1;
+ value = read0 (readcharfun);
+ new_backquote_flag = 0;
+
+ return Fcons (Qbackquote, Fcons (value, Qnil));
+ }
+
+ case ',':
+ if (new_backquote_flag)
+ {
+ Lisp_Object comma_type = Qnil;
+ Lisp_Object value;
+ int ch = READCHAR;
+
+ if (ch == '@')
+ comma_type = Qcomma_at;
+ else if (ch == '.')
+ comma_type = Qcomma_dot;
+ else
+ {
+ if (ch >= 0) UNREAD (ch);
+ comma_type = Qcomma;
+ }
+
+ new_backquote_flag = 0;
+ value = read0 (readcharfun);
+ new_backquote_flag = 1;
+ return Fcons (comma_type, Fcons (value, Qnil));
+ }
+ else
+ goto default_label;
+
case '?':
{
register Lisp_Object val;
if (c < 0) return Fsignal (Qend_of_file, Qnil);
if (c == '\\')
- XSET (val, Lisp_Int, read_escape (readcharfun));
+ XSETINT (val, read_escape (readcharfun));
else
- XSET (val, Lisp_Int, c);
+ XSETINT (val, c);
return val;
}
if (c == '\\')
c = read_escape (readcharfun);
/* c is -1 if \ newline has just been seen */
- if (c < 0)
+ if (c == -1)
{
if (p == read_buffer)
cancel = 1;
}
else
- *p++ = c;
+ {
+ /* Allow `\C- ' and `\C-?'. */
+ if (c == (CHAR_CTL | ' '))
+ c = 0;
+ else if (c == (CHAR_CTL | '?'))
+ c = 127;
+
+ if (c & CHAR_META)
+ /* Move the meta bit to the right place for a string. */
+ c = (c & ~CHAR_META) | 0x80;
+ if (c & ~0xff)
+ error ("Invalid modifier in string");
+ *p++ = c;
+ }
}
if (c < 0) return Fsignal (Qend_of_file, Qnil);
int next_char = READCHAR;
UNREAD (next_char);
- if (! isdigit (next_char))
+ if (! (next_char >= '0' && next_char <= '9'))
#endif
{
- register Lisp_Object val;
- XSET (val, Lisp_Internal, c);
- return val;
+ *pch = c;
+ return Qnil;
}
/* Otherwise, we fall through! Note that the atom-reading loop
try to UNREAD two characters in a row. */
}
default:
+ default_label:
if (c <= 040) goto retry;
{
register char *p = read_buffer;
+ int quoted = 0;
{
register char *end = read_buffer + read_buffer_size;
end = read_buffer + read_buffer_size;
}
if (c == '\\')
- c = READCHAR;
+ {
+ c = READCHAR;
+ quoted = 1;
+ }
*p++ = c;
c = READCHAR;
}
UNREAD (c);
}
- /* Is it an integer? */
- {
- register char *p1;
- register Lisp_Object val;
- p1 = read_buffer;
- if (*p1 == '+' || *p1 == '-') p1++;
- if (p1 != p)
- {
- while (p1 != p && (c = *p1) >= '0' && c <= '9') p1++;
- if (p1 == p)
- /* It is. */
- {
- XSET (val, Lisp_Int, atoi (read_buffer));
- return val;
- }
- }
+ if (!quoted)
+ {
+ register char *p1;
+ register Lisp_Object val;
+ p1 = read_buffer;
+ if (*p1 == '+' || *p1 == '-') p1++;
+ /* Is it an integer? */
+ if (p1 != p)
+ {
+ while (p1 != p && (c = *p1) >= '0' && c <= '9') p1++;
#ifdef LISP_FLOAT_TYPE
- if (isfloat_string (read_buffer))
- return make_float (atof (read_buffer));
+ /* Integers can have trailing decimal points. */
+ if (p1 > read_buffer && p1 < p && *p1 == '.') p1++;
#endif
- }
+ if (p1 == p)
+ /* It is an integer. */
+ {
+#ifdef LISP_FLOAT_TYPE
+ if (p1[-1] == '.')
+ p1[-1] = '\0';
+#endif
+ if (sizeof (int) == sizeof (EMACS_INT))
+ XSETINT (val, atoi (read_buffer));
+ else if (sizeof (long) == sizeof (EMACS_INT))
+ XSETINT (val, atol (read_buffer));
+ else
+ abort ();
+ return val;
+ }
+ }
+#ifdef LISP_FLOAT_TYPE
+ if (isfloat_string (read_buffer))
+ return make_float (atof (read_buffer));
+#endif
+ }
return intern (read_buffer);
}
if (*cp == '+' || *cp == '-')
cp++;
- if (isdigit(*cp))
+ if (*cp >= '0' && *cp <= '9')
{
state |= LEAD_INT;
- while (isdigit (*cp))
- cp ++;
+ while (*cp >= '0' && *cp <= '9')
+ cp++;
}
if (*cp == '.')
{
state |= DOT_CHAR;
cp++;
}
- if (isdigit(*cp))
+ if (*cp >= '0' && *cp <= '9')
{
state |= TRAIL_INT;
- while (isdigit (*cp))
+ while (*cp >= '0' && *cp <= '9')
cp++;
}
if (*cp == 'e')
{
state |= E_CHAR;
cp++;
+ if (*cp == '+' || *cp == '-')
+ cp++;
}
- if ((*cp == '+') || (*cp == '-'))
- cp++;
- if (isdigit (*cp))
+ if (*cp >= '0' && *cp <= '9')
{
state |= EXP_INT;
- while (isdigit (*cp))
+ while (*cp >= '0' && *cp <= '9')
cp++;
}
- return (*cp == 0
+ return (((*cp == 0) || (*cp == ' ') || (*cp == '\t') || (*cp == '\n') || (*cp == '\r') || (*cp == '\f'))
&& (state == (LEAD_INT|DOT_CHAR|TRAIL_INT)
|| state == (DOT_CHAR|TRAIL_INT)
|| state == (LEAD_INT|E_CHAR|EXP_INT)
Lisp_Object val, tail;
register Lisp_Object elt, tem;
struct gcpro gcpro1, gcpro2;
+ /* 0 is the normal case.
+ 1 means this list is a doc reference; replace it with the number 0.
+ 2 means this list is a doc reference; replace it with the doc string. */
+ int doc_reference = 0;
+
+ /* Initialize this to 1 if we are reading a list. */
+ int first_in_list = flag <= 0;
val = Qnil;
tail = Qnil;
while (1)
{
+ char ch;
GCPRO2 (val, tail);
- elt = read1 (readcharfun);
+ elt = read1 (readcharfun, &ch, first_in_list);
UNGCPRO;
- if (XTYPE (elt) == Lisp_Internal)
+
+ first_in_list = 0;
+
+ /* While building, if the list starts with #$, treat it specially. */
+ if (EQ (elt, Vload_file_name)
+ && !NILP (Vpurify_flag))
+ {
+ if (NILP (Vdoc_file_name))
+ /* We have not yet called Snarf-documentation, so assume
+ this file is described in the DOC-MM.NN file
+ and Snarf-documentation will fill in the right value later.
+ For now, replace the whole list with 0. */
+ doc_reference = 1;
+ else
+ /* We have already called Snarf-documentation, so make a relative
+ file name for this file, so it can be found properly
+ in the installed Lisp directory.
+ We don't use Fexpand_file_name because that would make
+ the directory absolute now. */
+ elt = concat2 (build_string ("../lisp/"),
+ Ffile_name_nondirectory (elt));
+ }
+ else if (EQ (elt, Vload_file_name)
+ && load_force_doc_strings)
+ doc_reference = 2;
+
+ if (ch)
{
if (flag > 0)
{
- if (XINT (elt) == ']')
+ if (ch == ']')
return val;
- return Fsignal (Qinvalid_read_syntax, Fcons (make_string (") or . in a vector", 18), Qnil));
+ Fsignal (Qinvalid_read_syntax,
+ Fcons (make_string (") or . in a vector", 18), Qnil));
}
- if (XINT (elt) == ')')
+ if (ch == ')')
return val;
- if (XINT (elt) == '.')
+ if (ch == '.')
{
GCPRO2 (val, tail);
if (!NILP (tail))
XCONS (tail)->cdr = read0 (readcharfun);
else
val = read0 (readcharfun);
- elt = read1 (readcharfun);
+ read1 (readcharfun, &ch, 0);
UNGCPRO;
- if (XTYPE (elt) == Lisp_Internal && XINT (elt) == ')')
- return val;
+ if (ch == ')')
+ {
+ if (doc_reference == 1)
+ return make_number (0);
+ if (doc_reference == 2)
+ {
+ /* Get a doc string from the file we are loading.
+ If it's in saved_doc_string, get it from there. */
+ int pos = XINT (XCONS (val)->cdr);
+ if (pos >= saved_doc_string_position
+ && pos < (saved_doc_string_position
+ + saved_doc_string_length))
+ {
+ int start = pos - saved_doc_string_position;
+ int from, to;
+
+ /* Process quoting with ^A,
+ and find the end of the string,
+ which is marked with ^_ (037). */
+ for (from = start, to = start;
+ saved_doc_string[from] != 037;)
+ {
+ int c = saved_doc_string[from++];
+ if (c == 1)
+ {
+ c = saved_doc_string[from++];
+ if (c == 1)
+ saved_doc_string[to++] = c;
+ else if (c == '0')
+ saved_doc_string[to++] = 0;
+ else if (c == '_')
+ saved_doc_string[to++] = 037;
+ }
+ else
+ saved_doc_string[to++] = c;
+ }
+
+ return make_string (saved_doc_string + start,
+ to - start);
+ }
+ else
+ return read_doc_string (val);
+ }
+
+ return val;
+ }
return Fsignal (Qinvalid_read_syntax, Fcons (make_string (". in wrong context", 18), Qnil));
}
return Fsignal (Qinvalid_read_syntax, Fcons (make_string ("] in a list", 11), Qnil));
Lisp_Object Vobarray;
Lisp_Object initial_obarray;
+/* oblookup stores the bucket number here, for the sake of Funintern. */
+
+int oblookup_last_bucket_number;
+
+static int hash_string ();
+Lisp_Object oblookup ();
+
+/* Get an error if OBARRAY is not an obarray.
+ If it is one, return it. */
+
Lisp_Object
check_obarray (obarray)
Lisp_Object obarray;
{
- while (XTYPE (obarray) != Lisp_Vector || XVECTOR (obarray)->size == 0)
+ while (!VECTORP (obarray) || XVECTOR (obarray)->size == 0)
{
/* If Vobarray is now invalid, force it to be valid. */
if (EQ (Vobarray, obarray)) Vobarray = initial_obarray;
return obarray;
}
-static int hash_string ();
-Lisp_Object oblookup ();
+/* Intern the C string STR: return a symbol with that name,
+ interned in the current obarray. */
Lisp_Object
intern (str)
{
Lisp_Object tem;
int len = strlen (str);
- Lisp_Object obarray = Vobarray;
+ Lisp_Object obarray;
- if (XTYPE (obarray) != Lisp_Vector || XVECTOR (obarray)->size == 0)
+ obarray = Vobarray;
+ if (!VECTORP (obarray) || XVECTOR (obarray)->size == 0)
obarray = check_obarray (obarray);
tem = oblookup (obarray, str, len);
- if (XTYPE (tem) == Lisp_Symbol)
+ if (SYMBOLP (tem))
return tem;
return Fintern ((!NILP (Vpurify_flag)
? make_pure_string (str, len)
: make_string (str, len)),
obarray);
}
-
+\f
DEFUN ("intern", Fintern, Sintern, 1, 2, 0,
"Return the canonical symbol whose name is STRING.\n\
If there is none, one is created by this function and returned.\n\
A second optional argument specifies the obarray to use;\n\
it defaults to the value of `obarray'.")
- (str, obarray)
- Lisp_Object str, obarray;
+ (string, obarray)
+ Lisp_Object string, obarray;
{
register Lisp_Object tem, sym, *ptr;
if (NILP (obarray)) obarray = Vobarray;
obarray = check_obarray (obarray);
- CHECK_STRING (str, 0);
+ CHECK_STRING (string, 0);
- tem = oblookup (obarray, XSTRING (str)->data, XSTRING (str)->size);
- if (XTYPE (tem) != Lisp_Int)
+ tem = oblookup (obarray, XSTRING (string)->data, XSTRING (string)->size);
+ if (!INTEGERP (tem))
return tem;
if (!NILP (Vpurify_flag))
- str = Fpurecopy (str);
- sym = Fmake_symbol (str);
+ string = Fpurecopy (string);
+ sym = Fmake_symbol (string);
ptr = &XVECTOR (obarray)->contents[XINT (tem)];
- if (XTYPE (*ptr) == Lisp_Symbol)
+ if (SYMBOLP (*ptr))
XSYMBOL (sym)->next = XSYMBOL (*ptr);
else
XSYMBOL (sym)->next = 0;
"Return the canonical symbol whose name is STRING, or nil if none exists.\n\
A second optional argument specifies the obarray to use;\n\
it defaults to the value of `obarray'.")
- (str, obarray)
- Lisp_Object str, obarray;
+ (string, obarray)
+ Lisp_Object string, obarray;
{
register Lisp_Object tem;
if (NILP (obarray)) obarray = Vobarray;
obarray = check_obarray (obarray);
- CHECK_STRING (str, 0);
+ CHECK_STRING (string, 0);
- tem = oblookup (obarray, XSTRING (str)->data, XSTRING (str)->size);
- if (XTYPE (tem) != Lisp_Int)
+ tem = oblookup (obarray, XSTRING (string)->data, XSTRING (string)->size);
+ if (!INTEGERP (tem))
return tem;
return Qnil;
}
+\f
+DEFUN ("unintern", Funintern, Sunintern, 1, 2, 0,
+ "Delete the symbol named NAME, if any, from OBARRAY.\n\
+The value is t if a symbol was found and deleted, nil otherwise.\n\
+NAME may be a string or a symbol. If it is a symbol, that symbol\n\
+is deleted, if it belongs to OBARRAY--no other symbol is deleted.\n\
+OBARRAY defaults to the value of the variable `obarray'.")
+ (name, obarray)
+ Lisp_Object name, obarray;
+{
+ register Lisp_Object string, tem;
+ int hash;
+
+ if (NILP (obarray)) obarray = Vobarray;
+ obarray = check_obarray (obarray);
+
+ if (SYMBOLP (name))
+ XSETSTRING (string, XSYMBOL (name)->name);
+ else
+ {
+ CHECK_STRING (name, 0);
+ string = name;
+ }
+
+ tem = oblookup (obarray, XSTRING (string)->data, XSTRING (string)->size);
+ if (INTEGERP (tem))
+ return Qnil;
+ /* If arg was a symbol, don't delete anything but that symbol itself. */
+ if (SYMBOLP (name) && !EQ (name, tem))
+ return Qnil;
+
+ hash = oblookup_last_bucket_number;
+
+ if (EQ (XVECTOR (obarray)->contents[hash], tem))
+ {
+ if (XSYMBOL (tem)->next)
+ XSETSYMBOL (XVECTOR (obarray)->contents[hash], XSYMBOL (tem)->next);
+ else
+ XSETINT (XVECTOR (obarray)->contents[hash], 0);
+ }
+ else
+ {
+ Lisp_Object tail, following;
+
+ for (tail = XVECTOR (obarray)->contents[hash];
+ XSYMBOL (tail)->next;
+ tail = following)
+ {
+ XSETSYMBOL (following, XSYMBOL (tail)->next);
+ if (EQ (following, tem))
+ {
+ XSYMBOL (tail)->next = XSYMBOL (following)->next;
+ break;
+ }
+ }
+ }
+
+ return Qt;
+}
+\f
+/* Return the symbol in OBARRAY whose names matches the string
+ of SIZE characters at PTR. If there is no such symbol in OBARRAY,
+ return nil.
+
+ Also store the bucket number in oblookup_last_bucket_number. */
Lisp_Object
oblookup (obarray, ptr, size)
register char *ptr;
register int size;
{
- int hash, obsize;
+ int hash;
+ int obsize;
register Lisp_Object tail;
Lisp_Object bucket, tem;
- if (XTYPE (obarray) != Lisp_Vector ||
- (obsize = XVECTOR (obarray)->size) == 0)
+ if (!VECTORP (obarray)
+ || (obsize = XVECTOR (obarray)->size) == 0)
{
obarray = check_obarray (obarray);
obsize = XVECTOR (obarray)->size;
}
+ /* This is sometimes needed in the middle of GC. */
+ obsize &= ~ARRAY_MARK_FLAG;
/* Combining next two lines breaks VMS C 2.3. */
hash = hash_string (ptr, size);
hash %= obsize;
bucket = XVECTOR (obarray)->contents[hash];
+ oblookup_last_bucket_number = hash;
if (XFASTINT (bucket) == 0)
;
- else if (XTYPE (bucket) != Lisp_Symbol)
+ else if (!SYMBOLP (bucket))
error ("Bad data in guts of obarray"); /* Like CADR error message */
- else for (tail = bucket; ; XSET (tail, Lisp_Symbol, XSYMBOL (tail)->next))
+ else
+ for (tail = bucket; ; XSETSYMBOL (tail, XSYMBOL (tail)->next))
{
- if (XSYMBOL (tail)->name->size == size &&
- !bcmp (XSYMBOL (tail)->name->data, ptr, size))
+ if (XSYMBOL (tail)->name->size == size
+ && !bcmp (XSYMBOL (tail)->name->data, ptr, size))
return tail;
else if (XSYMBOL (tail)->next == 0)
break;
}
- XSET (tem, Lisp_Int, hash);
+ XSETINT (tem, hash);
return tem;
}
}
return hash & 07777777777;
}
-
+\f
void
map_obarray (obarray, fn, arg)
Lisp_Object obarray;
(*fn) (tail, arg);
if (XSYMBOL (tail)->next == 0)
break;
- XSET (tail, Lisp_Symbol, XSYMBOL (tail)->next);
+ XSETSYMBOL (tail, XSYMBOL (tail)->next);
}
}
}
return Qnil;
}
-#define OBARRAY_SIZE 509
+#define OBARRAY_SIZE 1511
void
init_obarray ()
int hash;
Lisp_Object *tem;
- XFASTINT (oblength) = OBARRAY_SIZE;
+ XSETFASTINT (oblength, OBARRAY_SIZE);
Qnil = Fmake_symbol (make_pure_string ("nil", 3));
Vobarray = Fmake_vector (oblength, make_number (0));
{
Lisp_Object sym;
sym = intern (sname->symbol_name);
- XSET (XSYMBOL (sym)->function, Lisp_Subr, sname);
+ XSETSUBR (XSYMBOL (sym)->function, sname);
}
#ifdef NOTDEF /* use fset in subr.el now */
{
Lisp_Object sym;
sym = intern (string);
- XSET (XSYMBOL (sym)->function, Lisp_Subr, sname);
+ XSETSUBR (XSYMBOL (sym)->function, sname);
}
#endif /* NOTDEF */
-/* New replacement for DefIntVar; it ignores the doc string argument
- on the assumption that make-docfile will handle that. */
/* Define an "integer variable"; a symbol whose value is forwarded
- to a C variable of type int. Sample call: */
- /* DEFVARINT ("indent-tabs-mode", &indent_tabs_mode, "Documentation"); */
-
+ to a C variable of type int. Sample call: */
+ /* DEFVAR_INT ("indent-tabs-mode", &indent_tabs_mode, "Documentation"); */
void
-defvar_int (namestring, address, doc)
+defvar_int (namestring, address)
char *namestring;
int *address;
- char *doc;
{
- Lisp_Object sym;
+ Lisp_Object sym, val;
sym = intern (namestring);
- XSET (XSYMBOL (sym)->value, Lisp_Intfwd, address);
+ val = allocate_misc ();
+ XMISCTYPE (val) = Lisp_Misc_Intfwd;
+ XINTFWD (val)->intvar = address;
+ XSYMBOL (sym)->value = val;
}
/* Similar but define a variable whose value is T if address contains 1,
- NIL if address contains 0 */
-
+ NIL if address contains 0 */
void
-defvar_bool (namestring, address, doc)
+defvar_bool (namestring, address)
char *namestring;
int *address;
- char *doc;
{
- Lisp_Object sym;
+ Lisp_Object sym, val;
sym = intern (namestring);
- XSET (XSYMBOL (sym)->value, Lisp_Boolfwd, address);
+ val = allocate_misc ();
+ XMISCTYPE (val) = Lisp_Misc_Boolfwd;
+ XBOOLFWD (val)->boolvar = address;
+ XSYMBOL (sym)->value = val;
}
-/* Similar but define a variable whose value is the Lisp Object stored at address. */
-
+/* Similar but define a variable whose value is the Lisp Object stored
+ at address. Two versions: with and without gc-marking of the C
+ variable. The nopro version is used when that variable will be
+ gc-marked for some other reason, since marking the same slot twice
+ can cause trouble with strings. */
void
-defvar_lisp (namestring, address, doc)
+defvar_lisp_nopro (namestring, address)
char *namestring;
Lisp_Object *address;
- char *doc;
{
- Lisp_Object sym;
+ Lisp_Object sym, val;
sym = intern (namestring);
- XSET (XSYMBOL (sym)->value, Lisp_Objfwd, address);
- staticpro (address);
+ val = allocate_misc ();
+ XMISCTYPE (val) = Lisp_Misc_Objfwd;
+ XOBJFWD (val)->objvar = address;
+ XSYMBOL (sym)->value = val;
}
-/* Similar but don't request gc-marking of the C variable.
- Used when that variable will be gc-marked for some other reason,
- since marking the same slot twice can cause trouble with strings. */
-
void
-defvar_lisp_nopro (namestring, address, doc)
+defvar_lisp (namestring, address)
char *namestring;
Lisp_Object *address;
- char *doc;
{
- Lisp_Object sym;
- sym = intern (namestring);
- XSET (XSYMBOL (sym)->value, Lisp_Objfwd, address);
+ defvar_lisp_nopro (namestring, address);
+ staticpro (address);
}
#ifndef standalone
/* Similar but define a variable whose value is the Lisp Object stored in
- the current buffer. address is the address of the slot in the buffer that is current now. */
+ the current buffer. address is the address of the slot in the buffer
+ that is current now. */
void
defvar_per_buffer (namestring, address, type, doc)
Lisp_Object type;
char *doc;
{
- Lisp_Object sym;
+ Lisp_Object sym, val;
int offset;
extern struct buffer buffer_local_symbols;
sym = intern (namestring);
+ val = allocate_misc ();
offset = (char *)address - (char *)current_buffer;
- XSET (XSYMBOL (sym)->value, Lisp_Buffer_Objfwd,
- (Lisp_Object *) offset);
+ XMISCTYPE (val) = Lisp_Misc_Buffer_Objfwd;
+ XBUFFER_OBJFWD (val)->offset = offset;
+ XSYMBOL (sym)->value = val;
*(Lisp_Object *)(offset + (char *)&buffer_local_symbols) = sym;
*(Lisp_Object *)(offset + (char *)&buffer_local_types) = type;
- if (*(int *)(offset + (char *)&buffer_local_flags) == 0)
+ if (XINT (*(Lisp_Object *)(offset + (char *)&buffer_local_flags)) == 0)
/* Did a DEFVAR_PER_BUFFER without initializing the corresponding
slot of buffer_local_flags */
abort ();
}
#endif /* standalone */
+
+/* Similar but define a variable whose value is the Lisp Object stored
+ at a particular offset in the current kboard object. */
+
+void
+defvar_kboard (namestring, offset)
+ char *namestring;
+ int offset;
+{
+ Lisp_Object sym, val;
+ sym = intern (namestring);
+ val = allocate_misc ();
+ XMISCTYPE (val) = Lisp_Misc_Kboard_Objfwd;
+ XKBOARD_OBJFWD (val)->offset = offset;
+ XSYMBOL (sym)->value = val;
+}
\f
init_lread ()
{
char *normal;
+ int turn_off_warning = 0;
/* Compute the default load-path. */
#ifdef CANNOT_DUMP
Lisp_Object dump_path;
dump_path = decode_env_path (0, PATH_DUMPLOADSEARCH);
+
+ Vsource_directory = Fexpand_file_name (build_string ("../"),
+ Fcar (dump_path));
+
if (! NILP (Fequal (dump_path, Vload_path)))
- Vload_path = decode_env_path (0, normal);
+ {
+ Vload_path = decode_env_path (0, normal);
+ if (!NILP (Vinstallation_directory))
+ {
+ /* Add to the path the lisp subdir of the
+ installation dir, if it exists. */
+ Lisp_Object tem, tem1;
+ tem = Fexpand_file_name (build_string ("lisp"),
+ Vinstallation_directory);
+ tem1 = Ffile_exists_p (tem);
+ if (!NILP (tem1))
+ {
+ if (NILP (Fmember (tem, Vload_path)))
+ {
+ turn_off_warning = 1;
+ Vload_path = nconc2 (Vload_path, Fcons (tem, Qnil));
+ }
+ }
+ else
+ /* That dir doesn't exist, so add the build-time
+ Lisp dirs instead. */
+ Vload_path = nconc2 (Vload_path, dump_path);
+
+ /* Add site-list under the installation dir, if it exists. */
+ tem = Fexpand_file_name (build_string ("site-lisp"),
+ Vinstallation_directory);
+ tem1 = Ffile_exists_p (tem);
+ if (!NILP (tem1))
+ {
+ if (NILP (Fmember (tem, Vload_path)))
+ Vload_path = nconc2 (Vload_path, Fcons (tem, Qnil));
+ }
+ }
+ }
}
else
- Vload_path = decode_env_path (0, normal);
+ /* ../lisp refers to the build directory.
+ NORMAL refers to the lisp dir in the source directory. */
+ Vload_path = Fcons (build_string ("../lisp"),
+ decode_env_path (0, normal));
#endif
+#ifndef WINDOWSNT
+ /* When Emacs is invoked over network shares on NT, PATH_LOADSEARCH is
+ almost never correct, thereby causing a warning to be printed out that
+ confuses users. Since PATH_LOADSEARCH is always overridden by the
+ EMACSLOADPATH environment variable below, disable the warning on NT. */
+
/* Warn if dirs in the *standard* path don't exist. */
- {
- Lisp_Object path_tail;
+ if (!turn_off_warning)
+ {
+ Lisp_Object path_tail;
- for (path_tail = Vload_path;
- !NILP (path_tail);
- path_tail = XCONS (path_tail)->cdr)
- {
- Lisp_Object dirfile;
- dirfile = Fcar (path_tail);
- if (XTYPE (dirfile) == Lisp_String)
- {
- dirfile = Fdirectory_file_name (dirfile);
- if (access (XSTRING (dirfile)->data, 0) < 0)
- printf ("Warning: lisp library (%s) does not exist.\n",
- XSTRING (Fcar (path_tail))->data);
- }
- }
- }
+ for (path_tail = Vload_path;
+ !NILP (path_tail);
+ path_tail = XCONS (path_tail)->cdr)
+ {
+ Lisp_Object dirfile;
+ dirfile = Fcar (path_tail);
+ if (STRINGP (dirfile))
+ {
+ dirfile = Fdirectory_file_name (dirfile);
+ if (access (XSTRING (dirfile)->data, 0) < 0)
+ fprintf (stderr,
+ "Warning: Lisp directory `%s' does not exist.\n",
+ XSTRING (Fcar (path_tail))->data);
+ }
+ }
+ }
+#endif /* WINDOWSNT */
/* If the EMACSLOADPATH environment variable is set, use its value.
This doesn't apply if we're dumping. */
+#ifndef CANNOT_DUMP
if (NILP (Vpurify_flag)
&& egetenv ("EMACSLOADPATH"))
+#endif
Vload_path = decode_env_path ("EMACSLOADPATH", normal);
Vvalues = Qnil;
load_in_progress = 0;
+
+ load_descriptor_list = Qnil;
}
void
defsubr (&Sread_from_string);
defsubr (&Sintern);
defsubr (&Sintern_soft);
+ defsubr (&Sunintern);
defsubr (&Sload);
defsubr (&Seval_buffer);
defsubr (&Seval_region);
"*List of directories to search for files to load.\n\
Each element is a string (directory name) or nil (try default directory).\n\
Initialized based on EMACSLOADPATH environment variable, if any,\n\
-otherwise to default specified in by file `paths.h' when Emacs was built.");
+otherwise to default specified by file `paths.h' when Emacs was built.");
DEFVAR_BOOL ("load-in-progress", &load_in_progress,
"Non-nil iff inside of `load'.");
but does prevent execution of the rest of the FORMS.");
Vafter_load_alist = Qnil;
+ DEFVAR_LISP ("load-history", &Vload_history,
+ "Alist mapping source file names to symbols and features.\n\
+Each alist element is a list that starts with a file name,\n\
+except for one element (optional) that starts with nil and describes\n\
+definitions evaluated from buffers not visiting files.\n\
+The remaining elements of each list are symbols defined as functions\n\
+or variables, and cons cells `(provide . FEATURE)' and `(require . FEATURE)'.");
+ Vload_history = Qnil;
+
+ DEFVAR_LISP ("load-file-name", &Vload_file_name,
+ "Full name of file being loaded by `load'.");
+ Vload_file_name = Qnil;
+
+ DEFVAR_LISP ("current-load-list", &Vcurrent_load_list,
+ "Used for internal purposes by `load'.");
+ Vcurrent_load_list = Qnil;
+
+ DEFVAR_LISP ("load-read-function", &Vload_read_function,
+ "Function used by `load' and `eval-region' for reading expressions.\n\
+The default is nil, which means use the function `read'.");
+ Vload_read_function = Qnil;
+
+ DEFVAR_BOOL ("load-force-doc-strings", &load_force_doc_strings,
+ "Non-nil means `load' should force-load all dynamic doc strings.\n\
+This is useful when the file being loaded is a temporary copy.");
+ load_force_doc_strings = 0;
+
+ DEFVAR_LISP ("source-directory", &Vsource_directory,
+ "Directory in which Emacs sources were found when Emacs was built.\n\
+You cannot count on them to still be there!");
+ Vsource_directory = Qnil;
+ load_descriptor_list = Qnil;
+ staticpro (&load_descriptor_list);
+
+ Qcurrent_load_list = intern ("current-load-list");
+ staticpro (&Qcurrent_load_list);
+
Qstandard_input = intern ("standard-input");
staticpro (&Qstandard_input);
Qget_file_char = intern ("get-file-char");
staticpro (&Qget_file_char);
+
+ Qbackquote = intern ("`");
+ staticpro (&Qbackquote);
+ Qcomma = intern (",");
+ staticpro (&Qcomma);
+ Qcomma_at = intern (",@");
+ staticpro (&Qcomma_at);
+ Qcomma_dot = intern (",.");
+ staticpro (&Qcomma_dot);
+
+ Qascii_character = intern ("ascii-character");
+ staticpro (&Qascii_character);
+
+ Qfunction = intern ("function");
+ staticpro (&Qfunction);
+
+ Qload = intern ("load");
+ staticpro (&Qload);
+
+ Qload_file_name = intern ("load-file-name");
+ staticpro (&Qload_file_name);
}
HCoop / bpt / emacs.git / blobdiff