#include <config.h>
#include <stdio.h>
#include <sys/types.h>
#include <sys/stat.h>
#include <sys/file.h>
#include <errno.h>
#include "lisp.h"
#include "intervals.h"
#include "buffer.h"
#include "charset.h"
#include <epaths.h>
#include "commands.h"
#include "keyboard.h"
#include "termhooks.h"
#ifdef lint
#include <sys/inode.h>
#endif
#ifdef MSDOS
#if __DJGPP__ < 2
#include <unistd.h>
#endif
#include "msdos.h"
#endif
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif
#ifndef X_OK
#define X_OK 01
#endif
#include <math.h>
#ifdef HAVE_SETLOCALE
#include <locale.h>
#endif
#ifndef O_RDONLY
#define O_RDONLY 0
#endif
#ifdef HAVE_FSEEKO
#define file_offset off_t
#define file_tell ftello
#else
#define file_offset long
#define file_tell ftell
#endif
#ifndef USE_CRT_DLL
extern int errno;
#endif
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;
Lisp_Object Qinhibit_file_name_operation;
extern Lisp_Object Qevent_symbol_element_mask;
extern Lisp_Object Qfile_exists_p;
int load_in_progress;
Lisp_Object Vsource_directory;
Lisp_Object Vload_path;
Lisp_Object Vuser_init_file;
Lisp_Object Vload_history;
Lisp_Object Vcurrent_load_list;
Lisp_Object Vpreloaded_file_list;
Lisp_Object Vload_file_name;
Lisp_Object Vload_read_function;
Lisp_Object read_objects;
static int load_force_doc_strings;
static int load_convert_to_unibyte;
Lisp_Object Vload_source_file_function;
Lisp_Object Vbyte_boolean_vars;
static Lisp_Object load_descriptor_list;
static FILE *instream;
static int read_pure;
static int read_from_string_index;
static int read_from_string_index_byte;
static int read_from_string_limit;
static int readchar_backlog;
static char *saved_doc_string;
static int saved_doc_string_size;
static int saved_doc_string_length;
static file_offset saved_doc_string_position;
static char *prev_saved_doc_string;
static int prev_saved_doc_string_size;
static int prev_saved_doc_string_length;
static file_offset prev_saved_doc_string_position;
static int new_backquote_flag;
static Lisp_Object Vloads_in_progress;
Lisp_Object Vrecursive_load_depth_limit;
int load_dangerous_libraries;
static Lisp_Object Vbytecomp_version_regexp;
static void to_multibyte P_ ((char **, char **, int *));
static void readevalloop P_ ((Lisp_Object, FILE*, Lisp_Object,
Lisp_Object (*) (), int,
Lisp_Object, Lisp_Object));
static Lisp_Object load_unwind P_ ((Lisp_Object));
static Lisp_Object load_descriptor_unwind P_ ((Lisp_Object));
#define READCHAR readchar (readcharfun)
#define UNREAD(c) unreadchar (readcharfun, c)
static int
readchar (readcharfun)
Lisp_Object readcharfun;
{
Lisp_Object tem;
register int c;
if (BUFFERP (readcharfun))
{
register struct buffer *inbuffer = XBUFFER (readcharfun);
int pt_byte = BUF_PT_BYTE (inbuffer);
int orig_pt_byte = pt_byte;
if (readchar_backlog > 0)
return *(BUF_BYTE_ADDRESS (inbuffer, BUF_PT_BYTE (inbuffer) - 1)
- --readchar_backlog);
if (pt_byte >= BUF_ZV_BYTE (inbuffer))
return -1;
readchar_backlog = -1;
if (! NILP (inbuffer->enable_multibyte_characters))
{
unsigned char *p = BUF_BYTE_ADDRESS (inbuffer, pt_byte);
BUF_INC_POS (inbuffer, pt_byte);
c = STRING_CHAR (p, pt_byte - orig_pt_byte);
}
else
{
c = BUF_FETCH_BYTE (inbuffer, pt_byte);
pt_byte++;
}
SET_BUF_PT_BOTH (inbuffer, BUF_PT (inbuffer) + 1, pt_byte);
return c;
}
if (MARKERP (readcharfun))
{
register struct buffer *inbuffer = XMARKER (readcharfun)->buffer;
int bytepos = marker_byte_position (readcharfun);
int orig_bytepos = bytepos;
if (readchar_backlog > 0)
return *(BUF_BYTE_ADDRESS (inbuffer, XMARKER (readcharfun)->bytepos - 1)
- --readchar_backlog);
if (bytepos >= BUF_ZV_BYTE (inbuffer))
return -1;
readchar_backlog = -1;
if (! NILP (inbuffer->enable_multibyte_characters))
{
unsigned char *p = BUF_BYTE_ADDRESS (inbuffer, bytepos);
BUF_INC_POS (inbuffer, bytepos);
c = STRING_CHAR (p, bytepos - orig_bytepos);
}
else
{
c = BUF_FETCH_BYTE (inbuffer, bytepos);
bytepos++;
}
XMARKER (readcharfun)->bytepos = bytepos;
XMARKER (readcharfun)->charpos++;
return c;
}
if (EQ (readcharfun, Qlambda))
return read_bytecode_char (0);
if (EQ (readcharfun, Qget_file_char))
{
c = getc (instream);
#ifdef EINTR
while (c == EOF && ferror (instream) && errno == EINTR)
{
clearerr (instream);
c = getc (instream);
}
#endif
return c;
}
if (STRINGP (readcharfun))
{
if (read_from_string_index >= read_from_string_limit)
c = -1;
else
FETCH_STRING_CHAR_ADVANCE (c, readcharfun,
read_from_string_index,
read_from_string_index_byte);
return c;
}
tem = call0 (readcharfun);
if (NILP (tem))
return -1;
return XINT (tem);
}
static void
unreadchar (readcharfun, c)
Lisp_Object readcharfun;
int c;
{
if (c == -1)
;
else if (BUFFERP (readcharfun))
{
struct buffer *b = XBUFFER (readcharfun);
int bytepos = BUF_PT_BYTE (b);
if (readchar_backlog >= 0)
readchar_backlog++;
else
{
BUF_PT (b)--;
if (! NILP (b->enable_multibyte_characters))
BUF_DEC_POS (b, bytepos);
else
bytepos--;
BUF_PT_BYTE (b) = bytepos;
}
}
else if (MARKERP (readcharfun))
{
struct buffer *b = XMARKER (readcharfun)->buffer;
int bytepos = XMARKER (readcharfun)->bytepos;
if (readchar_backlog >= 0)
readchar_backlog++;
else
{
XMARKER (readcharfun)->charpos--;
if (! NILP (b->enable_multibyte_characters))
BUF_DEC_POS (b, bytepos);
else
bytepos--;
XMARKER (readcharfun)->bytepos = bytepos;
}
}
else if (STRINGP (readcharfun))
{
read_from_string_index--;
read_from_string_index_byte
= string_char_to_byte (readcharfun, read_from_string_index);
}
else if (EQ (readcharfun, Qlambda))
read_bytecode_char (1);
else if (EQ (readcharfun, Qget_file_char))
ungetc (c, instream);
else
call1 (readcharfun, make_number (c));
}
static Lisp_Object read0 (), read1 (), read_list (), read_vector ();
static int read_multibyte ();
static Lisp_Object substitute_object_recurse ();
static void substitute_object_in_subtree (), substitute_in_interval ();
extern Lisp_Object read_char ();
Lisp_Object
read_filtered_event (no_switch_frame, ascii_required, error_nonascii,
input_method)
int no_switch_frame, ascii_required, error_nonascii, input_method;
{
register Lisp_Object val, delayed_switch_frame;
#ifdef HAVE_WINDOW_SYSTEM
if (display_hourglass_p)
cancel_hourglass ();
#endif
delayed_switch_frame = Qnil;
retry:
val = read_char (0, 0, 0,
(input_method ? Qnil : Qt),
0);
if (BUFFERP (val))
goto retry;
if (no_switch_frame
&& EVENT_HAS_PARAMETERS (val)
&& EQ (EVENT_HEAD (val), Qswitch_frame))
{
delayed_switch_frame = val;
goto retry;
}
if (ascii_required)
{
if (SYMBOLP (val))
{
Lisp_Object tem, tem1;
tem = Fget (val, Qevent_symbol_element_mask);
if (!NILP (tem))
{
tem1 = Fget (Fcar (tem), Qascii_character);
if (!NILP (tem1))
XSETFASTINT (val, XINT (tem1) | XINT (Fcar (Fcdr (tem))));
}
}
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;
#ifdef HAVE_WINDOW_SYSTEM
if (display_hourglass_p)
start_hourglass ();
#endif
return val;
}
DEFUN ("read-char", Fread_char, Sread_char, 0, 2, 0,
"Read a character from the command input (keyboard or macro).\n\
It is returned as a number.\n\
If the user generates an event which is not a character (i.e. a mouse\n\
click or function key event), `read-char' signals an error. As an\n\
exception, switch-frame events are put off until non-ASCII events can\n\
be read.\n\
If you want to read non-character events, or ignore them, call\n\
`read-event' or `read-char-exclusive' instead.\n\
\n\
If the optional argument PROMPT is non-nil, display that as a prompt.\n\
If the optional argument INHERIT-INPUT-METHOD is non-nil and some\n\
input method is turned on in the current buffer, that input method\n\
is used for reading a character.")
(prompt, inherit_input_method)
Lisp_Object prompt, inherit_input_method;
{
if (! NILP (prompt))
message_with_string ("%s", prompt, 0);
return read_filtered_event (1, 1, 1, ! NILP (inherit_input_method));
}
DEFUN ("read-event", Fread_event, Sread_event, 0, 2, 0,
"Read an event object from the input stream.\n\
If the optional argument PROMPT is non-nil, display that as a prompt.\n\
If the optional argument INHERIT-INPUT-METHOD is non-nil and some\n\
input method is turned on in the current buffer, that input method\n\
is used for reading a character.")
(prompt, inherit_input_method)
Lisp_Object prompt, inherit_input_method;
{
if (! NILP (prompt))
message_with_string ("%s", prompt, 0);
return read_filtered_event (0, 0, 0, ! NILP (inherit_input_method));
}
DEFUN ("read-char-exclusive", Fread_char_exclusive, Sread_char_exclusive, 0, 2, 0,
"Read a character from the command input (keyboard or macro).\n\
It is returned as a number. Non-character events are ignored.\n\
\n\
If the optional argument PROMPT is non-nil, display that as a prompt.\n\
If the optional argument INHERIT-INPUT-METHOD is non-nil and some\n\
input method is turned on in the current buffer, that input method\n\
is used for reading a character.")
(prompt, inherit_input_method)
Lisp_Object prompt, inherit_input_method;
{
if (! NILP (prompt))
message_with_string ("%s", prompt, 0);
return read_filtered_event (1, 1, 0, ! NILP (inherit_input_method));
}
DEFUN ("get-file-char", Fget_file_char, Sget_file_char, 0, 0, 0,
"Don't use this yourself.")
()
{
register Lisp_Object val;
XSETINT (val, getc (instream));
return val;
}
static int
safe_to_load_p (fd)
int fd;
{
char buf[512];
int nbytes, i;
int safe_p = 1;
nbytes = emacs_read (fd, buf, sizeof buf - 1);
if (nbytes > 0)
{
buf[nbytes] = '\0';
for (i = 0; i < nbytes && buf[i] != '\n'; ++i)
;
if (i < nbytes
&& fast_c_string_match_ignore_case (Vbytecomp_version_regexp,
buf + i) < 0)
safe_p = 0;
}
lseek (fd, 0, SEEK_SET);
return safe_p;
}
static Lisp_Object
record_load_unwind (old)
Lisp_Object old;
{
return Vloads_in_progress = old;
}
DEFUN ("load", Fload, Sload, 1, 5, 0,
"Execute a file of Lisp code named FILE.\n\
First try FILE with `.elc' appended, then try with `.el',\n\
then try FILE unmodified. Environment variable references in FILE\n\
are replaced with their values by calling `substitute-in-file-name'.\n\
This function searches the directories in `load-path'.\n\
If optional second arg NOERROR is non-nil,\n\
report no error if FILE doesn't exist.\n\
Print messages at start and end of loading unless\n\
optional third arg NOMESSAGE is non-nil.\n\
If optional fourth arg NOSUFFIX is non-nil, don't try adding\n\
suffixes `.elc' or `.el' to the specified name FILE.\n\
If optional fifth arg MUST-SUFFIX is non-nil, insist on\n\
the suffix `.elc' or `.el'; don't accept just FILE unless\n\
it ends in one of those suffixes or includes a directory name.\n\
Return t if file exists.")
(file, noerror, nomessage, nosuffix, must_suffix)
Lisp_Object file, noerror, nomessage, nosuffix, must_suffix;
{
register FILE *stream;
register int fd = -1;
register Lisp_Object lispstream;
int count = specpdl_ptr - specpdl;
Lisp_Object temp;
struct gcpro gcpro1;
Lisp_Object found;
int newer = 0;
int compiled = 0;
Lisp_Object handler;
int safe_p = 1;
char *fmode = "r";
#ifdef DOS_NT
fmode = "rt";
#endif
CHECK_STRING (file, 0);
handler = Ffind_file_name_handler (file, Qload);
if (!NILP (handler))
return call5 (handler, Qload, file, noerror, nomessage, nosuffix);
file = Fsubstitute_in_file_name (file);
if (XSTRING (file)->size > 0)
{
int size = STRING_BYTES (XSTRING (file));
GCPRO1 (file);
if (! NILP (must_suffix))
{
if (size > 3
&& !strcmp (XSTRING (file)->data + size - 3, ".el"))
must_suffix = Qnil;
else if (size > 4
&& !strcmp (XSTRING (file)->data + size - 4, ".elc"))
must_suffix = Qnil;
else if (! NILP (Ffile_name_directory (file)))
must_suffix = Qnil;
}
fd = openp (Vload_path, file,
(!NILP (nosuffix) ? ""
: ! NILP (must_suffix) ? ".elc.gz:.elc:.el.gz:.el"
: ".elc:.elc.gz:.el.gz:.el:"),
&found, 0);
UNGCPRO;
}
if (fd == -1)
{
if (NILP (noerror))
while (1)
Fsignal (Qfile_error, Fcons (build_string ("Cannot open load file"),
Fcons (file, Qnil)));
else
return Qnil;
}
if (EQ (Qt, Vuser_init_file))
Vuser_init_file = found;
if (fd == -2)
{
if (NILP (Fequal (found, file)))
handler = Ffind_file_name_handler (found, Qt);
else
handler = Ffind_file_name_handler (found, Qload);
if (! NILP (handler))
return call5 (handler, Qload, found, noerror, nomessage, Qt);
}
if (INTEGERP (Vrecursive_load_depth_limit)
&& XINT (Vrecursive_load_depth_limit) > 0)
{
Lisp_Object len = Flength (Vloads_in_progress);
if (XFASTINT (len) > XFASTINT (Vrecursive_load_depth_limit))
Fsignal (Qerror, Fcons (build_string ("Recursive load suspected"),
Fcons (found, Vloads_in_progress)));
record_unwind_protect (record_load_unwind, Vloads_in_progress);
Vloads_in_progress = Fcons (found, Vloads_in_progress);
}
if (!bcmp (&(XSTRING (found)->data[STRING_BYTES (XSTRING (found)) - 4]),
".elc", 4))
{
if (fd != -2)
{
struct stat s1, s2;
int result;
if (!safe_to_load_p (fd))
{
safe_p = 0;
if (!load_dangerous_libraries)
error ("File `%s' was not compiled in Emacs",
XSTRING (found)->data);
else if (!NILP (nomessage))
message_with_string ("File `%s' not compiled in Emacs", found, 1);
}
compiled = 1;
#ifdef DOS_NT
fmode = "rb";
#endif
stat ((char *)XSTRING (found)->data, &s1);
XSTRING (found)->data[STRING_BYTES (XSTRING (found)) - 1] = 0;
result = stat ((char *)XSTRING (found)->data, &s2);
if (result >= 0 && (unsigned) s1.st_mtime < (unsigned) s2.st_mtime)
{
newer = 1;
if (! NILP (nomessage))
message_with_string ("Source file `%s' newer than byte-compiled file",
found, 1);
}
XSTRING (found)->data[STRING_BYTES (XSTRING (found)) - 1] = 'c';
}
}
else
{
if (!NILP (Vload_source_file_function))
{
Lisp_Object val;
if (fd >= 0)
emacs_close (fd);
val = call4 (Vload_source_file_function, found, file,
NILP (noerror) ? Qnil : Qt,
NILP (nomessage) ? Qnil : Qt);
return unbind_to (count, val);
}
}
#ifdef WINDOWSNT
emacs_close (fd);
stream = fopen ((char *) XSTRING (found)->data, fmode);
#else
stream = fdopen (fd, fmode);
#endif
if (stream == 0)
{
emacs_close (fd);
error ("Failure to create stdio stream for %s", XSTRING (file)->data);
}
if (! NILP (Vpurify_flag))
Vpreloaded_file_list = Fcons (file, Vpreloaded_file_list);
if (NILP (nomessage))
{
if (!safe_p)
message_with_string ("Loading %s (compiled; note unsafe, not compiled in Emacs)...",
file, 1);
else if (!compiled)
message_with_string ("Loading %s (source)...", file, 1);
else if (newer)
message_with_string ("Loading %s (compiled; note, source file is newer)...",
file, 1);
else
message_with_string ("Loading %s...", file, 1);
}
GCPRO1 (file);
lispstream = Fcons (Qnil, Qnil);
XSETFASTINT (XCAR (lispstream), (EMACS_UINT)stream >> 16);
XSETFASTINT (XCDR (lispstream), (EMACS_UINT)stream & 0xffff);
record_unwind_protect (load_unwind, lispstream);
record_unwind_protect (load_descriptor_unwind, load_descriptor_list);
specbind (Qload_file_name, found);
specbind (Qinhibit_file_name_operation, Qnil);
load_descriptor_list
= Fcons (make_number (fileno (stream)), load_descriptor_list);
load_in_progress++;
readevalloop (Qget_file_char, stream, file, Feval, 0, Qnil, Qnil);
unbind_to (count, Qnil);
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 (prev_saved_doc_string)
xfree (prev_saved_doc_string);
prev_saved_doc_string = 0;
prev_saved_doc_string_size = 0;
if (!noninteractive && NILP (nomessage))
{
if (!safe_p)
message_with_string ("Loading %s (compiled; note unsafe, not compiled in Emacs)...done",
file, 1);
else if (!compiled)
message_with_string ("Loading %s (source)...done", file, 1);
else if (newer)
message_with_string ("Loading %s (compiled; note, source file is newer)...done",
file, 1);
else
message_with_string ("Loading %s...done", file, 1);
}
return Qt;
}
static Lisp_Object
load_unwind (stream)
Lisp_Object stream;
{
fclose ((FILE *) (XFASTINT (XCAR (stream)) << 16
| XFASTINT (XCDR (stream))));
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;
}
void
close_load_descs ()
{
#ifndef WINDOWSNT
Lisp_Object tail;
for (tail = load_descriptor_list; !NILP (tail); tail = XCDR (tail))
emacs_close (XFASTINT (XCAR (tail)));
#endif
}
static int
complete_filename_p (pathname)
Lisp_Object pathname;
{
register unsigned char *s = XSTRING (pathname)->data;
return (IS_DIRECTORY_SEP (s[0])
|| (XSTRING (pathname)->size > 2
&& IS_DEVICE_SEP (s[1]) && IS_DIRECTORY_SEP (s[2]))
#ifdef ALTOS
|| *s == '@'
#endif
#ifdef VMS
|| index (s, ':')
#endif
);
}
int
openp (path, str, suffix, storeptr, exec_only)
Lisp_Object path, str;
char *suffix;
Lisp_Object *storeptr;
int exec_only;
{
register int fd;
int fn_size = 100;
char buf[100];
register char *fn = buf;
int absolute = 0;
int want_size;
Lisp_Object filename;
struct stat st;
struct gcpro gcpro1, gcpro2, gcpro3;
Lisp_Object string;
string = filename = Qnil;
GCPRO3 (str, string, filename);
if (storeptr)
*storeptr = Qnil;
if (complete_filename_p (str))
absolute = 1;
for (; !NILP (path); path = Fcdr (path))
{
char *nsuffix;
filename = Fexpand_file_name (str, Fcar (path));
if (!complete_filename_p (filename))
{
filename = Fexpand_file_name (filename, current_buffer->directory);
if (!complete_filename_p (filename))
continue;
}
want_size = strlen (suffix) + STRING_BYTES (XSTRING (filename)) + 1;
if (fn_size < want_size)
fn = (char *) alloca (fn_size = 100 + want_size);
nsuffix = suffix;
while (1)
{
char *esuffix = (char *) index (nsuffix, ':');
int lsuffix = esuffix ? esuffix - nsuffix : strlen (nsuffix);
Lisp_Object handler;
if (XSTRING (filename)->size > 2
&& XSTRING (filename)->data[0] == '/'
&& XSTRING (filename)->data[1] == ':')
{
strncpy (fn, XSTRING (filename)->data + 2,
STRING_BYTES (XSTRING (filename)) - 2);
fn[STRING_BYTES (XSTRING (filename)) - 2] = 0;
}
else
{
strncpy (fn, XSTRING (filename)->data,
STRING_BYTES (XSTRING (filename)));
fn[STRING_BYTES (XSTRING (filename))] = 0;
}
if (lsuffix != 0)
strncat (fn, nsuffix, lsuffix);
if (absolute)
handler = Qnil;
else
handler = Ffind_file_name_handler (filename, Qfile_exists_p);
if (! NILP (handler) && ! exec_only)
{
int exists;
string = build_string (fn);
exists = ! NILP (exec_only ? Ffile_executable_p (string)
: Ffile_readable_p (string));
if (exists
&& ! NILP (Ffile_directory_p (build_string (fn))))
exists = 0;
if (exists)
{
if (storeptr)
*storeptr = build_string (fn);
UNGCPRO;
return -2;
}
}
else
{
int exists = (stat (fn, &st) >= 0
&& (st.st_mode & S_IFMT) != S_IFDIR);
if (exists)
{
if (exec_only)
fd = (access (fn, X_OK) == 0) ? 1 : -1;
else
fd = emacs_open (fn, O_RDONLY, 0);
if (fd >= 0)
{
if (storeptr)
*storeptr = build_string (fn);
UNGCPRO;
return fd;
}
}
}
if (esuffix == 0)
break;
nsuffix += lsuffix + 1;
}
if (absolute)
break;
}
UNGCPRO;
return -1;
}
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;
loading = stream || !NARROWED;
tail = Vload_history;
prev = Qnil;
foundit = 0;
while (!NILP (tail))
{
tem = Fcar (tail);
if (!NILP (Fequal (source, Fcar (tem))))
{
foundit = 1;
if (loading)
{
if (NILP (prev))
Vload_history = Fcdr (tail);
else
Fsetcdr (prev, Fcdr (tail));
}
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 (loading || !foundit)
Vload_history = Fcons (Fnreverse (Vcurrent_load_list),
Vload_history);
}
Lisp_Object
unreadpure (junk)
Lisp_Object junk;
{
read_pure = 0;
return Qnil;
}
static Lisp_Object
readevalloop_1 (old)
Lisp_Object old;
{
load_convert_to_unibyte = ! NILP (old);
return Qnil;
}
static void
end_of_file_error ()
{
Lisp_Object data;
if (STRINGP (Vload_file_name))
data = Fcons (Vload_file_name, Qnil);
else
data = Qnil;
Fsignal (Qend_of_file, data);
}
static void
readevalloop (readcharfun, stream, sourcename, evalfun, printflag, unibyte, readfun)
Lisp_Object readcharfun;
FILE *stream;
Lisp_Object sourcename;
Lisp_Object (*evalfun) ();
int printflag;
Lisp_Object unibyte, readfun;
{
register int c;
register Lisp_Object val;
int count = specpdl_ptr - specpdl;
struct gcpro gcpro1;
struct buffer *b = 0;
int continue_reading_p;
if (BUFFERP (readcharfun))
b = XBUFFER (readcharfun);
else if (MARKERP (readcharfun))
b = XMARKER (readcharfun)->buffer;
specbind (Qstandard_input, readcharfun);
specbind (Qcurrent_load_list, Qnil);
record_unwind_protect (readevalloop_1, load_convert_to_unibyte ? Qt : Qnil);
load_convert_to_unibyte = !NILP (unibyte);
readchar_backlog = -1;
GCPRO1 (sourcename);
LOADHIST_ATTACH (sourcename);
continue_reading_p = 1;
while (continue_reading_p)
{
if (b != 0 && NILP (b->name))
error ("Reading from killed buffer");
instream = stream;
c = READCHAR;
if (c == ';')
{
while ((c = READCHAR) != '\n' && c != -1);
continue;
}
if (c < 0) break;
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 (count1, Qnil);
}
else
{
UNREAD (c);
read_objects = Qnil;
if (!NILP (readfun))
{
val = call1 (readfun, readcharfun);
if (BUFFERP (readcharfun))
{
struct buffer *b = XBUFFER (readcharfun);
if (BUF_PT (b) == BUF_ZV (b))
continue_reading_p = 0;
}
}
else if (! NILP (Vload_read_function))
val = call1 (Vload_read_function, readcharfun);
else
val = read0 (readcharfun);
}
val = (*evalfun) (val);
if (printflag)
{
Vvalues = Fcons (val, Vvalues);
if (EQ (Vstandard_output, Qt))
Fprin1 (val, Qnil);
else
Fprint (val, Qnil);
}
}
build_load_history (stream, sourcename);
UNGCPRO;
unbind_to (count, Qnil);
}
DEFUN ("eval-buffer", Feval_buffer, Seval_buffer, 0, 5, "",
"Execute the current buffer as Lisp code.\n\
Programs can pass two arguments, BUFFER and PRINTFLAG.\n\
BUFFER is the buffer to evaluate (nil means use current buffer).\n\
PRINTFLAG controls printing of output:\n\
nil means discard it; anything else is stream for print.\n\
\n\
If the optional third argument FILENAME is non-nil,\n\
it specifies the file name to use for `load-history'.\n\
The optional fourth argument UNIBYTE specifies `load-convert-to-unibyte'\n\
for this invocation.\n\
\n\
The optional fifth argument DO-ALLOW-PRINT, if not-nil, specifies that\n\
`print' and related functions should work normally even if PRINTFLAG is nil.\n\
\n\
This function preserves the position of point.")
(buffer, printflag, filename, unibyte, do_allow_print)
Lisp_Object buffer, printflag, filename, unibyte, do_allow_print;
{
int count = specpdl_ptr - specpdl;
Lisp_Object tem, buf;
if (NILP (buffer))
buf = Fcurrent_buffer ();
else
buf = Fget_buffer (buffer);
if (NILP (buf))
error ("No such buffer");
if (NILP (printflag) && NILP (do_allow_print))
tem = Qsymbolp;
else
tem = printflag;
if (NILP (filename))
filename = XBUFFER (buf)->filename;
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, filename, Feval, !NILP (printflag), unibyte, Qnil);
unbind_to (count, Qnil);
return Qnil;
}
#if 0
XDEFUN ("eval-current-buffer", Feval_current_buffer, Seval_current_buffer, 0, 1, "",
"Execute the current buffer as Lisp code.\n\
Programs can pass argument PRINTFLAG which controls printing of output:\n\
nil means discard it; anything else is stream for print.\n\
\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.")
(printflag)
Lisp_Object printflag;
{
int count = specpdl_ptr - specpdl;
Lisp_Object tem, cbuf;
cbuf = Fcurrent_buffer ()
if (NILP (printflag))
tem = Qsymbolp;
else
tem = printflag;
specbind (Qstandard_output, tem);
record_unwind_protect (save_excursion_restore, save_excursion_save ());
SET_PT (BEGV);
readevalloop (cbuf, 0, XBUFFER (cbuf)->filename, Feval,
!NILP (printflag), Qnil, Qnil);
return unbind_to (count, Qnil);
}
#endif
DEFUN ("eval-region", Feval_region, Seval_region, 2, 4, "r",
"Execute the region as Lisp code.\n\
When called from programs, expects two arguments,\n\
giving starting and ending indices in the current buffer\n\
of the text to be executed.\n\
Programs can pass third argument PRINTFLAG which controls output:\n\
nil means discard it; anything else is stream for printing it.\n\
Also the fourth argument READ-FUNCTION, if non-nil, is used\n\
instead of `read' to read each expression. It gets one argument\n\
which is the input stream for reading characters.\n\
\n\
This function does not move point.")
(start, end, printflag, read_function)
Lisp_Object start, end, printflag, read_function;
{
int count = specpdl_ptr - specpdl;
Lisp_Object tem, cbuf;
cbuf = Fcurrent_buffer ();
if (NILP (printflag))
tem = Qsymbolp;
else
tem = printflag;
specbind (Qstandard_output, tem);
if (NILP (printflag))
record_unwind_protect (save_excursion_restore, save_excursion_save ());
record_unwind_protect (save_restriction_restore, save_restriction_save ());
Fgoto_char (start);
Fnarrow_to_region (make_number (BEGV), end);
readevalloop (cbuf, 0, XBUFFER (cbuf)->filename, Feval,
!NILP (printflag), Qnil, read_function);
return unbind_to (count, Qnil);
}
DEFUN ("read", Fread, Sread, 0, 1, 0,
"Read one Lisp expression as text from STREAM, return as Lisp object.\n\
If STREAM is nil, use the value of `standard-input' (which see).\n\
STREAM or the value of `standard-input' may be:\n\
a buffer (read from point and advance it)\n\
a marker (read from where it points and advance it)\n\
a function (call it with no arguments for each character,\n\
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, or read from\n\
standard input in batch mode).")
(stream)
Lisp_Object stream;
{
extern Lisp_Object Fread_minibuffer ();
if (NILP (stream))
stream = Vstandard_input;
if (EQ (stream, Qt))
stream = Qread_char;
readchar_backlog = -1;
new_backquote_flag = 0;
read_objects = Qnil;
if (EQ (stream, Qread_char))
return Fread_minibuffer (build_string ("Lisp expression: "), Qnil);
if (STRINGP (stream))
return Fcar (Fread_from_string (stream, Qnil, Qnil));
return read0 (stream);
}
DEFUN ("read-from-string", Fread_from_string, Sread_from_string, 1, 3, 0,
"Read one Lisp expression which is represented as text by STRING.\n\
Returns a cons: (OBJECT-READ . FINAL-STRING-INDEX).\n\
START and END optionally delimit a substring of STRING from which to read;\n\
they default to 0 and (length STRING) respectively.")
(string, start, end)
Lisp_Object string, start, end;
{
int startval, endval;
Lisp_Object tem;
CHECK_STRING (string,0);
if (NILP (end))
endval = XSTRING (string)->size;
else
{
CHECK_NUMBER (end, 2);
endval = XINT (end);
if (endval < 0 || endval > XSTRING (string)->size)
args_out_of_range (string, end);
}
if (NILP (start))
startval = 0;
else
{
CHECK_NUMBER (start, 1);
startval = XINT (start);
if (startval < 0 || startval > endval)
args_out_of_range (string, start);
}
read_from_string_index = startval;
read_from_string_index_byte = string_char_to_byte (string, startval);
read_from_string_limit = endval;
new_backquote_flag = 0;
read_objects = Qnil;
tem = read0 (string);
return Fcons (tem, make_number (read_from_string_index));
}
static Lisp_Object
read0 (readcharfun)
Lisp_Object readcharfun;
{
register Lisp_Object val;
int c;
val = read1 (readcharfun, &c, 0);
if (c)
Fsignal (Qinvalid_read_syntax, Fcons (Fmake_string (make_number (1),
make_number (c)),
Qnil));
return val;
}
static int read_buffer_size;
static char *read_buffer;
static int
read_multibyte (c, readcharfun)
register int c;
Lisp_Object readcharfun;
{
unsigned char str[MAX_MULTIBYTE_LENGTH];
int len = 0;
int bytes;
str[len++] = c;
while ((c = READCHAR) >= 0xA0
&& len < MAX_MULTIBYTE_LENGTH)
str[len++] = c;
UNREAD (c);
if (UNIBYTE_STR_AS_MULTIBYTE_P (str, len, bytes))
return STRING_CHAR (str, len);
while (--len > 0)
UNREAD (str[len]);
return str[0];
}
static int
read_escape (readcharfun, stringp)
Lisp_Object readcharfun;
int stringp;
{
register int c = READCHAR;
switch (c)
{
case -1:
error ("End of file");
case 'a':
return '\007';
case 'b':
return '\b';
case 'd':
return 0177;
case 'e':
return 033;
case 'f':
return '\f';
case 'n':
return '\n';
case 'r':
return '\r';
case 't':
return '\t';
case 'v':
return '\v';
case '\n':
return -1;
case ' ':
if (stringp)
return -1;
return ' ';
case 'M':
c = READCHAR;
if (c != '-')
error ("Invalid escape character syntax");
c = READCHAR;
if (c == '\\')
c = read_escape (readcharfun, 0);
return c | meta_modifier;
case 'S':
c = READCHAR;
if (c != '-')
error ("Invalid escape character syntax");
c = READCHAR;
if (c == '\\')
c = read_escape (readcharfun, 0);
return c | shift_modifier;
case 'H':
c = READCHAR;
if (c != '-')
error ("Invalid escape character syntax");
c = READCHAR;
if (c == '\\')
c = read_escape (readcharfun, 0);
return c | hyper_modifier;
case 'A':
c = READCHAR;
if (c != '-')
error ("Invalid escape character syntax");
c = READCHAR;
if (c == '\\')
c = read_escape (readcharfun, 0);
return c | alt_modifier;
case 's':
c = READCHAR;
if (c != '-')
error ("Invalid escape character syntax");
c = READCHAR;
if (c == '\\')
c = read_escape (readcharfun, 0);
return c | super_modifier;
case 'C':
c = READCHAR;
if (c != '-')
error ("Invalid escape character syntax");
case '^':
c = READCHAR;
if (c == '\\')
c = read_escape (readcharfun, 0);
if ((c & ~CHAR_MODIFIER_MASK) == '?')
return 0177 | (c & CHAR_MODIFIER_MASK);
else if (! SINGLE_BYTE_CHAR_P ((c & ~CHAR_MODIFIER_MASK)))
return c | ctrl_modifier;
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 | ctrl_modifier;
case '0':
case '1':
case '2':
case '3':
case '4':
case '5':
case '6':
case '7':
{
register int i = c - '0';
register int count = 0;
while (++count < 3)
{
if ((c = READCHAR) >= '0' && c <= '7')
{
i *= 8;
i += c - '0';
}
else
{
UNREAD (c);
break;
}
}
return i;
}
case 'x':
{
int i = 0;
while (1)
{
c = READCHAR;
if (c >= '0' && c <= '9')
{
i *= 16;
i += c - '0';
}
else if ((c >= 'a' && c <= 'f')
|| (c >= 'A' && c <= 'F'))
{
i *= 16;
if (c >= 'a' && c <= 'f')
i += c - 'a' + 10;
else
i += c - 'A' + 10;
}
else
{
UNREAD (c);
break;
}
}
return i;
}
default:
if (BASE_LEADING_CODE_P (c))
c = read_multibyte (c, readcharfun);
return c;
}
}
static Lisp_Object
read_integer (readcharfun, radix)
Lisp_Object readcharfun;
int radix;
{
int ndigits = 0, invalid_p, c, sign = 0;
EMACS_INT number = 0;
if (radix < 2 || radix > 36)
invalid_p = 1;
else
{
number = ndigits = invalid_p = 0;
sign = 1;
c = READCHAR;
if (c == '-')
{
c = READCHAR;
sign = -1;
}
else if (c == '+')
c = READCHAR;
while (c >= 0)
{
int digit;
if (c >= '0' && c <= '9')
digit = c - '0';
else if (c >= 'a' && c <= 'z')
digit = c - 'a' + 10;
else if (c >= 'A' && c <= 'Z')
digit = c - 'A' + 10;
else
{
UNREAD (c);
break;
}
if (digit < 0 || digit >= radix)
invalid_p = 1;
number = radix * number + digit;
++ndigits;
c = READCHAR;
}
}
if (ndigits == 0 || invalid_p)
{
char buf[50];
sprintf (buf, "integer, radix %d", radix);
Fsignal (Qinvalid_read_syntax, Fcons (build_string (buf), Qnil));
}
return make_number (sign * number);
}
static void
to_multibyte (p, end, nchars)
char **p, **end;
int *nchars;
{
int nbytes;
parse_str_as_multibyte (read_buffer, *p - read_buffer, &nbytes, nchars);
if (read_buffer_size < 2 * nbytes)
{
int offset = *p - read_buffer;
read_buffer_size *= 2;
read_buffer = (char *) xrealloc (read_buffer, read_buffer_size);
*p = read_buffer + offset;
*end = read_buffer + read_buffer_size;
}
if (nbytes != *nchars)
nbytes = str_as_multibyte (read_buffer, read_buffer_size,
*p - read_buffer, nchars);
*p = read_buffer + nbytes;
}
static Lisp_Object
read1 (readcharfun, pch, first_in_list)
register Lisp_Object readcharfun;
int *pch;
int first_in_list;
{
register int c;
int uninterned_symbol = 0;
*pch = 0;
retry:
c = READCHAR;
if (c < 0)
end_of_file_error ();
switch (c)
{
case '(':
return read_list (0, readcharfun);
case '[':
return read_vector (readcharfun, 0);
case ')':
case ']':
{
*pch = c;
return Qnil;
}
case '#':
c = READCHAR;
if (c == '^')
{
c = READCHAR;
if (c == '[')
{
Lisp_Object tmp;
tmp = read_vector (readcharfun, 0);
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));
XCHAR_TABLE (tmp)->top = Qt;
return tmp;
}
else if (c == '^')
{
c = READCHAR;
if (c == '[')
{
Lisp_Object tmp;
tmp = read_vector (readcharfun, 0);
if (XVECTOR (tmp)->size != SUB_CHAR_TABLE_STANDARD_SLOTS)
error ("Invalid size char-table");
XSETCHAR_TABLE (tmp, XCHAR_TABLE (tmp));
XCHAR_TABLE (tmp)->top = Qnil;
return tmp;
}
Fsignal (Qinvalid_read_syntax,
Fcons (make_string ("#^^", 3), Qnil));
}
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 - 1)
/ BITS_PER_CHAR);
UNREAD (c);
tmp = read1 (readcharfun, pch, first_in_list);
if (size_in_chars != XSTRING (tmp)->size
&& ! (XFASTINT (length)
== (XSTRING (tmp)->size - 1) * BITS_PER_CHAR))
Fsignal (Qinvalid_read_syntax,
Fcons (make_string ("#&...", 5), Qnil));
val = Fmake_bool_vector (length, Qnil);
bcopy (XSTRING (tmp)->data, XBOOL_VECTOR (val)->data,
size_in_chars);
if (XINT (length) != size_in_chars * BITS_PER_CHAR)
XBOOL_VECTOR (val)->data[size_in_chars - 1]
&= (1 << (XINT (length) % BITS_PER_CHAR)) - 1;
return val;
}
Fsignal (Qinvalid_read_syntax, Fcons (make_string ("#&...", 5),
Qnil));
}
if (c == '[')
{
Lisp_Object tmp;
tmp = read_vector (readcharfun, 1);
return Fmake_byte_code (XVECTOR (tmp)->size,
XVECTOR (tmp)->contents);
}
if (c == '(')
{
Lisp_Object tmp;
struct gcpro gcpro1;
int ch;
tmp = read1 (readcharfun, &ch, 0);
if (ch != 0 || !STRINGP (tmp))
Fsignal (Qinvalid_read_syntax, Fcons (make_string ("#", 1), Qnil));
GCPRO1 (tmp);
while (1)
{
Lisp_Object beg, end, plist;
beg = read1 (readcharfun, &ch, 0);
end = plist = Qnil;
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;
}
if (c == '@')
{
int i, nskip = 0;
while ((c = READCHAR) >= 0
&& c >= '0' && c <= '9')
{
nskip *= 10;
nskip += c - '0';
}
if (c >= 0)
UNREAD (c);
if (load_force_doc_strings && EQ (readcharfun, Qget_file_char))
{
{
char *temp = saved_doc_string;
int temp_size = saved_doc_string_size;
file_offset temp_pos = saved_doc_string_position;
int temp_len = saved_doc_string_length;
saved_doc_string = prev_saved_doc_string;
saved_doc_string_size = prev_saved_doc_string_size;
saved_doc_string_position = prev_saved_doc_string_position;
saved_doc_string_length = prev_saved_doc_string_length;
prev_saved_doc_string = temp;
prev_saved_doc_string_size = temp_size;
prev_saved_doc_string_position = temp_pos;
prev_saved_doc_string_length = temp_len;
}
if (saved_doc_string_size == 0)
{
saved_doc_string_size = nskip + 100;
saved_doc_string = (char *) xmalloc (saved_doc_string_size);
}
if (nskip > saved_doc_string_size)
{
saved_doc_string_size = nskip + 100;
saved_doc_string = (char *) xrealloc (saved_doc_string,
saved_doc_string_size);
}
saved_doc_string_position = file_tell (instream);
for (i = 0; i < nskip && c >= 0; i++)
saved_doc_string[i] = c = READCHAR;
saved_doc_string_length = i;
}
else
{
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));
if (c == ':')
{
uninterned_symbol = 1;
c = READCHAR;
goto default_label;
}
if (c >= '0' && c <= '9')
{
int n = 0;
Lisp_Object tem;
while (c >= '0' && c <= '9')
{
n *= 10;
n += c - '0';
c = READCHAR;
}
if (c == '=')
{
Lisp_Object placeholder;
Lisp_Object cell;
placeholder = Fcons(Qnil, Qnil);
cell = Fcons (make_number (n), placeholder);
read_objects = Fcons (cell, read_objects);
tem = read0 (readcharfun);
substitute_object_in_subtree (tem, placeholder);
Fsetcdr (cell, tem);
return tem;
}
if (c == '#')
{
tem = Fassq (make_number (n), read_objects);
if (CONSP (tem))
return XCDR (tem);
}
else if (c == 'r' || c == 'R')
return read_integer (readcharfun, n);
}
else if (c == 'x' || c == 'X')
return read_integer (readcharfun, 16);
else if (c == 'o' || c == 'O')
return read_integer (readcharfun, 8);
else if (c == 'b' || c == 'B')
return read_integer (readcharfun, 2);
UNREAD (c);
Fsignal (Qinvalid_read_syntax, Fcons (make_string ("#", 1), Qnil));
case ';':
while ((c = READCHAR) >= 0 && c != '\n');
goto retry;
case '\'':
{
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 '?':
{
c = READCHAR;
if (c < 0)
end_of_file_error ();
if (c == '\\')
c = read_escape (readcharfun, 0);
else if (BASE_LEADING_CODE_P (c))
c = read_multibyte (c, readcharfun);
return make_number (c);
}
case '"':
{
char *p = read_buffer;
char *end = read_buffer + read_buffer_size;
register int c;
int force_multibyte = 0;
int force_singlebyte = 0;
int cancel = 0;
int nchars;
while ((c = READCHAR) >= 0
&& c != '\"')
{
if (end - p < MAX_MULTIBYTE_LENGTH)
{
int offset = p - read_buffer;
read_buffer = (char *) xrealloc (read_buffer,
read_buffer_size *= 2);
p = read_buffer + offset;
end = read_buffer + read_buffer_size;
}
if (c == '\\')
{
c = read_escape (readcharfun, 1);
if (c == -1)
{
if (p == read_buffer)
cancel = 1;
continue;
}
if (SINGLE_BYTE_CHAR_P ((c & ~CHAR_MODIFIER_MASK))
&& ! ASCII_BYTE_P ((c & ~CHAR_MODIFIER_MASK)))
force_singlebyte = 1;
}
if (! SINGLE_BYTE_CHAR_P ((c & ~CHAR_MODIFIER_MASK)))
{
if (c & CHAR_MODIFIER_MASK)
error ("Invalid modifier in string");
p += CHAR_STRING (c, p);
force_multibyte = 1;
}
else
{
if (c == (CHAR_CTL | ' '))
c = 0;
else if (c == (CHAR_CTL | '?'))
c = 127;
if (c & CHAR_SHIFT)
{
if ((c & 0377) >= 'A' && (c & 0377) <= 'Z')
c &= ~CHAR_SHIFT;
else if ((c & 0377) >= 'a' && (c & 0377) <= 'z')
c = (c & ~CHAR_SHIFT) - ('a' - 'A');
}
if (c & CHAR_META)
c = (c & ~CHAR_META) | 0x80;
if (c & ~0xff)
error ("Invalid modifier in string");
*p++ = c;
}
}
if (c < 0)
end_of_file_error ();
if (!NILP (Vpurify_flag) && NILP (Vdoc_file_name) && cancel)
return make_number (0);
if (force_multibyte)
to_multibyte (&p, &end, &nchars);
else if (force_singlebyte)
nchars = p - read_buffer;
else if (load_convert_to_unibyte)
{
Lisp_Object string;
to_multibyte (&p, &end, &nchars);
if (p - read_buffer != nchars)
{
string = make_multibyte_string (read_buffer, nchars,
p - read_buffer);
return Fstring_make_unibyte (string);
}
}
else if (EQ (readcharfun, Qget_file_char)
|| EQ (readcharfun, Qlambda))
{
to_multibyte (&p, &end, &nchars);
}
else
nchars = p - read_buffer;
if (read_pure)
return make_pure_string (read_buffer, nchars, p - read_buffer,
(force_multibyte
|| (p - read_buffer != nchars)));
return make_specified_string (read_buffer, nchars, p - read_buffer,
(force_multibyte
|| (p - read_buffer != nchars)));
}
case '.':
{
int next_char = READCHAR;
UNREAD (next_char);
if (next_char <= 040
|| index ("\"'`,(", next_char))
{
*pch = c;
return Qnil;
}
}
default:
default_label:
if (c <= 040) goto retry;
{
char *p = read_buffer;
int quoted = 0;
{
char *end = read_buffer + read_buffer_size;
while (c > 040
&& !(c == '\"' || c == '\'' || c == ';'
|| c == '(' || c == ')'
|| c == '[' || c == ']' || c == '#'))
{
if (end - p < MAX_MULTIBYTE_LENGTH)
{
int offset = p - read_buffer;
read_buffer = (char *) xrealloc (read_buffer,
read_buffer_size *= 2);
p = read_buffer + offset;
end = read_buffer + read_buffer_size;
}
if (c == '\\')
{
c = READCHAR;
if (c == -1)
end_of_file_error ();
quoted = 1;
}
if (! SINGLE_BYTE_CHAR_P (c))
p += CHAR_STRING (c, p);
else
*p++ = c;
c = READCHAR;
}
if (p == end)
{
int offset = p - read_buffer;
read_buffer = (char *) xrealloc (read_buffer,
read_buffer_size *= 2);
p = read_buffer + offset;
end = read_buffer + read_buffer_size;
}
*p = 0;
if (c >= 0)
UNREAD (c);
}
if (!quoted && !uninterned_symbol)
{
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 > read_buffer && p1 < p && *p1 == '.') p1++;
if (p1 == p)
{
if (p1[-1] == '.')
p1[-1] = '\0';
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;
}
}
if (isfloat_string (read_buffer))
{
double zero = 0.0;
double value;
int negative = read_buffer[0] == '-';
switch (p[-1])
{
case 'F':
value = 1.0 / zero;
break;
case 'N':
value = zero / zero;
break;
default:
value = atof (read_buffer + negative);
break;
}
return make_float (negative ? - value : value);
}
}
if (uninterned_symbol)
return make_symbol (read_buffer);
else
return intern (read_buffer);
}
}
}
static Lisp_Object seen_list;
static void
substitute_object_in_subtree (object, placeholder)
Lisp_Object object;
Lisp_Object placeholder;
{
Lisp_Object check_object;
seen_list = Qnil;
check_object
= substitute_object_recurse (object, placeholder, object);
seen_list = Qnil;
if (!EQ (check_object, object))
error ("Unexpected mutation error in reader");
}
#define SUBSTITUTE(get_val, set_val) \
{ \
Lisp_Object old_value = get_val; \
Lisp_Object true_value \
= substitute_object_recurse (object, placeholder,\
old_value); \
\
if (!EQ (old_value, true_value)) \
{ \
set_val; \
} \
}
static Lisp_Object
substitute_object_recurse (object, placeholder, subtree)
Lisp_Object object;
Lisp_Object placeholder;
Lisp_Object subtree;
{
if (EQ (placeholder, subtree))
return object;
if (!EQ (Qnil, Fmemq (subtree, seen_list)))
return subtree;
if (!EQ (Qnil, Frassq (subtree, read_objects)))
seen_list = Fcons (subtree, seen_list);
switch (XTYPE (subtree))
{
case Lisp_Vectorlike:
{
int i;
int length = XINT (Flength(subtree));
for (i = 0; i < length; i++)
{
Lisp_Object idx = make_number (i);
SUBSTITUTE (Faref (subtree, idx),
Faset (subtree, idx, true_value));
}
return subtree;
}
case Lisp_Cons:
{
SUBSTITUTE (Fcar_safe (subtree),
Fsetcar (subtree, true_value));
SUBSTITUTE (Fcdr_safe (subtree),
Fsetcdr (subtree, true_value));
return subtree;
}
case Lisp_String:
{
INTERVAL root_interval = XSTRING (subtree)->intervals;
Lisp_Object arg = Fcons (object, placeholder);
traverse_intervals (root_interval, 1, 0,
&substitute_in_interval, arg);
return subtree;
}
default:
return subtree;
}
}
static void
substitute_in_interval (interval, arg)
INTERVAL interval;
Lisp_Object arg;
{
Lisp_Object object = Fcar (arg);
Lisp_Object placeholder = Fcdr (arg);
SUBSTITUTE(interval->plist, interval->plist = true_value);
}
#define LEAD_INT 1
#define DOT_CHAR 2
#define TRAIL_INT 4
#define E_CHAR 8
#define EXP_INT 16
int
isfloat_string (cp)
register char *cp;
{
register int state;
char *start = cp;
state = 0;
if (*cp == '+' || *cp == '-')
cp++;
if (*cp >= '0' && *cp <= '9')
{
state |= LEAD_INT;
while (*cp >= '0' && *cp <= '9')
cp++;
}
if (*cp == '.')
{
state |= DOT_CHAR;
cp++;
}
if (*cp >= '0' && *cp <= '9')
{
state |= TRAIL_INT;
while (*cp >= '0' && *cp <= '9')
cp++;
}
if (*cp == 'e' || *cp == 'E')
{
state |= E_CHAR;
cp++;
if (*cp == '+' || *cp == '-')
cp++;
}
if (*cp >= '0' && *cp <= '9')
{
state |= EXP_INT;
while (*cp >= '0' && *cp <= '9')
cp++;
}
else if (cp == start)
;
else if (cp[-1] == '+' && cp[0] == 'I' && cp[1] == 'N' && cp[2] == 'F')
{
state |= EXP_INT;
cp += 3;
}
else if (cp[-1] == '+' && cp[0] == 'N' && cp[1] == 'a' && cp[2] == 'N')
{
state |= EXP_INT;
cp += 3;
}
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)
|| state == (LEAD_INT|DOT_CHAR|TRAIL_INT|E_CHAR|EXP_INT)
|| state == (DOT_CHAR|TRAIL_INT|E_CHAR|EXP_INT)));
}
static Lisp_Object
read_vector (readcharfun, bytecodeflag)
Lisp_Object readcharfun;
int bytecodeflag;
{
register int i;
register int size;
register Lisp_Object *ptr;
register Lisp_Object tem, item, vector;
register struct Lisp_Cons *otem;
Lisp_Object len;
tem = read_list (1, readcharfun);
len = Flength (tem);
vector = (read_pure ? make_pure_vector (XINT (len)) : Fmake_vector (len, Qnil));
size = XVECTOR (vector)->size;
ptr = XVECTOR (vector)->contents;
for (i = 0; i < size; i++)
{
item = Fcar (tem);
if (bytecodeflag && load_force_doc_strings)
{
if (i == COMPILED_BYTECODE)
{
if (!STRINGP (item))
error ("invalid byte code");
ptr[COMPILED_CONSTANTS] = item;
item = Qnil;
}
else if (i == COMPILED_CONSTANTS)
{
Lisp_Object bytestr = ptr[COMPILED_CONSTANTS];
if (NILP (item))
{
XSTRING (bytestr)->size = STRING_BYTES (XSTRING (bytestr));
SET_STRING_BYTES (XSTRING (bytestr), -1);
item = Fread (bytestr);
if (!CONSP (item))
error ("invalid byte code");
otem = XCONS (item);
bytestr = XCAR (item);
item = XCDR (item);
free_cons (otem);
}
ptr[COMPILED_BYTECODE] = read_pure ? Fpurecopy (bytestr) : bytestr;
}
}
ptr[i] = read_pure ? Fpurecopy (item) : item;
otem = XCONS (tem);
tem = Fcdr (tem);
free_cons (otem);
}
return vector;
}
static Lisp_Object
read_list (flag, readcharfun)
int flag;
register Lisp_Object readcharfun;
{
int defunflag = flag < 0 ? -1 : 0;
Lisp_Object val, tail;
register Lisp_Object elt, tem;
struct gcpro gcpro1, gcpro2;
int doc_reference = 0;
int first_in_list = flag <= 0;
val = Qnil;
tail = Qnil;
while (1)
{
int ch;
GCPRO2 (val, tail);
elt = read1 (readcharfun, &ch, first_in_list);
UNGCPRO;
first_in_list = 0;
if (EQ (elt, Vload_file_name)
&& ! NILP (elt)
&& !NILP (Vpurify_flag))
{
if (NILP (Vdoc_file_name))
doc_reference = 1;
else
elt = concat2 (build_string ("../lisp/"),
Ffile_name_nondirectory (elt));
}
else if (EQ (elt, Vload_file_name)
&& ! NILP (elt)
&& load_force_doc_strings)
doc_reference = 2;
if (ch)
{
if (flag > 0)
{
if (ch == ']')
return val;
Fsignal (Qinvalid_read_syntax,
Fcons (make_string (") or . in a vector", 18), Qnil));
}
if (ch == ')')
return val;
if (ch == '.')
{
GCPRO2 (val, tail);
if (!NILP (tail))
XCDR (tail) = read0 (readcharfun);
else
val = read0 (readcharfun);
read1 (readcharfun, &ch, 0);
UNGCPRO;
if (ch == ')')
{
if (doc_reference == 1)
return make_number (0);
if (doc_reference == 2)
{
int pos = XINT (XCDR (val));
if (pos < 0) pos = -pos;
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;
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 if (pos >= prev_saved_doc_string_position
&& pos < (prev_saved_doc_string_position
+ prev_saved_doc_string_length))
{
int start = pos - prev_saved_doc_string_position;
int from, to;
for (from = start, to = start;
prev_saved_doc_string[from] != 037;)
{
int c = prev_saved_doc_string[from++];
if (c == 1)
{
c = prev_saved_doc_string[from++];
if (c == 1)
prev_saved_doc_string[to++] = c;
else if (c == '0')
prev_saved_doc_string[to++] = 0;
else if (c == '_')
prev_saved_doc_string[to++] = 037;
}
else
prev_saved_doc_string[to++] = c;
}
return make_string (prev_saved_doc_string + start,
to - start);
}
else
return get_doc_string (val, 0, 0);
}
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));
}
tem = (read_pure && flag <= 0
? pure_cons (elt, Qnil)
: Fcons (elt, Qnil));
if (!NILP (tail))
XCDR (tail) = tem;
else
val = tem;
tail = tem;
if (defunflag < 0)
defunflag = EQ (elt, Qdefun);
else if (defunflag > 0)
read_pure = 1;
}
}
Lisp_Object Vobarray;
Lisp_Object initial_obarray;
int oblookup_last_bucket_number;
static int hash_string ();
Lisp_Object oblookup ();
Lisp_Object
check_obarray (obarray)
Lisp_Object obarray;
{
while (!VECTORP (obarray) || XVECTOR (obarray)->size == 0)
{
if (EQ (Vobarray, obarray)) Vobarray = initial_obarray;
obarray = wrong_type_argument (Qvectorp, obarray);
}
return obarray;
}
Lisp_Object
intern (str)
char *str;
{
Lisp_Object tem;
int len = strlen (str);
Lisp_Object obarray;
obarray = Vobarray;
if (!VECTORP (obarray) || XVECTOR (obarray)->size == 0)
obarray = check_obarray (obarray);
tem = oblookup (obarray, str, len, len);
if (SYMBOLP (tem))
return tem;
return Fintern (make_string (str, len), obarray);
}
Lisp_Object
make_symbol (str)
char *str;
{
int len = strlen (str);
return Fmake_symbol ((!NILP (Vpurify_flag)
? make_pure_string (str, len, len, 0)
: make_string (str, len)));
}
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'.")
(string, obarray)
Lisp_Object string, obarray;
{
register Lisp_Object tem, sym, *ptr;
if (NILP (obarray)) obarray = Vobarray;
obarray = check_obarray (obarray);
CHECK_STRING (string, 0);
tem = oblookup (obarray, XSTRING (string)->data,
XSTRING (string)->size,
STRING_BYTES (XSTRING (string)));
if (!INTEGERP (tem))
return tem;
if (!NILP (Vpurify_flag))
string = Fpurecopy (string);
sym = Fmake_symbol (string);
XSYMBOL (sym)->obarray = obarray;
if ((XSTRING (string)->data[0] == ':')
&& EQ (obarray, initial_obarray))
XSYMBOL (sym)->value = sym;
ptr = &XVECTOR (obarray)->contents[XINT (tem)];
if (SYMBOLP (*ptr))
XSYMBOL (sym)->next = XSYMBOL (*ptr);
else
XSYMBOL (sym)->next = 0;
*ptr = sym;
return sym;
}
DEFUN ("intern-soft", Fintern_soft, Sintern_soft, 1, 2, 0,
"Return the canonical symbol named NAME, or nil if none exists.\n\
NAME may be a string or a symbol. If it is a symbol, that exact\n\
symbol is searched for.\n\
A second optional argument specifies the obarray to use;\n\
it defaults to the value of `obarray'.")
(name, obarray)
Lisp_Object name, obarray;
{
register Lisp_Object tem;
struct Lisp_String *string;
if (NILP (obarray)) obarray = Vobarray;
obarray = check_obarray (obarray);
if (!SYMBOLP (name))
{
CHECK_STRING (name, 0);
string = XSTRING (name);
}
else
string = XSYMBOL (name)->name;
tem = oblookup (obarray, string->data, string->size, STRING_BYTES (string));
if (INTEGERP (tem) || (SYMBOLP (name) && !EQ (name, tem)))
return Qnil;
else
return tem;
}
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,
STRING_BYTES (XSTRING (string)));
if (INTEGERP (tem))
return Qnil;
if (SYMBOLP (name) && !EQ (name, tem))
return Qnil;
XSYMBOL (tem)->obarray = 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;
}
Lisp_Object
oblookup (obarray, ptr, size, size_byte)
Lisp_Object obarray;
register char *ptr;
int size, size_byte;
{
int hash;
int obsize;
register Lisp_Object tail;
Lisp_Object bucket, tem;
if (!VECTORP (obarray)
|| (obsize = XVECTOR (obarray)->size) == 0)
{
obarray = check_obarray (obarray);
obsize = XVECTOR (obarray)->size;
}
obsize &= ~ARRAY_MARK_FLAG;
hash = hash_string (ptr, size_byte);
hash %= obsize;
bucket = XVECTOR (obarray)->contents[hash];
oblookup_last_bucket_number = hash;
if (XFASTINT (bucket) == 0)
;
else if (!SYMBOLP (bucket))
error ("Bad data in guts of obarray");
else
for (tail = bucket; ; XSETSYMBOL (tail, XSYMBOL (tail)->next))
{
if (STRING_BYTES (XSYMBOL (tail)->name) == size_byte
&& XSYMBOL (tail)->name->size == size
&& !bcmp (XSYMBOL (tail)->name->data, ptr, size_byte))
return tail;
else if (XSYMBOL (tail)->next == 0)
break;
}
XSETINT (tem, hash);
return tem;
}
static int
hash_string (ptr, len)
unsigned char *ptr;
int len;
{
register unsigned char *p = ptr;
register unsigned char *end = p + len;
register unsigned char c;
register int hash = 0;
while (p != end)
{
c = *p++;
if (c >= 0140) c -= 40;
hash = ((hash<<3) + (hash>>28) + c);
}
return hash & 07777777777;
}
void
map_obarray (obarray, fn, arg)
Lisp_Object obarray;
void (*fn) P_ ((Lisp_Object, Lisp_Object));
Lisp_Object arg;
{
register int i;
register Lisp_Object tail;
CHECK_VECTOR (obarray, 1);
for (i = XVECTOR (obarray)->size - 1; i >= 0; i--)
{
tail = XVECTOR (obarray)->contents[i];
if (SYMBOLP (tail))
while (1)
{
(*fn) (tail, arg);
if (XSYMBOL (tail)->next == 0)
break;
XSETSYMBOL (tail, XSYMBOL (tail)->next);
}
}
}
void
mapatoms_1 (sym, function)
Lisp_Object sym, function;
{
call1 (function, sym);
}
DEFUN ("mapatoms", Fmapatoms, Smapatoms, 1, 2, 0,
"Call FUNCTION on every symbol in OBARRAY.\n\
OBARRAY defaults to the value of `obarray'.")
(function, obarray)
Lisp_Object function, obarray;
{
if (NILP (obarray)) obarray = Vobarray;
obarray = check_obarray (obarray);
map_obarray (obarray, mapatoms_1, function);
return Qnil;
}
#define OBARRAY_SIZE 1511
void
init_obarray ()
{
Lisp_Object oblength;
int hash;
Lisp_Object *tem;
XSETFASTINT (oblength, OBARRAY_SIZE);
Qnil = Fmake_symbol (make_pure_string ("nil", 3, 3, 0));
Vobarray = Fmake_vector (oblength, make_number (0));
initial_obarray = Vobarray;
staticpro (&initial_obarray);
XSYMBOL (Qnil)->obarray = Vobarray;
hash = hash_string ("nil", 3);
hash %= OBARRAY_SIZE;
tem = &XVECTOR (Vobarray)->contents[hash];
*tem = Qnil;
Qunbound = Fmake_symbol (make_pure_string ("unbound", 7, 7, 0));
XSYMBOL (Qnil)->function = Qunbound;
XSYMBOL (Qunbound)->value = Qunbound;
XSYMBOL (Qunbound)->function = Qunbound;
Qt = intern ("t");
XSYMBOL (Qnil)->value = Qnil;
XSYMBOL (Qnil)->plist = Qnil;
XSYMBOL (Qt)->value = Qt;
Vpurify_flag = Qt;
Qvariable_documentation = intern ("variable-documentation");
staticpro (&Qvariable_documentation);
read_buffer_size = 100 + MAX_MULTIBYTE_LENGTH;
read_buffer = (char *) xmalloc (read_buffer_size);
}
void
defsubr (sname)
struct Lisp_Subr *sname;
{
Lisp_Object sym;
sym = intern (sname->symbol_name);
XSETSUBR (XSYMBOL (sym)->function, sname);
}
#ifdef NOTDEF
void
defalias (sname, string)
struct Lisp_Subr *sname;
char *string;
{
Lisp_Object sym;
sym = intern (string);
XSETSUBR (XSYMBOL (sym)->function, sname);
}
#endif
void
defvar_int (namestring, address)
char *namestring;
int *address;
{
Lisp_Object sym, val;
sym = intern (namestring);
val = allocate_misc ();
XMISCTYPE (val) = Lisp_Misc_Intfwd;
XINTFWD (val)->intvar = address;
XSYMBOL (sym)->value = val;
}
void
defvar_bool (namestring, address)
char *namestring;
int *address;
{
Lisp_Object sym, val;
sym = intern (namestring);
val = allocate_misc ();
XMISCTYPE (val) = Lisp_Misc_Boolfwd;
XBOOLFWD (val)->boolvar = address;
XSYMBOL (sym)->value = val;
Vbyte_boolean_vars = Fcons (sym, Vbyte_boolean_vars);
}
void
defvar_lisp_nopro (namestring, address)
char *namestring;
Lisp_Object *address;
{
Lisp_Object sym, val;
sym = intern (namestring);
val = allocate_misc ();
XMISCTYPE (val) = Lisp_Misc_Objfwd;
XOBJFWD (val)->objvar = address;
XSYMBOL (sym)->value = val;
}
void
defvar_lisp (namestring, address)
char *namestring;
Lisp_Object *address;
{
defvar_lisp_nopro (namestring, address);
staticpro (address);
}
void
defvar_per_buffer (namestring, address, type, doc)
char *namestring;
Lisp_Object *address;
Lisp_Object type;
char *doc;
{
Lisp_Object sym, val;
int offset;
extern struct buffer buffer_local_symbols;
sym = intern (namestring);
val = allocate_misc ();
offset = (char *)address - (char *)current_buffer;
XMISCTYPE (val) = Lisp_Misc_Buffer_Objfwd;
XBUFFER_OBJFWD (val)->offset = offset;
XSYMBOL (sym)->value = val;
PER_BUFFER_SYMBOL (offset) = sym;
PER_BUFFER_TYPE (offset) = type;
if (PER_BUFFER_IDX (offset) == 0)
abort ();
}
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;
}
static Lisp_Object dump_path;
void
init_lread ()
{
char *normal;
int turn_off_warning = 0;
#ifdef CANNOT_DUMP
normal = PATH_LOADSEARCH;
Vload_path = decode_env_path (0, normal);
#else
if (NILP (Vpurify_flag))
normal = PATH_LOADSEARCH;
else
normal = PATH_DUMPLOADSEARCH ":" PATH_LOADSEARCH;
if (initialized)
{
if (! NILP (Fequal (dump_path, Vload_path)))
{
Vload_path = decode_env_path (0, normal);
if (!NILP (Vinstallation_directory))
{
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
Vload_path = nconc2 (Vload_path, dump_path);
tem = Fexpand_file_name (build_string ("leim"),
Vinstallation_directory);
tem1 = Ffile_exists_p (tem);
if (!NILP (tem1))
{
if (NILP (Fmember (tem, Vload_path)))
Vload_path = nconc2 (Vload_path, Fcons (tem, Qnil));
}
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));
}
if (NILP (Fequal (Vinstallation_directory, Vsource_directory)))
{
Lisp_Object tem2;
tem = Fexpand_file_name (build_string ("src/Makefile"),
Vinstallation_directory);
tem1 = Ffile_exists_p (tem);
tem = Fexpand_file_name (build_string ("src/Makefile.in"),
Vinstallation_directory);
tem2 = Ffile_exists_p (tem);
if (!NILP (tem1) && NILP (tem2))
{
tem = Fexpand_file_name (build_string ("lisp"),
Vsource_directory);
if (NILP (Fmember (tem, Vload_path)))
Vload_path = nconc2 (Vload_path, Fcons (tem, Qnil));
tem = Fexpand_file_name (build_string ("leim"),
Vsource_directory);
if (NILP (Fmember (tem, Vload_path)))
Vload_path = nconc2 (Vload_path, Fcons (tem, Qnil));
tem = Fexpand_file_name (build_string ("site-lisp"),
Vsource_directory);
if (NILP (Fmember (tem, Vload_path)))
Vload_path = nconc2 (Vload_path, Fcons (tem, Qnil));
}
}
}
}
}
else
{
Vload_path = decode_env_path (0, normal);
dump_path = Vload_path;
}
#endif
#ifndef WINDOWSNT
if (!turn_off_warning)
{
Lisp_Object path_tail;
for (path_tail = Vload_path;
!NILP (path_tail);
path_tail = XCDR (path_tail))
{
Lisp_Object dirfile;
dirfile = Fcar (path_tail);
if (STRINGP (dirfile))
{
dirfile = Fdirectory_file_name (dirfile);
if (access (XSTRING (dirfile)->data, 0) < 0)
dir_warning ("Warning: Lisp directory `%s' does not exist.\n",
XCAR (path_tail));
}
}
}
#endif
#ifndef CANNOT_DUMP
if (NILP (Vpurify_flag)
&& egetenv ("EMACSLOADPATH"))
#endif
Vload_path = decode_env_path ("EMACSLOADPATH", normal);
Vvalues = Qnil;
load_in_progress = 0;
Vload_file_name = Qnil;
load_descriptor_list = Qnil;
Vstandard_input = Qt;
Vloads_in_progress = Qnil;
}
void
dir_warning (format, dirname)
char *format;
Lisp_Object dirname;
{
char *buffer
= (char *) alloca (XSTRING (dirname)->size + strlen (format) + 5);
fprintf (stderr, format, XSTRING (dirname)->data);
sprintf (buffer, format, XSTRING (dirname)->data);
if (initialized)
message_dolog (buffer, strlen (buffer), 0, STRING_MULTIBYTE (dirname));
}
void
syms_of_lread ()
{
defsubr (&Sread);
defsubr (&Sread_from_string);
defsubr (&Sintern);
defsubr (&Sintern_soft);
defsubr (&Sunintern);
defsubr (&Sload);
defsubr (&Seval_buffer);
defsubr (&Seval_region);
defsubr (&Sread_char);
defsubr (&Sread_char_exclusive);
defsubr (&Sread_event);
defsubr (&Sget_file_char);
defsubr (&Smapatoms);
DEFVAR_LISP ("obarray", &Vobarray,
"Symbol table for use by `intern' and `read'.\n\
It is a vector whose length ought to be prime for best results.\n\
The vector's contents don't make sense if examined from Lisp programs;\n\
to find all the symbols in an obarray, use `mapatoms'.");
DEFVAR_LISP ("values", &Vvalues,
"List of values of all expressions which were read, evaluated and printed.\n\
Order is reverse chronological.");
DEFVAR_LISP ("standard-input", &Vstandard_input,
"Stream for read to get input from.\n\
See documentation of `read' for possible values.");
Vstandard_input = Qt;
DEFVAR_LISP ("load-path", &Vload_path,
"*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 by file `epaths.h' when Emacs was built.");
DEFVAR_BOOL ("load-in-progress", &load_in_progress,
"Non-nil iff inside of `load'.");
DEFVAR_LISP ("after-load-alist", &Vafter_load_alist,
"An alist of expressions to be evalled when particular files are loaded.\n\
Each element looks like (FILENAME FORMS...).\n\
When `load' is run and the file-name argument is FILENAME,\n\
the FORMS in the corresponding element are executed at the end of loading.\n\n\
FILENAME must match exactly! Normally FILENAME is the name of a library,\n\
with no directory specified, since that is how `load' is normally called.\n\
An error in FORMS does not undo the load,\n\
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)', `(require . FEATURE)',\n\
and `(autoload . SYMBOL)'.");
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 ("user-init-file", &Vuser_init_file,
"File name, including directory, of user's initialization file.\n\
If the file loaded had extension `.elc' and there was a corresponding `.el'\n\
file, this variable contains the name of the .el file, suitable for use\n\
by functions like `custom-save-all' which edit the init file.");
Vuser_init_file = 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_LISP ("load-source-file-function", &Vload_source_file_function,
"Function called in `load' for loading an Emacs lisp source file.\n\
This function is for doing code conversion before reading the source file.\n\
If nil, loading is done without any code conversion.\n\
Arguments are FULLNAME, FILE, NOERROR, NOMESSAGE, where\n\
FULLNAME is the full name of FILE.\n\
See `load' for the meaning of the remaining arguments.");
Vload_source_file_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_BOOL ("load-convert-to-unibyte", &load_convert_to_unibyte,
"Non-nil means `read' converts strings to unibyte whenever possible.\n\
This is normally bound by `load' and `eval-buffer' to control `read',\n\
and is not meant for users to change.");
load_convert_to_unibyte = 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
= Fexpand_file_name (build_string ("../"),
Fcar (decode_env_path (0, PATH_DUMPLOADSEARCH)));
DEFVAR_LISP ("preloaded-file-list", &Vpreloaded_file_list,
"List of files that were preloaded (when dumping Emacs).");
Vpreloaded_file_list = Qnil;
DEFVAR_LISP ("byte-boolean-vars", &Vbyte_boolean_vars,
"List of all DEFVAR_BOOL variables, used by the byte code optimizer.");
Vbyte_boolean_vars = Qnil;
DEFVAR_BOOL ("load-dangerous-libraries", &load_dangerous_libraries,
"Non-nil means load dangerous compiled Lisp files.\n\
Some versions of XEmacs use different byte codes than Emacs. These\n\
incompatible byte codes can make Emacs crash when it tries to execute\n\
them.");
load_dangerous_libraries = 0;
DEFVAR_LISP ("bytecomp-version-regexp", &Vbytecomp_version_regexp,
"Regular expression matching safe to load compiled Lisp files.\n\
When Emacs loads a compiled Lisp file, it reads the first 512 bytes\n\
from the file, and matches them against this regular expression.\n\
When the regular expression matches, the file is considered to be safe\n\
to load. See also `load-dangerous-libraries'.");
Vbytecomp_version_regexp
= build_string ("^;;;.\\(in Emacs version\\|bytecomp version FSF\\)");
DEFVAR_LISP ("recursive-load-depth-limit", &Vrecursive_load_depth_limit,
"Limit for depth of recursive loads.\n\
Value should be either an integer > 0 specifying the limit, or nil for\n\
no limit.");
Vrecursive_load_depth_limit = make_number (50);
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);
Qread_char = intern ("read-char");
staticpro (&Qread_char);
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);
Qinhibit_file_name_operation = intern ("inhibit-file-name-operation");
staticpro (&Qinhibit_file_name_operation);
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);
staticpro (&dump_path);
staticpro (&read_objects);
read_objects = Qnil;
staticpro (&seen_list);
Vloads_in_progress = Qnil;
staticpro (&Vloads_in_progress);
}