#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"
#include "coding.h"
#include "blockinput.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
#ifdef HAVE_FCNTL_H
#include <fcntl.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;
Lisp_Object Qeval_buffer_list, Veval_buffer_list;
Lisp_Object Qfile_truename, Qdo_after_load_evaluation;
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, Vload_suffixes, Vload_file_rep_suffixes;
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;
Lisp_Object Vread_with_symbol_positions;
Lisp_Object Vread_symbol_positions_list;
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 int readchar_count;
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;
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,
Lisp_Object, Lisp_Object));
static Lisp_Object load_unwind P_ ((Lisp_Object));
static Lisp_Object load_descriptor_unwind P_ ((Lisp_Object));
static void invalid_syntax P_ ((const char *, int)) NO_RETURN;
static void end_of_file_error P_ (()) NO_RETURN;
#define READCHAR readchar (readcharfun)
#define UNREAD(c) unreadchar (readcharfun, c)
static int
readchar (readcharfun)
Lisp_Object readcharfun;
{
Lisp_Object tem;
register int c;
readchar_count++;
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))
{
BLOCK_INPUT;
c = getc (instream);
#ifdef EINTR
while (c == EOF && ferror (instream) && errno == EINTR)
{
UNBLOCK_INPUT;
QUIT;
BLOCK_INPUT;
clearerr (instream);
c = getc (instream);
}
#endif
UNBLOCK_INPUT;
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;
{
readchar_count--;
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))
{
BLOCK_INPUT;
ungetc (c, instream);
UNBLOCK_INPUT;
}
else
call1 (readcharfun, make_number (c));
}
static Lisp_Object read_internal_start P_ ((Lisp_Object, Lisp_Object,
Lisp_Object));
static Lisp_Object read0 P_ ((Lisp_Object));
static Lisp_Object read1 P_ ((Lisp_Object, int *, int));
static Lisp_Object read_list P_ ((int, Lisp_Object));
static Lisp_Object read_vector P_ ((Lisp_Object, int));
static int read_multibyte P_ ((int, Lisp_Object));
static Lisp_Object substitute_object_recurse P_ ((Lisp_Object, Lisp_Object,
Lisp_Object));
static void substitute_object_in_subtree P_ ((Lisp_Object,
Lisp_Object));
static void substitute_in_interval P_ ((INTERVAL, Lisp_Object));
extern Lisp_Object read_char ();
Lisp_Object
read_filtered_event (no_switch_frame, ascii_required, error_nonascii,
input_method, seconds)
int no_switch_frame, ascii_required, error_nonascii, input_method;
Lisp_Object seconds;
{
Lisp_Object val, delayed_switch_frame;
EMACS_TIME end_time;
#ifdef HAVE_WINDOW_SYSTEM
if (display_hourglass_p)
cancel_hourglass ();
#endif
delayed_switch_frame = Qnil;
if (NUMBERP (seconds))
{
EMACS_TIME wait_time;
int sec, usec;
double duration = extract_float (seconds);
sec = (int) duration;
usec = (duration - sec) * 1000000;
EMACS_GET_TIME (end_time);
EMACS_SET_SECS_USECS (wait_time, sec, usec);
EMACS_ADD_TIME (end_time, end_time, wait_time);
}
retry:
val = read_char (0, 0, 0, (input_method ? Qnil : Qt), 0,
NUMBERP (seconds) ? &end_time : NULL);
if (BUFFERP (val))
goto retry;
if (no_switch_frame
&& EVENT_HAS_PARAMETERS (val)
&& EQ (EVENT_HEAD_KIND (EVENT_HEAD (val)), Qswitch_frame))
{
delayed_switch_frame = val;
goto retry;
}
if (ascii_required && !(NUMBERP (seconds) && NILP (val)))
{
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;
#if 0
#ifdef HAVE_WINDOW_SYSTEM
if (display_hourglass_p)
start_hourglass ();
#endif
#endif
return val;
}
DEFUN ("read-char", Fread_char, Sread_char, 0, 3, 0,
doc: )
(prompt, inherit_input_method, seconds)
Lisp_Object prompt, inherit_input_method, seconds;
{
if (! NILP (prompt))
message_with_string ("%s", prompt, 0);
return read_filtered_event (1, 1, 1, ! NILP (inherit_input_method), seconds);
}
DEFUN ("read-event", Fread_event, Sread_event, 0, 3, 0,
doc: )
(prompt, inherit_input_method, seconds)
Lisp_Object prompt, inherit_input_method, seconds;
{
if (! NILP (prompt))
message_with_string ("%s", prompt, 0);
return read_filtered_event (0, 0, 0, ! NILP (inherit_input_method), seconds);
}
DEFUN ("read-char-exclusive", Fread_char_exclusive, Sread_char_exclusive, 0, 3, 0,
doc: )
(prompt, inherit_input_method, seconds)
Lisp_Object prompt, inherit_input_method, seconds;
{
if (! NILP (prompt))
message_with_string ("%s", prompt, 0);
return read_filtered_event (1, 1, 0, ! NILP (inherit_input_method), seconds);
}
DEFUN ("get-file-char", Fget_file_char, Sget_file_char, 0, 0, 0,
doc: )
()
{
register Lisp_Object val;
BLOCK_INPUT;
XSETINT (val, getc (instream));
UNBLOCK_INPUT;
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;
}
static Lisp_Object
load_error_handler (data)
Lisp_Object data;
{
return Qnil;
}
DEFUN ("get-load-suffixes", Fget_load_suffixes, Sget_load_suffixes, 0, 0, 0,
doc: )
()
{
Lisp_Object lst = Qnil, suffixes = Vload_suffixes, suffix, ext;
while (CONSP (suffixes))
{
Lisp_Object exts = Vload_file_rep_suffixes;
suffix = XCAR (suffixes);
suffixes = XCDR (suffixes);
while (CONSP (exts))
{
ext = XCAR (exts);
exts = XCDR (exts);
lst = Fcons (concat2 (suffix, ext), lst);
}
}
return Fnreverse (lst);
}
DEFUN ("load", Fload, Sload, 1, 5, 0,
doc: )
(file, noerror, nomessage, nosuffix, must_suffix)
Lisp_Object file, noerror, nomessage, nosuffix, must_suffix;
{
register FILE *stream;
register int fd = -1;
int count = SPECPDL_INDEX ();
Lisp_Object temp;
struct gcpro gcpro1, gcpro2, gcpro3;
Lisp_Object found, efound, hist_file_name;
int newer = 0;
int compiled = 0;
Lisp_Object handler;
int safe_p = 1;
char *fmode = "r";
Lisp_Object tmp[2];
#ifdef DOS_NT
fmode = "rt";
#endif
CHECK_STRING (file);
if (! NILP (noerror))
{
file = internal_condition_case_1 (Fsubstitute_in_file_name, file,
Qt, load_error_handler);
if (NILP (file))
return Qnil;
}
else
file = Fsubstitute_in_file_name (file);
if (SCHARS (file) > 0)
{
int size = SBYTES (file);
found = Qnil;
GCPRO2 (file, found);
if (! NILP (must_suffix))
{
if (size > 3
&& !strcmp (SDATA (file) + size - 3, ".el"))
must_suffix = Qnil;
else if (size > 4
&& !strcmp (SDATA (file) + size - 4, ".elc"))
must_suffix = Qnil;
else if (! NILP (Ffile_name_directory (file)))
must_suffix = Qnil;
}
fd = openp (Vload_path, file,
(!NILP (nosuffix) ? Qnil
: !NILP (must_suffix) ? Fget_load_suffixes ()
: Fappend (2, (tmp[0] = Fget_load_suffixes (),
tmp[1] = Vload_file_rep_suffixes,
tmp))),
&found, Qnil);
UNGCPRO;
}
if (fd == -1)
{
if (NILP (noerror))
xsignal2 (Qfile_error, build_string ("Cannot open load file"), file);
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);
}
{
int count = 0;
Lisp_Object tem;
for (tem = Vloads_in_progress; CONSP (tem); tem = XCDR (tem))
if (!NILP (Fequal (found, XCAR (tem))))
count++;
if (count > 3)
{
if (fd >= 0)
emacs_close (fd);
signal_error ("Recursive load", Fcons (found, Vloads_in_progress));
}
record_unwind_protect (record_load_unwind, Vloads_in_progress);
Vloads_in_progress = Fcons (found, Vloads_in_progress);
}
hist_file_name = (! NILP (Vpurify_flag)
? Fconcat (2, (tmp[0] = Ffile_name_directory (file),
tmp[1] = Ffile_name_nondirectory (found),
tmp))
: found) ;
if (!bcmp (SDATA (found) + SBYTES (found) - 4,
".elc", 4))
{
if (fd != -2)
{
struct stat s1, s2;
int result;
GCPRO3 (file, found, hist_file_name);
if (!safe_to_load_p (fd))
{
safe_p = 0;
if (!load_dangerous_libraries)
{
if (fd >= 0)
emacs_close (fd);
error ("File `%s' was not compiled in Emacs",
SDATA (found));
}
else if (!NILP (nomessage))
message_with_string ("File `%s' not compiled in Emacs", found, 1);
}
compiled = 1;
efound = ENCODE_FILE (found);
#ifdef DOS_NT
fmode = "rb";
#endif
stat ((char *)SDATA (efound), &s1);
SSET (efound, SBYTES (efound) - 1, 0);
result = stat ((char *)SDATA (efound), &s2);
SSET (efound, SBYTES (efound) - 1, 'c');
if (result >= 0 && (unsigned) s1.st_mtime < (unsigned) s2.st_mtime)
{
newer = 1;
if (!NILP (nomessage))
{
Lisp_Object msg_file;
msg_file = Fsubstring (found, make_number (0), make_number (-1));
message_with_string ("Source file `%s' newer than byte-compiled file",
msg_file, 1);
}
}
UNGCPRO;
}
}
else
{
if (!NILP (Vload_source_file_function))
{
Lisp_Object val;
if (fd >= 0)
emacs_close (fd);
val = call4 (Vload_source_file_function, found, hist_file_name,
NILP (noerror) ? Qnil : Qt,
NILP (nomessage) ? Qnil : Qt);
return unbind_to (count, val);
}
}
GCPRO3 (file, found, hist_file_name);
#ifdef WINDOWSNT
emacs_close (fd);
efound = ENCODE_FILE (found);
stream = fopen ((char *) SDATA (efound), fmode);
#else
stream = fdopen (fd, fmode);
#endif
if (stream == 0)
{
emacs_close (fd);
error ("Failure to create stdio stream for %s", SDATA (file));
}
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);
}
record_unwind_protect (load_unwind, make_save_value (stream, 0));
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, hist_file_name,
Feval, 0, Qnil, Qnil, Qnil, Qnil);
unbind_to (count, Qnil);
if (NILP (Vpurify_flag)
&& (!NILP (Ffboundp (Qdo_after_load_evaluation))))
call1 (Qdo_after_load_evaluation, hist_file_name) ;
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);
}
if (!NILP (Fequal (build_string ("obsolete"),
Ffile_name_nondirectory
(Fdirectory_file_name (Ffile_name_directory (found))))))
message_with_string ("Package %s is obsolete", file, 1);
return Qt;
}
static Lisp_Object
load_unwind (arg)
Lisp_Object arg;
{
FILE *stream = (FILE *) XSAVE_VALUE (arg)->pointer;
if (stream != NULL)
{
BLOCK_INPUT;
fclose (stream);
UNBLOCK_INPUT;
}
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 const unsigned char *s = SDATA (pathname);
return (IS_DIRECTORY_SEP (s[0])
|| (SCHARS (pathname) > 2
&& IS_DEVICE_SEP (s[1]) && IS_DIRECTORY_SEP (s[2]))
#ifdef ALTOS
|| *s == '@'
#endif
#ifdef VMS
|| index (s, ':')
#endif
);
}
DEFUN ("locate-file-internal", Flocate_file_internal, Slocate_file_internal, 2, 4, 0,
doc: )
(filename, path, suffixes, predicate)
Lisp_Object filename, path, suffixes, predicate;
{
Lisp_Object file;
int fd = openp (path, filename, suffixes, &file, predicate);
if (NILP (predicate) && fd > 0)
close (fd);
return file;
}
int
openp (path, str, suffixes, storeptr, predicate)
Lisp_Object path, str;
Lisp_Object suffixes;
Lisp_Object *storeptr;
Lisp_Object predicate;
{
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, gcpro4, gcpro5, gcpro6;
Lisp_Object string, tail, encoded_fn;
int max_suffix_len = 0;
CHECK_STRING (str);
for (tail = suffixes; CONSP (tail); tail = XCDR (tail))
{
CHECK_STRING_CAR (tail);
max_suffix_len = max (max_suffix_len,
SBYTES (XCAR (tail)));
}
string = filename = encoded_fn = Qnil;
GCPRO6 (str, string, filename, path, suffixes, encoded_fn);
if (storeptr)
*storeptr = Qnil;
if (complete_filename_p (str))
absolute = 1;
for (; CONSP (path); path = XCDR (path))
{
filename = Fexpand_file_name (str, XCAR (path));
if (!complete_filename_p (filename))
{
filename = Fexpand_file_name (filename, current_buffer->directory);
if (!complete_filename_p (filename))
continue;
}
want_size = max_suffix_len + SBYTES (filename) + 1;
if (fn_size < want_size)
fn = (char *) alloca (fn_size = 100 + want_size);
for (tail = NILP (suffixes) ? Fcons (build_string (""), Qnil) : suffixes;
CONSP (tail); tail = XCDR (tail))
{
int lsuffix = SBYTES (XCAR (tail));
Lisp_Object handler;
int exists;
if (SCHARS (filename) > 2
&& SREF (filename, 0) == '/'
&& SREF (filename, 1) == ':')
{
strncpy (fn, SDATA (filename) + 2,
SBYTES (filename) - 2);
fn[SBYTES (filename) - 2] = 0;
}
else
{
strncpy (fn, SDATA (filename),
SBYTES (filename));
fn[SBYTES (filename)] = 0;
}
if (lsuffix != 0)
strlcat (fn, SDATA (XCAR (tail)), fn_size);
string = build_string (fn);
handler = Ffind_file_name_handler (string, Qfile_exists_p);
if ((!NILP (handler) || !NILP (predicate)) && !NATNUMP (predicate))
{
if (NILP (predicate))
exists = !NILP (Ffile_readable_p (string));
else
exists = !NILP (call1 (predicate, string));
if (exists && !NILP (Ffile_directory_p (string)))
exists = 0;
if (exists)
{
if (storeptr)
*storeptr = string;
UNGCPRO;
return -2;
}
}
else
{
const char *pfn;
encoded_fn = ENCODE_FILE (string);
pfn = SDATA (encoded_fn);
exists = (stat (pfn, &st) >= 0
&& (st.st_mode & S_IFMT) != S_IFDIR);
if (exists)
{
if (NATNUMP (predicate))
fd = (access (pfn, XFASTINT (predicate)) == 0) ? 1 : -1;
else
fd = emacs_open (pfn, O_RDONLY, 0);
if (fd >= 0)
{
if (storeptr)
*storeptr = string;
UNGCPRO;
return fd;
}
}
}
}
if (absolute)
break;
}
UNGCPRO;
return -1;
}
static void
build_load_history (filename, entire)
Lisp_Object filename;
int entire;
{
register Lisp_Object tail, prev, newelt;
register Lisp_Object tem, tem2;
register int foundit = 0;
tail = Vload_history;
prev = Qnil;
while (CONSP (tail))
{
tem = XCAR (tail);
if (!NILP (Fequal (filename, Fcar (tem))))
{
foundit = 1;
if (entire)
{
if (NILP (prev))
Vload_history = XCDR (tail);
else
Fsetcdr (prev, XCDR (tail));
}
else
{
tem2 = Vcurrent_load_list;
while (CONSP (tem2))
{
newelt = XCAR (tem2);
if (NILP (Fmember (newelt, tem)))
Fsetcar (tail, Fcons (XCAR (tem),
Fcons (newelt, XCDR (tem))));
tem2 = XCDR (tem2);
QUIT;
}
}
}
else
prev = tail;
tail = XCDR (tail);
QUIT;
}
if (entire || !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))
xsignal1 (Qend_of_file, Vload_file_name);
xsignal0 (Qend_of_file);
}
static void
readevalloop (readcharfun, stream, sourcename, evalfun,
printflag, unibyte, readfun, start, end)
Lisp_Object readcharfun;
FILE *stream;
Lisp_Object sourcename;
Lisp_Object (*evalfun) ();
int printflag;
Lisp_Object unibyte, readfun;
Lisp_Object start, end;
{
register int c;
register Lisp_Object val;
int count = SPECPDL_INDEX ();
struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
struct buffer *b = 0;
int continue_reading_p;
int whole_buffer = 0;
int first_sexp = 1;
if (MARKERP (readcharfun))
{
if (NILP (start))
start = readcharfun;
}
if (BUFFERP (readcharfun))
b = XBUFFER (readcharfun);
else if (MARKERP (readcharfun))
b = XMARKER (readcharfun)->buffer;
if (! NILP (start) && !b)
abort ();
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;
GCPRO4 (sourcename, readfun, start, end);
if (NILP (Vpurify_flag)
&& !NILP (sourcename) && !NILP (Ffile_name_absolute_p (sourcename))
&& !NILP (Ffboundp (Qfile_truename)))
sourcename = call1 (Qfile_truename, sourcename) ;
LOADHIST_ATTACH (sourcename);
continue_reading_p = 1;
while (continue_reading_p)
{
int count1 = SPECPDL_INDEX ();
if (b != 0 && NILP (b->name))
error ("Reading from killed buffer");
if (!NILP (start))
{
record_unwind_protect (save_excursion_restore, save_excursion_save ());
set_buffer_internal (b);
record_unwind_protect (save_excursion_restore, save_excursion_save ());
record_unwind_protect (save_restriction_restore, save_restriction_save ());
Fgoto_char (start);
if (!NILP (end))
Fnarrow_to_region (make_number (BEGV), end);
if (INTEGERP (end))
end = Fpoint_max_marker ();
}
if (b && first_sexp)
whole_buffer = (PT == BEG && ZV == Z);
instream = stream;
read_next:
c = READCHAR;
if (c == ';')
{
while ((c = READCHAR) != '\n' && c != -1);
goto read_next;
}
if (c < 0)
{
unbind_to (count1, Qnil);
break;
}
if (c == ' ' || c == '\t' || c == '\n' || c == '\f' || c == '\r')
goto read_next;
if (!NILP (Vpurify_flag) && c == '(')
{
record_unwind_protect (unreadpure, Qnil);
val = read_list (-1, readcharfun);
}
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 = read_internal_start (readcharfun, Qnil, Qnil);
}
if (!NILP (start) && continue_reading_p)
start = Fpoint_marker ();
unbind_to (count1, Qnil);
val = (*evalfun) (val);
if (printflag)
{
Vvalues = Fcons (val, Vvalues);
if (EQ (Vstandard_output, Qt))
Fprin1 (val, Qnil);
else
Fprint (val, Qnil);
}
first_sexp = 0;
}
build_load_history (sourcename,
stream || whole_buffer);
UNGCPRO;
unbind_to (count, Qnil);
}
DEFUN ("eval-buffer", Feval_buffer, Seval_buffer, 0, 5, "",
doc: )
(buffer, printflag, filename, unibyte, do_allow_print)
Lisp_Object buffer, printflag, filename, unibyte, do_allow_print;
{
int count = SPECPDL_INDEX ();
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 (Qeval_buffer_list, Fcons (buf, Veval_buffer_list));
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, Qnil, Qnil);
unbind_to (count, Qnil);
return Qnil;
}
DEFUN ("eval-region", Feval_region, Seval_region, 2, 4, "r",
doc: )
(start, end, printflag, read_function)
Lisp_Object start, end, printflag, read_function;
{
int count = SPECPDL_INDEX ();
Lisp_Object tem, cbuf;
cbuf = Fcurrent_buffer ();
if (NILP (printflag))
tem = Qsymbolp;
else
tem = printflag;
specbind (Qstandard_output, tem);
specbind (Qeval_buffer_list, Fcons (cbuf, Veval_buffer_list));
readevalloop (cbuf, 0, XBUFFER (cbuf)->filename, Feval,
!NILP (printflag), Qnil, read_function,
start, end);
return unbind_to (count, Qnil);
}
DEFUN ("read", Fread, Sread, 0, 1, 0,
doc: )
(stream)
Lisp_Object stream;
{
if (NILP (stream))
stream = Vstandard_input;
if (EQ (stream, Qt))
stream = Qread_char;
if (EQ (stream, Qread_char))
return Fread_minibuffer (build_string ("Lisp expression: "), Qnil);
return read_internal_start (stream, Qnil, Qnil);
}
DEFUN ("read-from-string", Fread_from_string, Sread_from_string, 1, 3, 0,
doc: )
(string, start, end)
Lisp_Object string, start, end;
{
Lisp_Object ret;
CHECK_STRING (string);
ret = read_internal_start (string, start, end);
return Fcons (ret, make_number (read_from_string_index));
}
static Lisp_Object
read_internal_start (stream, start, end)
Lisp_Object stream;
Lisp_Object start;
Lisp_Object end;
{
Lisp_Object retval;
readchar_backlog = -1;
readchar_count = 0;
new_backquote_flag = 0;
read_objects = Qnil;
if (EQ (Vread_with_symbol_positions, Qt)
|| EQ (Vread_with_symbol_positions, stream))
Vread_symbol_positions_list = Qnil;
if (STRINGP (stream))
{
int startval, endval;
if (NILP (end))
endval = SCHARS (stream);
else
{
CHECK_NUMBER (end);
endval = XINT (end);
if (endval < 0 || endval > SCHARS (stream))
args_out_of_range (stream, end);
}
if (NILP (start))
startval = 0;
else
{
CHECK_NUMBER (start);
startval = XINT (start);
if (startval < 0 || startval > endval)
args_out_of_range (stream, start);
}
read_from_string_index = startval;
read_from_string_index_byte = string_char_to_byte (stream, startval);
read_from_string_limit = endval;
}
retval = read0 (stream);
if (EQ (Vread_with_symbol_positions, Qt)
|| EQ (Vread_with_symbol_positions, stream))
Vread_symbol_positions_list = Fnreverse (Vread_symbol_positions_list);
return retval;
}
static void
invalid_syntax (s, n)
const char *s;
int n;
{
if (!n)
n = strlen (s);
xsignal1 (Qinvalid_read_syntax, make_string (s, n));
}
static Lisp_Object
read0 (readcharfun)
Lisp_Object readcharfun;
{
register Lisp_Object val;
int c;
val = read1 (readcharfun, &c, 0);
if (!c)
return val;
xsignal1 (Qinvalid_read_syntax,
Fmake_string (make_number (1), make_number (c)));
}
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;
if (c < 0)
return c;
str[len++] = c;
while ((c = READCHAR) >= 0xA0
&& len < MAX_MULTIBYTE_LENGTH)
{
str[len++] = c;
readchar_count--;
}
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, byterep)
Lisp_Object readcharfun;
int stringp;
int *byterep;
{
register int c = READCHAR;
int unicode_hex_count = 4;
*byterep = 0;
switch (c)
{
case -1:
end_of_file_error ();
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, byterep);
return c | meta_modifier;
case 'S':
c = READCHAR;
if (c != '-')
error ("Invalid escape character syntax");
c = READCHAR;
if (c == '\\')
c = read_escape (readcharfun, 0, byterep);
return c | shift_modifier;
case 'H':
c = READCHAR;
if (c != '-')
error ("Invalid escape character syntax");
c = READCHAR;
if (c == '\\')
c = read_escape (readcharfun, 0, byterep);
return c | hyper_modifier;
case 'A':
c = READCHAR;
if (c != '-')
error ("Invalid escape character syntax");
c = READCHAR;
if (c == '\\')
c = read_escape (readcharfun, 0, byterep);
return c | alt_modifier;
case 's':
c = READCHAR;
if (c != '-')
{
UNREAD (c);
return ' ';
}
c = READCHAR;
if (c == '\\')
c = read_escape (readcharfun, 0, byterep);
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, byterep);
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;
}
}
*byterep = 1;
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;
}
}
*byterep = 2;
return i;
}
case 'U':
unicode_hex_count = 8;
case 'u':
{
int i = 0;
int count = 0;
Lisp_Object lisp_char;
struct gcpro gcpro1;
while (++count <= unicode_hex_count)
{
c = READCHAR;
if (c >= '0' && c <= '9') i = (i << 4) + (c - '0');
else if (c >= 'a' && c <= 'f') i = (i << 4) + (c - 'a') + 10;
else if (c >= 'A' && c <= 'F') i = (i << 4) + (c - 'A') + 10;
else
{
error ("Non-hex digit used for Unicode escape");
break;
}
}
GCPRO1 (readcharfun);
lisp_char = call2 (intern ("decode-char"), intern ("ucs"),
make_number (i));
UNGCPRO;
if (NILP (lisp_char))
{
error ("Unsupported Unicode code point: U+%x", (unsigned)i);
}
return XFASTINT (lisp_char);
}
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);
invalid_syntax (buf, 0);
}
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 * max (read_buffer_size, nbytes);
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;
}
invalid_syntax ("#^^", 3);
}
invalid_syntax ("#^", 2);
}
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) + BOOL_VECTOR_BITS_PER_CHAR - 1)
/ BOOL_VECTOR_BITS_PER_CHAR);
UNREAD (c);
tmp = read1 (readcharfun, pch, first_in_list);
if (size_in_chars != SCHARS (tmp)
&& ! (XFASTINT (length)
== (SCHARS (tmp) - 1) * BOOL_VECTOR_BITS_PER_CHAR))
invalid_syntax ("#&...", 5);
val = Fmake_bool_vector (length, Qnil);
bcopy (SDATA (tmp), XBOOL_VECTOR (val)->data,
size_in_chars);
if (XINT (length) != size_in_chars * BOOL_VECTOR_BITS_PER_CHAR)
XBOOL_VECTOR (val)->data[size_in_chars - 1]
&= (1 << (XINT (length) % BOOL_VECTOR_BITS_PER_CHAR)) - 1;
return val;
}
invalid_syntax ("#&...", 5);
}
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))
invalid_syntax ("#", 1);
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)
invalid_syntax ("Invalid string property list", 0);
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 == '!')
{
while (c != '\n' && c >= 0)
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);
invalid_syntax ("#", 1);
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++;
value = read0 (readcharfun);
new_backquote_flag--;
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--;
value = read0 (readcharfun);
new_backquote_flag++;
return Fcons (comma_type, Fcons (value, Qnil));
}
else
goto default_label;
case '?':
{
int discard;
int next_char;
int ok;
c = READCHAR;
if (c < 0)
end_of_file_error ();
if (c == ' ' || c == '\t')
return make_number (c);
if (c == '\\')
c = read_escape (readcharfun, 0, &discard);
else if (BASE_LEADING_CODE_P (c))
c = read_multibyte (c, readcharfun);
next_char = READCHAR;
if (next_char == '.')
{
int next_next_char = READCHAR;
UNREAD (next_next_char);
ok = (next_next_char <= 040
|| (next_next_char < 0200
&& (index ("\"';([#?", next_next_char)
|| (!first_in_list && next_next_char == '`')
|| (new_backquote_flag && next_next_char == ','))));
}
else
{
ok = (next_char <= 040
|| (next_char < 0200
&& (index ("\"';()[]#?", next_char)
|| (!first_in_list && next_char == '`')
|| (new_backquote_flag && next_char == ','))));
}
UNREAD (next_char);
if (ok)
return make_number (c);
invalid_syntax ("?", 1);
}
case '"':
{
char *p = read_buffer;
char *end = read_buffer + read_buffer_size;
register int c;
int force_multibyte = 0;
int force_singlebyte = 0;
int is_multibyte = 0;
int cancel = 0;
int nchars = 0;
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 == '\\')
{
int byterep;
c = read_escape (readcharfun, 1, &byterep);
if (c == -1)
{
if (p == read_buffer)
cancel = 1;
continue;
}
if (byterep == 1)
force_singlebyte = 1;
else if (byterep == 2)
force_multibyte = 1;
}
if (! SINGLE_BYTE_CHAR_P (c & ~CHAR_MODIFIER_MASK))
force_multibyte = 1;
if (force_multibyte && ! is_multibyte)
{
is_multibyte = 1;
to_multibyte (&p, &end, &nchars);
}
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 & CHAR_MODIFIER_MASK)
error ("Invalid modifier in string");
if (is_multibyte)
p += CHAR_STRING (c, p);
else
*p++ = c;
nchars++;
}
if (c < 0)
end_of_file_error ();
if (!NILP (Vpurify_flag) && NILP (Vdoc_file_name) && cancel)
return make_number (0);
if (is_multibyte || force_singlebyte)
;
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);
}
is_multibyte = 0;
}
else if (EQ (readcharfun, Qget_file_char)
|| EQ (readcharfun, Qlambda))
{
to_multibyte (&p, &end, &nchars);
is_multibyte = (p - read_buffer) != nchars;
}
else
;
if (read_pure)
return make_pure_string (read_buffer, nchars, p - read_buffer,
is_multibyte);
return make_specified_string (read_buffer, nchars, p - read_buffer,
is_multibyte);
}
case '.':
{
int next_char = READCHAR;
UNREAD (next_char);
if (next_char <= 040
|| (next_char < 0200
&& (index ("\"';([#?", next_char)
|| (!first_in_list && next_char == '`')
|| (new_backquote_flag && 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 >= 0200
|| (!index ("\"';()[]#", c)
&& !(!first_in_list && c == '`')
&& !(new_backquote_flag && 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;
{
int i;
union { double d; char c[sizeof (double)]; } u_data, u_minus_zero;
u_data.d = value;
u_minus_zero.d = - 0.0;
for (i = 0; i < sizeof (double); i++)
if (u_data.c[i] & u_minus_zero.c[i])
{
value = - value;
break;
}
}
break;
default:
value = atof (read_buffer + negative);
break;
}
return make_float (negative ? - value : value);
}
}
{
Lisp_Object result = uninterned_symbol ? make_symbol (read_buffer)
: intern (read_buffer);
if (EQ (Vread_with_symbol_positions, Qt)
|| EQ (Vread_with_symbol_positions, readcharfun))
Vread_symbol_positions_list =
Fcons (Fcons (result,
make_number (readchar_count
- XFASTINT (Flength (Fsymbol_name (result))))),
Vread_symbol_positions_list);
return result;
}
}
}
}
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 = STRING_INTERVALS (subtree);
Lisp_Object arg = Fcons (object, placeholder);
traverse_intervals_noorder (root_interval,
&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))
{
STRING_SET_CHARS (bytestr, SBYTES (bytestr));
STRING_SET_UNIBYTE (bytestr);
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;
invalid_syntax (") or . in a vector", 18);
}
if (ch == ')')
return val;
if (ch == '.')
{
GCPRO2 (val, tail);
if (!NILP (tail))
XSETCDR (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;
}
invalid_syntax (". in wrong context", 18);
}
invalid_syntax ("] in a list", 11);
}
tem = (read_pure && flag <= 0
? pure_cons (elt, Qnil)
: Fcons (elt, Qnil));
if (!NILP (tail))
XSETCDR (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
check_obarray (obarray)
Lisp_Object obarray;
{
if (!VECTORP (obarray) || XVECTOR (obarray)->size == 0)
{
if (EQ (Vobarray, obarray)) Vobarray = initial_obarray;
wrong_type_argument (Qvectorp, obarray);
}
return obarray;
}
Lisp_Object
intern (str)
const 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,
doc: )
(string, obarray)
Lisp_Object string, obarray;
{
register Lisp_Object tem, sym, *ptr;
if (NILP (obarray)) obarray = Vobarray;
obarray = check_obarray (obarray);
CHECK_STRING (string);
tem = oblookup (obarray, SDATA (string),
SCHARS (string),
SBYTES (string));
if (!INTEGERP (tem))
return tem;
if (!NILP (Vpurify_flag))
string = Fpurecopy (string);
sym = Fmake_symbol (string);
if (EQ (obarray, initial_obarray))
XSYMBOL (sym)->interned = SYMBOL_INTERNED_IN_INITIAL_OBARRAY;
else
XSYMBOL (sym)->interned = SYMBOL_INTERNED;
if ((SREF (string, 0) == ':')
&& EQ (obarray, initial_obarray))
{
XSYMBOL (sym)->constant = 1;
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,
doc: )
(name, obarray)
Lisp_Object name, obarray;
{
register Lisp_Object tem, string;
if (NILP (obarray)) obarray = Vobarray;
obarray = check_obarray (obarray);
if (!SYMBOLP (name))
{
CHECK_STRING (name);
string = name;
}
else
string = SYMBOL_NAME (name);
tem = oblookup (obarray, SDATA (string), SCHARS (string), SBYTES (string));
if (INTEGERP (tem) || (SYMBOLP (name) && !EQ (name, tem)))
return Qnil;
else
return tem;
}
DEFUN ("unintern", Funintern, Sunintern, 1, 2, 0,
doc: )
(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))
string = SYMBOL_NAME (name);
else
{
CHECK_STRING (name);
string = name;
}
tem = oblookup (obarray, SDATA (string),
SCHARS (string),
SBYTES (string));
if (INTEGERP (tem))
return Qnil;
if (SYMBOLP (name) && !EQ (name, tem))
return Qnil;
XSYMBOL (tem)->interned = SYMBOL_UNINTERNED;
XSYMBOL (tem)->constant = 0;
XSYMBOL (tem)->indirect_variable = 0;
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 const 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 (EQ (bucket, make_number (0)))
;
else if (!SYMBOLP (bucket))
error ("Bad data in guts of obarray");
else
for (tail = bucket; ; XSETSYMBOL (tail, XSYMBOL (tail)->next))
{
if (SBYTES (SYMBOL_NAME (tail)) == size_byte
&& SCHARS (SYMBOL_NAME (tail)) == size
&& !bcmp (SDATA (SYMBOL_NAME (tail)), ptr, size_byte))
return tail;
else if (XSYMBOL (tail)->next == 0)
break;
}
XSETINT (tem, hash);
return tem;
}
static int
hash_string (ptr, len)
const unsigned char *ptr;
int len;
{
register const unsigned char *p = ptr;
register const 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);
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,
doc: )
(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)->interned = SYMBOL_INTERNED_IN_INITIAL_OBARRAY;
XSYMBOL (Qnil)->constant = 1;
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;
XSYMBOL (Qt)->constant = 1;
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;
EMACS_INT *address;
{
Lisp_Object sym, val;
sym = intern (namestring);
val = allocate_misc ();
XMISCTYPE (val) = Lisp_Misc_Intfwd;
XINTFWD (val)->intvar = address;
SET_SYMBOL_VALUE (sym, 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;
SET_SYMBOL_VALUE (sym, 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;
SET_SYMBOL_VALUE (sym, 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;
sym = intern (namestring);
val = allocate_misc ();
offset = (char *)address - (char *)current_buffer;
XMISCTYPE (val) = Lisp_Misc_Buffer_Objfwd;
XBUFFER_OBJFWD (val)->offset = offset;
SET_SYMBOL_VALUE (sym, 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;
SET_SYMBOL_VALUE (sym, 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
#ifdef EMACS_UNDUMPED
normal = PATH_LOADSEARCH;
#else
normal = PATH_DUMPLOADSEARCH;
#endif
if (initialized)
{
if (! NILP (Fequal (dump_path, Vload_path)))
{
Vload_path = decode_env_path (0, normal);
if (!NILP (Vinstallation_directory))
{
Lisp_Object tem, tem1, sitelisp;
sitelisp = Qnil;
while (1)
{
tem = Fcar (Vload_path);
tem1 = Fstring_match (build_string ("site-lisp"),
tem, Qnil);
if (!NILP (tem1))
{
Vload_path = Fcdr (Vload_path);
sitelisp = Fcons (tem, sitelisp);
}
else
break;
}
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 = Fcons (tem, Vload_path);
}
}
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 = Fcons (tem, Vload_path);
}
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 = Fcons (tem, Vload_path);
}
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 = Fcons (tem, Vload_path);
tem = Fexpand_file_name (build_string ("leim"),
Vsource_directory);
if (NILP (Fmember (tem, Vload_path)))
Vload_path = Fcons (tem, Vload_path);
tem = Fexpand_file_name (build_string ("site-lisp"),
Vsource_directory);
if (NILP (Fmember (tem, Vload_path)))
Vload_path = Fcons (tem, Vload_path);
}
}
if (!NILP (sitelisp))
Vload_path = nconc2 (Fnreverse (sitelisp), Vload_path);
}
}
}
else
{
Vload_path = decode_env_path (0, normal);
dump_path = Vload_path;
}
#endif
#if (!(defined(WINDOWSNT) || (defined(HAVE_CARBON))))
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 (SDATA (dirfile), 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 (SCHARS (dirname) + strlen (format) + 5);
fprintf (stderr, format, SDATA (dirname));
sprintf (buffer, format, SDATA (dirname));
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 (&Sget_load_suffixes);
defsubr (&Sload);
defsubr (&Seval_buffer);
defsubr (&Seval_region);
defsubr (&Sread_char);
defsubr (&Sread_char_exclusive);
defsubr (&Sread_event);
defsubr (&Sget_file_char);
defsubr (&Smapatoms);
defsubr (&Slocate_file_internal);
DEFVAR_LISP ("obarray", &Vobarray,
doc: );
DEFVAR_LISP ("values", &Vvalues,
doc: );
DEFVAR_LISP ("standard-input", &Vstandard_input,
doc: );
Vstandard_input = Qt;
DEFVAR_LISP ("read-with-symbol-positions", &Vread_with_symbol_positions,
doc: );
Vread_with_symbol_positions = Qnil;
DEFVAR_LISP ("read-symbol-positions-list", &Vread_symbol_positions_list,
doc: );
Vread_symbol_positions_list = Qnil;
DEFVAR_LISP ("load-path", &Vload_path,
doc: );
DEFVAR_LISP ("load-suffixes", &Vload_suffixes,
doc: );
Vload_suffixes = Fcons (build_string (".elc"),
Fcons (build_string (".el"), Qnil));
DEFVAR_LISP ("load-file-rep-suffixes", &Vload_file_rep_suffixes,
doc: );
Vload_file_rep_suffixes = Fcons (build_string (""), Qnil);
DEFVAR_BOOL ("load-in-progress", &load_in_progress,
doc: );
DEFVAR_LISP ("after-load-alist", &Vafter_load_alist,
doc: );
Vafter_load_alist = Qnil;
DEFVAR_LISP ("load-history", &Vload_history,
doc: );
Vload_history = Qnil;
DEFVAR_LISP ("load-file-name", &Vload_file_name,
doc: );
Vload_file_name = Qnil;
DEFVAR_LISP ("user-init-file", &Vuser_init_file,
doc: );
Vuser_init_file = Qnil;
DEFVAR_LISP ("current-load-list", &Vcurrent_load_list,
doc: );
Vcurrent_load_list = Qnil;
DEFVAR_LISP ("load-read-function", &Vload_read_function,
doc: );
Vload_read_function = Qnil;
DEFVAR_LISP ("load-source-file-function", &Vload_source_file_function,
doc: );
Vload_source_file_function = Qnil;
DEFVAR_BOOL ("load-force-doc-strings", &load_force_doc_strings,
doc: );
load_force_doc_strings = 0;
DEFVAR_BOOL ("load-convert-to-unibyte", &load_convert_to_unibyte,
doc: );
load_convert_to_unibyte = 0;
DEFVAR_LISP ("source-directory", &Vsource_directory,
doc: );
Vsource_directory
= Fexpand_file_name (build_string ("../"),
Fcar (decode_env_path (0, PATH_DUMPLOADSEARCH)));
DEFVAR_LISP ("preloaded-file-list", &Vpreloaded_file_list,
doc: );
Vpreloaded_file_list = Qnil;
DEFVAR_LISP ("byte-boolean-vars", &Vbyte_boolean_vars,
doc: );
Vbyte_boolean_vars = Qnil;
DEFVAR_BOOL ("load-dangerous-libraries", &load_dangerous_libraries,
doc: );
load_dangerous_libraries = 0;
DEFVAR_LISP ("bytecomp-version-regexp", &Vbytecomp_version_regexp,
doc: );
Vbytecomp_version_regexp
= build_string ("^;;;.\\(in Emacs version\\|bytecomp version FSF\\)");
DEFVAR_LISP ("eval-buffer-list", &Veval_buffer_list,
doc: );
Veval_buffer_list = 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);
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);
Qeval_buffer_list = intern ("eval-buffer-list");
staticpro (&Qeval_buffer_list);
Qfile_truename = intern ("file-truename");
staticpro (&Qfile_truename) ;
Qdo_after_load_evaluation = intern ("do-after-load-evaluation");
staticpro (&Qdo_after_load_evaluation) ;
staticpro (&dump_path);
staticpro (&read_objects);
read_objects = Qnil;
staticpro (&seen_list);
seen_list = Qnil;
Vloads_in_progress = Qnil;
staticpro (&Vloads_in_progress);
}