This is lread.c in view mode; [Download] [Up]
/* Lisp parsing and input streams.
Copyright (C) 1985-1989, 1992-1994 Free Software Foundation, Inc.
Copyright (C) 1995 Amdahl Corporation.
Copyright (C) 1995 Tinker Systems
This file is part of XEmacs.
XEmacs is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by the
Free Software Foundation; either version 2, or (at your option) any
later version.
XEmacs is distributed in the hope that it will be useful, but WITHOUT
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
for more details.
You should have received a copy of the GNU General Public License
along with XEmacs; see the file COPYING. If not, write to the Free
Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
/* Synched up with: Mule 2.0. Synched with FSF 19.28 only as far as
Fload_internal (). */
/* This file has been Mule-ized. */
#include <config.h>
#include "lisp.h"
#ifndef standalone
#include "buffer.h"
#include "bytecode.h"
#include "commands.h"
#include "insdel.h"
#include "lstream.h"
#include "paths.h"
#endif
#include "sysfile.h"
#ifdef LISP_FLOAT_TYPE
#define THIS_FILENAME lread
#include "sysfloat.h"
#endif /* LISP_FLOAT_TYPE */
Lisp_Object Qread_char, Qstandard_input;
Lisp_Object Qvariable_documentation;
#define LISP_BACKQUOTES
#ifdef LISP_BACKQUOTES
#include "opaque.h"
static int reading_backquote, reading_old_backquote;
Lisp_Object Qbackquote, Qbacktick, Qcomma, Qcomma_at;
#endif
Lisp_Object Qvariable_domain; /* I18N3 */
Lisp_Object Vvalues, Vstandard_input, Vafter_load_alist;
Lisp_Object Qcurrent_load_list;
Lisp_Object Qload;
Lisp_Object Qlocate_file_hash_table;
int puke_on_fsf_keys;
/* non-zero if inside `load' */
int load_in_progress;
/* Whether Fload_internal() should check whether the .el is newer
when loading .elc */
int load_warn_when_source_newer;
/* Whether Fload_internal() should check whether the .elc doesn't exist */
int load_warn_when_source_only;
/* Whether Fload_internal() should ignore .elc files when no suffix is given */
int load_ignore_elc_files;
/* Search path for files to be loaded. */
Lisp_Object Vload_path;
/* Search path for files when dumping. */
/* Lisp_Object Vdump_load_path; */
/* This is the user-visible association list that maps features to
lists of defs in their load files. */
Lisp_Object Vload_history;
/* This is used to build the load history. */
Lisp_Object Vcurrent_load_list;
/* List of descriptors now open for Fload_internal. */
static Lisp_Object load_descriptor_list;
/* A resizing-buffer stream used to temporarily hold data while reading */
static Lisp_Object Vread_buffer_stream;
static DOESNT_RETURN
syntax_error (CONST char *string)
{
signal_error (Qinvalid_read_syntax,
list1 (build_translated_string (string)));
}
static Lisp_Object
continuable_syntax_error (CONST char *string)
{
return Fsignal (Qinvalid_read_syntax,
list1 (build_translated_string (string)));
}
/* Handle unreading and rereading of characters. */
static Emchar
readchar (Lisp_Object readcharfun)
{
/* This function can GC */
if (BUFFERP (readcharfun))
{
Emchar c;
struct buffer *b = XBUFFER (readcharfun);
if (!BUFFER_LIVE_P (b))
error ("Reading from killed buffer");
if (BUF_PT (b) >= BUF_ZV (b))
return -1;
c = BUF_FETCH_CHAR (b, BUF_PT (b));
BUF_SET_PT (b, BUF_PT (b) + 1);
return c;
}
else if (LSTREAMP (readcharfun))
{
return Lstream_get_emchar (XLSTREAM (readcharfun));
}
else if (MARKERP (readcharfun))
{
Emchar c;
Bufpos mpos = marker_position (readcharfun);
struct buffer *inbuffer = XMARKER (readcharfun)->buffer;
if (mpos >= BUF_ZV (inbuffer))
return -1;
c = BUF_FETCH_CHAR (inbuffer, mpos);
set_marker_position (readcharfun, mpos + 1);
return c;
}
else
{
Lisp_Object tem = call0 (readcharfun);
if (NILP (tem))
return -1;
return XINT (tem);
}
}
/* Unread the character C in the way appropriate for the stream READCHARFUN.
If the stream is a user function, call it with the char as argument. */
static void
unreadchar (Lisp_Object readcharfun, Emchar c)
{
if (c == -1)
/* Don't back up the pointer if we're unreading the end-of-input mark,
since readchar didn't advance it when we read it. */
;
else if (BUFFERP (readcharfun))
{
BUF_SET_PT (XBUFFER (readcharfun), BUF_PT (XBUFFER (readcharfun)) - 1);
}
else if (LSTREAMP (readcharfun))
{
Lstream_unget_emchar (XLSTREAM (readcharfun), c);
}
else if (MARKERP (readcharfun))
set_marker_position (readcharfun, marker_position (readcharfun) - 1);
else
call1 (readcharfun, make_number (c));
}
static Lisp_Object read0 (Lisp_Object readcharfun);
static Lisp_Object read1 (Lisp_Object readcharfun);
/* flag = 1 means check for ] to terminate rather than ) and .
flag = -1 means check for starting with defun
and make structure pure. */
static Lisp_Object read_list (Lisp_Object readcharfun,
Emchar terminator,
int allow_dotted_lists);
/* get a character from the tty */
#ifdef standalone /* This primitive is normally not defined */
#define kludge DEFUN /* to keep this away from make-docfile... */
kludge ("read-char", Fread_char, Sread_char, 0, 0, 0, "") ()
{
return getchar ();
}
#undef kludge
#endif /* standalone */
static void readevalloop (Lisp_Object readcharfun,
Lisp_Object sourcefile,
Lisp_Object (*evalfun) (Lisp_Object),
int printflag);
static Lisp_Object
load_unwind (Lisp_Object stream) /* used as unwind-protect function in load */
{
Lstream_close (XLSTREAM (stream));
if (--load_in_progress < 0)
load_in_progress = 0;
return Qnil;
}
static Lisp_Object
load_descriptor_unwind (Lisp_Object oldlist)
{
load_descriptor_list = oldlist;
return Qnil;
}
/* Close all descriptors in use for Fload_internals.
This is used when starting a subprocess. */
void
close_load_descs (void)
{
Lisp_Object tail;
LIST_LOOP (tail, load_descriptor_list)
close (XINT (XCAR (tail)));
}
#ifdef I18N3
Lisp_Object Vfile_domain;
Lisp_Object
restore_file_domain (Lisp_Object val)
{
Vfile_domain = val;
return Qnil;
}
#endif /* I18N3 */
DEFUN ("load-internal", Fload_internal, Sload_internal, 1, 4, 0,
"Execute a file of Lisp code named FILE.\n\
First try LIBRARY with `.elc' appended, then try with `.el',\n\
then try LIBRARY unmodified.\n\
This function searches the directories in `load-path'.\n\
If optional second arg NOERROR is non-nil,\n\
report no error if LIBRARY doesn't exist.\n\
Print messages at start and end of loading unless\n\
optional third arg NOMESSAGE is non-nil (ignored in -batch mode).\n\
If optional fourth arg NOSUFFIX is non-nil, don't try adding\n\
suffixes `.elc' or `.el' to the specified name LIBRARY.\n\
Return t if file exists.")
(library, no_error, nomessage, nosuffix)
Lisp_Object library, no_error, nomessage, nosuffix;
{
/* This function can GC */
FILE *stream;
int fd = -1;
int speccount = specpdl_depth ();
Lisp_Object newer = Qnil;
int source_only = 0;
Lisp_Object handler = Qnil;
struct gcpro gcpro1, gcpro2;
GCPRO2 (library, newer);
#ifdef MSDOS
char *dosmode = "rt";
#endif
CHECK_STRING (library, 0);
library = Fsubstitute_in_file_name (library);
/* If file name is magic, call the handler. */
handler = Ffind_file_name_handler (library, Qload);
if (!NILP (handler))
{
RETURN_UNGCPRO (call5 (handler, Qload, library, no_error, nomessage,
nosuffix));
}
/* Avoid weird lossage with null string as arg,
since it would try to load a directory as a Lisp file.
Unix truly sucks */
if (string_length (XSTRING (library)) > 0)
{
Lisp_Object found = Qnil;
char *foundstr;
int foundlen;
struct gcpro gcpro1;
fd = locate_file (Vload_path, library,
((!NILP (nosuffix)) ? "" :
load_ignore_elc_files ? ".el:" :
".elc:.el:"),
&found,
-1);
if (fd < 0)
{
if (NILP (no_error))
signal_file_error ("Cannot open load file", library);
else
{
UNGCPRO;
return Qnil;
}
}
GCPRO1 (found);
foundstr = (char *) alloca (string_length (XSTRING (found)) + 1);
strcpy (foundstr, (char *) string_data (XSTRING (found)));
foundlen = strlen (foundstr);
/* The omniscient JWZ thinks this is worthless, but I beg to
differ. --ben */
if (load_ignore_elc_files)
{
newer = Ffile_name_nondirectory (found);
}
else if (load_warn_when_source_newer &&
!memcmp (".elc", foundstr + foundlen - 4, 4))
{
struct stat s1, s2;
if (! fstat (fd, &s1)) /* can't fail, right? */
{
int result;
/* temporarily hack the 'c' off the end of the filename */
foundstr[foundlen - 1] = '\0';
result = stat (foundstr, &s2);
if (result >= 0 &&
(unsigned) s1.st_mtime < (unsigned) s2.st_mtime)
{
Lisp_Object newer_name = make_string ((Bufbyte *) foundstr,
foundlen - 1);
struct gcpro gcpro1;
GCPRO1 (newer_name);
newer = Ffile_name_nondirectory (newer_name);
UNGCPRO;
}
/* put the 'c' back on (kludge-o-rama) */
foundstr[foundlen - 1] = 'c';
}
}
else if (load_warn_when_source_only &&
/* `found' ends in ".el" */
!memcmp (".el", foundstr + foundlen - 3, 3) &&
/* `library' does not end in ".el" */
memcmp (".el",
string_data (XSTRING (library)) +
string_length (XSTRING (library)) - 3,
3))
{
source_only = 1;
}
UNGCPRO;
}
#ifdef MSDOS
if (!memcmp (".elc", foundstr + foundlen - 4, 4))
dosmode = "rb";
close (fd);
stream = fopen (foundstr, dosmode);
#else
stream = fdopen (fd, "r");
#endif
if (stream == 0)
{
close (fd);
error ("Failure to create stdio stream for %s",
string_data (XSTRING (library)));
}
if (load_ignore_elc_files)
{
if (noninteractive || NILP (nomessage))
message ("Loading %s...", string_data (XSTRING (newer)));
}
else if (!NILP (newer))
{
message ("Loading %s... (file %s is newer)",
string_data (XSTRING (library)),
string_data (XSTRING (newer)));
nomessage = Qnil; /* we printed the first one, so print "done" too */
}
else if (source_only)
{
message ("Loading %s... (file %s.elc does not exist)",
string_data (XSTRING (library)),
string_data (XSTRING (Ffile_name_nondirectory (library))));
nomessage = Qnil;
}
else if (noninteractive || NILP (nomessage))
message ("Loading %s...", string_data (XSTRING (library)));
{
/* Lisp_Object's must be malloc'ed, not stack-allocated */
Lisp_Object lispstream;
struct gcpro gcpro1;
#ifdef MULE
/* !!#### Need to make a Mule-encoding stream */
#endif
lispstream = make_stdio_stream (stream, LSTR_CLOSING);
/* 64K is used for normal files; 8K should be OK here because Lisp
files aren't really all that big. */
Lstream_set_buffering (XLSTREAM (lispstream), LSTREAM_BLOCKN_BUFFERED,
8192);
GCPRO1 (lispstream);
record_unwind_protect (load_unwind, lispstream);
record_unwind_protect (load_descriptor_unwind, load_descriptor_list);
load_descriptor_list
= Fcons (make_number (fileno (stream)), load_descriptor_list);
#ifdef I18N3
record_unwind_protect (restore_file_domain, Vfile_domain);
Vfile_domain = Qnil; /* set it to nil; a call to #'domain will set it. */
#endif
load_in_progress++;
readevalloop (lispstream, library, Feval, 0);
unbind_to (speccount, Qnil);
UNGCPRO;
}
{
Lisp_Object tem;
/* #### Disgusting kludge */
/* Run any load-hooks for this file. */
tem = Fassoc (library, Vafter_load_alist);
if (!NILP (tem))
{
struct gcpro gcpro1;
GCPRO1 (tem);
/* Use eval so that errors give a semi-meaningful backtrace. --Stig */
tem = Fcons (Qprogn, Fcdr (tem));
Feval (tem);
UNGCPRO;
}
}
if (noninteractive || !NILP (nomessage))
;
else if (!NILP (newer))
message ("Loading %s...done (file %s is newer)",
string_data (XSTRING (library)),
string_data (XSTRING (newer)));
else
message ("Loading %s...done", string_data (XSTRING (library)));
UNGCPRO;
return Qt;
}
DEFUN ("locate-file", Flocate_file, Slocate_file, 2, 4, 0,
"Search for FILENAME through PATH-LIST, expanded by one of the optional\n\
SUFFIXES (string of suffixes separated by \":\"s), checking for access\n\
MODE (0|1|2|4 = exists|executable|writeable|readable), default readable.\n\
\n\
`locate-file' keeps hash tables of the directories it searches through,\n\
in order to speed things up. It tries valiantly to not get confused in\n\
the face of a changing and unpredictable environment, but can occasionally\n\
get tripped up. In this case, you will have to call\n\
`locate-file-clear-hashing' to get it back on track. See that function\n\
for details.")
(file, path, suff, mode)
Lisp_Object file, path, suff, mode;
{
/* This function can GC */
Lisp_Object tp;
CHECK_STRING (file, 0);
if (!NILP (suff))
{
CHECK_STRING (suff, 0);
}
if (!(NILP (mode) || (INTP (mode) && XINT (mode) >= 0)))
mode = wrong_type_argument (Qnatnump, mode);
locate_file (path, file,
((NILP (suff)) ? "" : (char *) (string_data (XSTRING (suff)))),
&tp, (NILP (mode) ? R_OK : XINT (mode)));
return tp;
}
/* recalculate the hash table for the given string */
static Lisp_Object
locate_file_refresh_hashing (Lisp_Object str)
{
Lisp_Object hash =
make_directory_hash_table ((char *) string_data (XSTRING (str)));
Fput (str, Qlocate_file_hash_table, hash);
return hash;
}
/* find the hash table for the given string, recalculating if necessary */
static Lisp_Object
locate_file_find_directory_hash_table (Lisp_Object str)
{
Lisp_Object hash = Fget (str, Qlocate_file_hash_table, Qnil);
if (NILP (Fhashtablep (hash)))
return locate_file_refresh_hashing (str);
return hash;
}
/* look for STR in PATH, optionally adding suffixes in SUFFIX */
static int
locate_file_in_directory (Lisp_Object path, Lisp_Object str,
CONST char *suffix, Lisp_Object *storeptr,
int mode)
{
/* This function can GC */
int fd;
int fn_size = 100;
char buf[100];
char *fn = buf;
int want_size;
struct stat st;
Lisp_Object filename = Qnil;
struct gcpro gcpro1, gcpro2, gcpro3;
CONST char *nsuffix;
GCPRO3 (path, str, filename);
filename = Fexpand_file_name (str, path);
if (NILP (filename) || NILP (Ffile_name_absolute_p (filename)))
/* If there are non-absolute elts in PATH (eg ".") */
/* Of course, this could conceivably lose if luser sets
default-directory to be something non-absolute ... */
{
if (NILP (filename))
/* NIL means current dirctory */
filename = current_buffer->directory;
else
filename = Fexpand_file_name (filename,
current_buffer->directory);
if (NILP (Ffile_name_absolute_p (filename)))
{
/* Give up on this path element! */
UNGCPRO;
return -1;
}
}
/* Calculate maximum size of any filename made from
this path element/specified file name and any possible suffix. */
want_size = strlen (suffix) +
string_length (XSTRING (filename)) + 1;
if (fn_size < want_size)
fn = (char *) alloca (fn_size = 100 + want_size);
nsuffix = suffix;
/* Loop over suffixes. */
while (1)
{
char *esuffix = (char *) strchr (nsuffix, ':');
int lsuffix = ((esuffix) ? (esuffix - nsuffix) : strlen (nsuffix));
/* Concatenate path element/specified name with the suffix. */
strncpy (fn, (char *) string_data (XSTRING (filename)),
string_length (XSTRING (filename)));
fn[string_length (XSTRING (filename))] = 0;
if (lsuffix != 0) /* Bug happens on CCI if lsuffix is 0. */
strncat (fn, nsuffix, lsuffix);
/* Ignore file if it's a directory. */
if (stat (fn, &st) >= 0
&& (st.st_mode & S_IFMT) != S_IFDIR)
{
/* Check that we can access or open it. */
if (mode>=0)
fd = access (fn, mode);
else
fd = open (fn, 0, 0);
if (fd >= 0)
{
/* We succeeded; return this descriptor and filename. */
if (storeptr)
*storeptr = build_string (fn);
UNGCPRO;
/* If we actually opened the file, set close-on-exec flag
on the new descriptor so that subprocesses can't whack
at it. */
if (mode < 0)
(void) fcntl (fd, F_SETFD, FD_CLOEXEC);
return fd;
}
}
/* Advance to next suffix. */
if (esuffix == 0)
break;
nsuffix += lsuffix + 1;
}
UNGCPRO;
return -1;
}
/* do the same as locate_file() but don't use any hash tables. */
static int
locate_file_without_hash (Lisp_Object path, Lisp_Object str,
CONST char *suffix, Lisp_Object *storeptr,
int mode)
{
/* This function can GC */
int absolute;
struct gcpro gcpro1;
/* is this necessary? */
GCPRO1 (path);
absolute = !NILP (Ffile_name_absolute_p (str));
for (; !NILP (path); path = Fcdr (path))
{
int val = locate_file_in_directory (Fcar (path), str, suffix,
storeptr, mode);
if (val >= 0)
{
UNGCPRO;
return val;
}
if (absolute)
{
UNGCPRO;
return -1;
}
}
UNGCPRO;
return -1;
}
/* Construct a list of all files to search for. */
static Lisp_Object
locate_file_construct_suffixed_files (Lisp_Object str, CONST char *suffix)
{
int want_size;
int fn_size = 100;
char buf[100];
char *fn = buf;
CONST char *nsuffix;
Lisp_Object suffixtab = Qnil;
/* Calculate maximum size of any filename made from
this path element/specified file name and any possible suffix. */
want_size = strlen (suffix) + string_length (XSTRING (str)) + 1;
if (fn_size < want_size)
fn = (char *) alloca (fn_size = 100 + want_size);
nsuffix = suffix;
while (1)
{
char *esuffix = (char *) strchr (nsuffix, ':');
int lsuffix = ((esuffix) ? (esuffix - nsuffix) : strlen (nsuffix));
/* Concatenate path element/specified name with the suffix. */
strncpy (fn, (char *) string_data (XSTRING (str)),
string_length (XSTRING (str)));
fn[string_length (XSTRING (str))] = 0;
if (lsuffix != 0) /* Bug happens on CCI if lsuffix is 0. */
strncat (fn, nsuffix, lsuffix);
suffixtab = Fcons (build_string (fn), suffixtab);
/* Advance to next suffix. */
if (esuffix == 0)
break;
nsuffix += lsuffix + 1;
}
return Fnreverse (suffixtab);
}
/* Search for a file whose name is STR, looking in directories
in the Lisp list PATH, and trying suffixes from SUFFIX.
SUFFIX is a string containing possible suffixes separated by colons.
On success, returns a file descriptor. On failure, returns -1.
MODE nonnegative means don't open the files,
just look for one for which access(file,MODE) succeeds. In this case,
returns 1 on success.
If STOREPTR is nonzero, it points to a slot where the name of
the file actually found should be stored as a Lisp string.
Nil is stored there on failure. */
int
locate_file (Lisp_Object path, Lisp_Object str, CONST char *suffix,
Lisp_Object *storeptr, int mode)
{
/* This function can GC */
Lisp_Object suffixtab = Qnil;
Lisp_Object pathtail;
int val;
struct gcpro gcpro1, gcpro2, gcpro3;
if (storeptr)
*storeptr = Qnil;
/* if this filename has directory components, it's too complicated
to try and use the hash tables. */
if (!NILP (Ffile_name_directory (str)))
return locate_file_without_hash (path, str, suffix, storeptr,
mode);
/* Is it really necessary to gcpro path and str? It shouldn't be
unless some caller has fucked up. */
GCPRO3 (path, str, suffixtab);
suffixtab = locate_file_construct_suffixed_files (str, suffix);
for (pathtail = path; !NILP (pathtail); pathtail = Fcdr (pathtail))
{
Lisp_Object pathel = Fcar (pathtail);
Lisp_Object hashtab;
Lisp_Object tail;
int found;
/* If this path element is relative, we have to look by hand.
Can't set string property in a pure string. */
if (NILP (pathel) || NILP (Ffile_name_absolute_p (pathel)) ||
purified (pathel))
{
val = locate_file_in_directory (pathel, str, suffix, storeptr,
mode);
if (val >= 0)
{
UNGCPRO;
return val;
}
continue;
}
hashtab = locate_file_find_directory_hash_table (pathel);
/* Loop over suffixes. */
for (tail = suffixtab, found = 0; !NILP (tail) && !found;
tail = Fcdr (tail))
{
if (!NILP (Fgethash (Fcar (tail), hashtab, Qnil)))
found = 1;
}
if (found)
{
/* This is a likely candidate. Look by hand in this directory
so we don't get thrown off if someone byte-compiles a file. */
val = locate_file_in_directory (pathel, str, suffix, storeptr,
mode);
if (val >= 0)
{
UNGCPRO;
return val;
}
/* Hmm ... the file isn't actually there. (Or possibly it's
a directory ...) So refresh our hashing. */
locate_file_refresh_hashing (pathel);
}
}
/* File is probably not there, but check the hard way just in case. */
val = locate_file_without_hash (path, str, suffix, storeptr,
mode);
if (val >= 0)
{
/* Sneaky user added a file without telling us. */
Flocate_file_clear_hashing (path);
}
UNGCPRO;
return val;
}
DEFUN ("locate-file-clear-hashing", Flocate_file_clear_hashing,
Slocate_file_clear_hashing, 1, 1, 0,
"Clear the hash records for the specified list of directories.\n\
`locate-file' uses a hashing scheme to speed lookup, and will correctly\n\
track the following environmental changes:\n\
\n\
-- changes of any sort to the list of directories to be searched.\n\
-- addition and deletion of non-shadowing files (see below) from the\n\
directories in the list.\n\
-- byte-compilation of a .el file into a .elc file.\n\
\n\
`locate-file' will primarily get confused if you add a file that shadows\n\
(i.e. has the same name as) another file further down in the directory list.\n\
In this case, you must call `locate-file-clear-hashing'.")
(path)
Lisp_Object path;
{
Lisp_Object pathtail;
for (pathtail = path; !NILP (pathtail); pathtail = Fcdr (pathtail))
{
Lisp_Object pathel = Fcar (pathtail);
if (!purified (pathel))
Fput (pathel, Qlocate_file_hash_table, Qnil);
}
return Qnil;
}
#ifdef LOADHIST
/* Merge the list we've accumulated of globals from the current input source
into the load_history variable. The details depend on whether
the source has an associated file name or not. */
static void
build_load_history (int loading, Lisp_Object source)
{
Lisp_Object tail, prev, newelt;
Lisp_Object tem, tem2;
int foundit;
/* Don't bother recording anything for preloaded files. */
if (purify_flag)
return;
tail = Vload_history;
prev = Qnil;
foundit = 0;
while (!NILP (tail))
{
tem = Fcar (tail);
/* Find the feature's previous assoc list... */
if (!NILP (Fequal (source, Fcar (tem))))
{
foundit = 1;
/* If we're loading, remove it. */
if (loading)
{
if (NILP (prev))
Vload_history = Fcdr (tail);
else
Fsetcdr (prev, Fcdr (tail));
}
/* Otherwise, cons on new symbols that are not already members. */
else
{
tem2 = Vcurrent_load_list;
while (CONSP (tem2))
{
newelt = Fcar (tem2);
if (NILP (Fmemq (newelt, tem)))
Fsetcar (tail, Fcons (Fcar (tem),
Fcons (newelt, Fcdr (tem))));
tem2 = Fcdr (tem2);
QUIT;
}
}
}
else
prev = tail;
tail = Fcdr (tail);
QUIT;
}
/* If we're loading, cons the new assoc onto the front of load-history,
the most-recently-loaded position. Also do this if we didn't find
an existing member for the current source. */
if (loading || !foundit)
Vload_history = Fcons (Fnreverse (Vcurrent_load_list),
Vload_history);
}
#else /* !LOADHIST */
#define build_load_history(x,y)
#endif /* !LOADHIST */
static void
readevalloop (Lisp_Object readcharfun,
Lisp_Object sourcename,
Lisp_Object (*evalfun) (Lisp_Object),
int printflag)
{
/* This function can GC */
Emchar c;
Lisp_Object val;
int speccount = specpdl_depth ();
struct gcpro gcpro1;
specbind (Qstandard_input, readcharfun);
specbind (Qcurrent_load_list, Qnil);
GCPRO1 (sourcename);
LOADHIST_ATTACH (sourcename);
while (1)
{
QUIT;
c = readchar (readcharfun);
if (c == ';')
{
/* Skip comment */
while ((c = readchar (readcharfun)) != '\n' && c != -1)
QUIT;
continue;
}
if (c < 0)
break;
if (c == ' ' || c == '\t' || c == '\n' || c == '\f')
continue;
#if 0 /* defun hack */
if (purify_flag && c == '(')
{
val = read_list (readcharfun, ')', 1, read_pure, 0, 1);
}
else
{
unreadchar (readcharfun, c);
val = read0 (readcharfun);
}
#else /* No "defun hack" -- Emacs 19 uses read-time syntax for bytecodes */
unreadchar (readcharfun, c);
val = read0 (readcharfun);
#endif
val = (*evalfun) (val);
if (printflag)
{
Vvalues = Fcons (val, Vvalues);
if (EQ (Vstandard_output, Qt))
Fprin1 (val, Qnil);
else
Fprint (val, Qnil);
}
}
build_load_history (1, /* #### This isn't right */
sourcename);
UNGCPRO;
unbind_to (speccount, Qnil);
}
#ifndef standalone
DEFUN ("eval-buffer", Feval_buffer, Seval_buffer, 1, 2, "bBuffer: ",
"Execute 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.")
(bufname, printflag)
Lisp_Object bufname, printflag;
{
/* This function can GC */
int speccount = specpdl_depth ();
Lisp_Object tem, buf;
buf = Fget_buffer (bufname);
if (NILP (buf))
error ("No such buffer.");
if (NILP (printflag))
tem = Qsymbolp; /* #### #@[]*&$#*[& SI:NULL-STREAM */
else
tem = printflag;
specbind (Qstandard_output, tem);
record_unwind_protect (save_excursion_restore, save_excursion_save ());
BUF_SET_PT (XBUFFER (buf), BUF_BEGV (XBUFFER (buf)));
readevalloop (buf, XBUFFER (buf)->filename, Feval,
!NILP (printflag));
return unbind_to (speccount, Qnil);
}
DEFUN ("eval-region", Feval_region, Seval_region, 2, 3, "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\
\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.\n\
Note: Before evaling the region, this function narrows the buffer to it.\n\
If the code being eval'd should happen to trigger a redisplay you may\n\
see some text temporarily disappear because of this.")
(b, e, printflag)
Lisp_Object b, e, printflag;
{
/* This function can GC */
int speccount = specpdl_depth ();
Lisp_Object tem;
Lisp_Object cbuf = Fcurrent_buffer ();
if (NILP (printflag))
tem = Qsymbolp; /* #### #@[]*&$#*[& SI:NULL-STREAM */
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 ());
/* This both uses b and checks its type. */
Fgoto_char (b, cbuf);
Fnarrow_to_region (make_number (BUF_BEGV (current_buffer)), e, cbuf);
readevalloop (cbuf, XBUFFER (cbuf)->filename, Feval,
!NILP (printflag));
return unbind_to (speccount, Qnil);
}
#endif /* standalone */
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).")
(stream)
Lisp_Object stream;
{
if (NILP (stream))
stream = Vstandard_input;
if (EQ (stream, Qt))
stream = Qread_char;
#ifndef standalone
if (EQ (stream, Qread_char))
{
Lisp_Object val = call1 (Qread_from_minibuffer,
build_translated_string ("Lisp expression: "));
return (Fcar (Fread_from_string (val, Qnil, Qnil)));
}
#endif
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;
{
Bytecount startval, endval;
Lisp_Object tem;
Lisp_Object lispstream = Qnil;
struct gcpro gcpro1;
GCPRO1 (lispstream);
get_string_range (string, start, end, &startval, &endval);
lispstream = make_lisp_string_stream (string, startval,
endval - startval);
tem = read0 (lispstream);
/* Yeah, it's ugly. Gonna make something of it? */
RETURN_UNGCPRO
(Fcons (tem, make_number
(bytecount_to_charcount
(string_data (XSTRING (string)),
startval + Lstream_byte_count (XLSTREAM (lispstream))))));
}
#ifdef LISP_BACKQUOTES
static Lisp_Object
backquote_unwind (Lisp_Object ptr)
{ /* used as unwind-protect function in read0() */
int *counter = (int *)get_opaque_ptr (ptr);
if (--*counter < 0)
*counter = 0;
return Qnil;
}
#endif
/* Use this for recursive reads, in contexts where internal tokens are
not allowed. See also read1(). */
static Lisp_Object
read0 (Lisp_Object readcharfun)
{
Lisp_Object val;
val = read1 (readcharfun);
if (CONSP (val) && EQ (XCAR (val), Qunbound))
{
Emchar c = XINT (XCDR (val));
free_cons (XCONS (val));
return Fsignal (Qinvalid_read_syntax,
list1 (Fchar_to_string (make_number (c))));
}
return val;
}
static Emchar
read_escape (Lisp_Object readcharfun)
{
/* This function can GC */
Emchar c = readchar (readcharfun);
switch (c)
{
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 'M':
c = readchar (readcharfun);
if (c != '-')
error ("Invalid escape character syntax");
c = readchar (readcharfun);
if (c == '\\')
c = read_escape (readcharfun);
return c | 0200;
#define FSF_KEYS
#ifdef FSF_KEYS
#define alt_modifier (0x040000)
#define super_modifier (0x080000)
#define hyper_modifier (0x100000)
#define shift_modifier (0x200000)
/* fsf uses a different modifiers for meta and control. Possibly
byte_compiled code will still work fsfmacs, though... --Stig
#define ctl_modifier (0x400000)
#define meta_modifier (0x800000)
*/
#define FSF_LOSSAGE(charvar, mask) \
if (puke_on_fsf_keys || ((c = readchar (readcharfun)) != '-')) \
error ("Invalid escape character syntax"); \
if ((c = readchar (readcharfun)) == '\\') \
c = read_escape (readcharfun); \
return c | mask;
case 'S':
FSF_LOSSAGE (c, shift_modifier);
case 'H':
FSF_LOSSAGE (c, hyper_modifier);
case 'A':
FSF_LOSSAGE (c, alt_modifier);
case 's':
FSF_LOSSAGE (c, super_modifier);
#undef alt_modifier
#undef super_modifier
#undef hyper_modifier
#undef shift_modifier
#undef FSF_LOSSAGE
#endif /* FSF_KEYS */
case 'C':
c = readchar (readcharfun);
if (c != '-')
error ("Invalid escape character syntax");
case '^':
c = readchar (readcharfun);
if (c == '\\')
c = read_escape (readcharfun);
if (c == '?')
return 0177;
else
return (c & (0200 | 037));
case '0':
case '1':
case '2':
case '3':
case '4':
case '5':
case '6':
case '7':
/* An octal escape, as in ANSI C. */
{
Emchar i = c - '0';
int count = 0;
while (++count < 3)
{
if ((c = readchar (readcharfun)) >= '0' && c <= '7')
{
i *= 8;
i += c - '0';
}
else
{
unreadchar (readcharfun, c);
break;
}
}
return i;
}
case 'x':
/* A hex escape, as in ANSI C. */
{
Emchar i = 0;
while (1)
{
c = readchar (readcharfun);
/* Remember, can't use isdigit(), isalpha() etc.
on Emchars */
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
{
unreadchar (readcharfun, c);
break;
}
}
return i;
}
#ifdef MULE
/* #### need some way of reading an extended character with
an escape sequence. */
#endif
default:
{
return c;
}
}
}
/* read symbol-constituent stuff into `Vread_buffer_stream'. */
static Bytecount
read_atom_0 (Lisp_Object readcharfun, Emchar firstchar, int *saw_a_backslash)
{
/* This function can GC */
Emchar c = ((firstchar) >= 0 ? firstchar : readchar (readcharfun));
Lstream_rewind (XLSTREAM (Vread_buffer_stream));
*saw_a_backslash = 0;
while (c > 040 /* #### - comma should be here as should backquote */
&& !(c == '\"' || c == '\'' || c == ';'
|| c == '(' || c == ')'
|| c == '[' || c == ']' || c == '#'
))
{
if (c == '\\')
{
c = readchar (readcharfun);
*saw_a_backslash = 1;
}
Lstream_put_emchar (XLSTREAM (Vread_buffer_stream), c);
QUIT;
c = readchar (readcharfun);
}
if (c >= 0)
unreadchar (readcharfun, c);
/* blasted terminating 0 */
Lstream_put_emchar (XLSTREAM (Vread_buffer_stream), 0);
Lstream_flush (XLSTREAM (Vread_buffer_stream));
return (Lstream_byte_count (XLSTREAM (Vread_buffer_stream)) - 1);
}
static Lisp_Object parse_integer (CONST Bufbyte *buf, Bytecount len, int base);
static Lisp_Object
read_atom (Lisp_Object readcharfun,
Emchar firstchar,
int uninterned_symbol)
{
/* This function can GC */
int saw_a_backslash;
Bytecount len = read_atom_0 (readcharfun, firstchar, &saw_a_backslash);
char *read_ptr = (char *)
resizing_buffer_stream_ptr (XLSTREAM (Vread_buffer_stream));
/* Is it an integer? */
if (! (saw_a_backslash || uninterned_symbol))
{
/* If a token had any backslashes in it, it is disqualified from
being an integer or a float. This means that 123\456 is a
symbol, as is \123 (which is the way (intern "123") prints).
Also, if token was preceeded by #:, it's always a symbol.
*/
char *p = read_ptr + len;
char *p1 = read_ptr;
if (*p1 == '+' || *p1 == '-') p1++;
if (p1 != p)
{
int c;
while (p1 != p && (c = *p1) >= '0' && c <= '9')
p1++;
if (p1 == p)
{
/* It is an integer. */
#if 0
int number = 0;
number = atoi (read_ptr);
return (make_number (number));
#else
return (parse_integer ((Bufbyte *) read_ptr, len, 10));
#endif
}
}
#ifdef LISP_FLOAT_TYPE
if (isfloat_string (read_ptr))
return make_float (atof (read_ptr));
#endif
}
{
Lisp_Object sym;
if (uninterned_symbol)
sym = (Fmake_symbol ((purify_flag)
? make_pure_pname ((Bufbyte *) read_ptr, len, 0)
: make_string ((Bufbyte *) read_ptr, len)));
else
{
/* intern will purecopy pname if necessary */
Lisp_Object name = make_string ((Bufbyte *) read_ptr, len);
sym = Fintern (name, Qnil);
}
if (SYMBOL_IS_KEYWORD (sym))
{
/* the LISP way is to put keywords in their own package, but we don't
have packages, so we do something simpler. Someday, maybe we'll
have packages and then this will be reworked. --Stig. */
XSYMBOL (sym)->value = sym;
}
return (sym);
}
}
static Lisp_Object
parse_integer (CONST Bufbyte *buf, Bytecount len, int base)
{
CONST Bufbyte *lim = buf + len;
CONST Bufbyte *p = buf;
unsigned LISP_WORD_TYPE num = 0;
int negativland = 0;
if (*p == '-')
{
negativland = 1;
p++;
}
else if (*p == '+')
{
p++;
}
if (p == lim)
goto loser;
for (; p < lim; p++)
{
int c = *p;
unsigned LISP_WORD_TYPE onum;
if (isdigit (c))
c = c - '0';
else if (isupper (c))
c = c - 'A' + 10;
else if (islower (c))
c = c - 'a' + 10;
else
goto loser;
if (c < 0 || c >= base)
goto loser;
onum = num;
num = num * base + c;
if (num < onum)
goto overflow;
}
{
Lisp_Object result = make_number ((negativland) ? -num : num);
if (num && ((XINT (result) < 0) != negativland))
goto overflow;
if (XINT (result) != ((negativland) ? -num : num))
goto overflow;
return (result);
}
overflow:
return Fsignal (Qinvalid_read_syntax,
list3 (build_translated_string
("Integer constant overflow in reader"),
make_string (buf, len),
make_number (base)));
loser:
return Fsignal (Qinvalid_read_syntax,
list3 (build_translated_string
("Invalid integer constant in reader"),
make_string (buf, len),
make_number (base)));
}
static Lisp_Object
read_integer (Lisp_Object readcharfun, int base)
{
/* This function can GC */
int saw_a_backslash;
Bytecount len = read_atom_0 (readcharfun, -1, &saw_a_backslash);
return (parse_integer
(resizing_buffer_stream_ptr (XLSTREAM (Vread_buffer_stream)),
((saw_a_backslash)
? 0 /* make parse_integer signal error */
: len),
base));
}
static Lisp_Object read_bytecode (Lisp_Object readcharfun, int terminator);
static Lisp_Object read_vector (Lisp_Object readcharfun, int terminator);
/* Get the next character; filter out whitespace and comments */
static Emchar
reader_nextchar (Lisp_Object readcharfun)
{
/* This function can GC */
Emchar c;
retry:
QUIT;
c = readchar (readcharfun);
if (c < 0)
signal_error (Qend_of_file, list1 (readcharfun));
switch (c)
{
default:
{
/* Ignore whitespace and control characters */
if (c <= 040)
goto retry;
return (c);
}
case ';':
{
/* Comment */
while ((c = readchar (readcharfun)) >= 0 && c != '\n')
QUIT;
goto retry;
}
}
}
#if 0
static Lisp_Object
list2_pure (int pure, Lisp_Object a, Lisp_Object b)
{
if (pure)
return (pure_cons (a, pure_cons (b, Qnil)));
else
return (list2 (a, b));
}
#endif
/* Read the next Lisp object from the stream READCHARFUN and return it.
If the return value is a cons whose car in Qunbound, then read1()
encountered a misplaced token (e.g. a right bracket, right paren,
or dot followed by a non-number). To filter this stuff out,
use read0(). */
static Lisp_Object
read1 (Lisp_Object readcharfun)
{
Emchar c;
retry:
c = reader_nextchar (readcharfun);
switch (c)
{
case '(':
{
#ifdef LISP_BACKQUOTES /* old backquote compatibility in lisp reader */
/* if this is disabled, then other code in eval.c must be enabled */
int ch = reader_nextchar (readcharfun);
switch (ch)
{
case '`':
{
Lisp_Object tem;
int speccount = specpdl_depth ();
++reading_old_backquote;
record_unwind_protect (backquote_unwind,
make_opaque_ptr (&reading_old_backquote));
tem = read0 (readcharfun);
unbind_to (speccount, Qnil);
ch = reader_nextchar (readcharfun);
if (ch != ')')
{
unreadchar (readcharfun, ch);
return Fsignal (Qinvalid_read_syntax,
list1 (build_string
("Weird old-backquote syntax")));
}
return list2 (Qbacktick, tem);
}
case ',':
{
if (reading_old_backquote)
{
Lisp_Object tem, comma_type;
ch = readchar (readcharfun);
if (ch == '@')
comma_type = Qcomma_at;
else
{
if (ch >= 0)
unreadchar (readcharfun, ch);
comma_type = Qcomma;
}
tem = read0 (readcharfun);
ch = reader_nextchar (readcharfun);
if (ch != ')')
{
unreadchar (readcharfun, ch);
return Fsignal (Qinvalid_read_syntax,
list1 (build_string
("Weird old-backquote syntax")));
}
return list2 (comma_type, tem);
}
else
{
unreadchar (readcharfun, ch);
#if 0
return Fsignal (Qinvalid_read_syntax,
list1 (build_string ("Comma outside of backquote")));
#else
/* #### - yuck....but this is reverse compatible. */
/* mostly this is required by edebug, which does it's own
annotated reading. We need to have an annotated_read
function that records (with markers) the buffer
positions of the elements that make up lists, then that
can be used in edebug and bytecomp and the check above
can go back in. --Stig */
break;
#endif
}
}
default:
unreadchar (readcharfun, ch);
} /* switch(ch) */
#endif /* old backquote crap... */
return read_list (readcharfun, ')', 1);
}
case '[':
return (read_vector (readcharfun, ']'));
case ')':
case ']':
/* #### - huh? these don't do what they seem... */
return (Fcons (Qunbound, make_number (c)));
case '.':
{
#ifdef LISP_FLOAT_TYPE
/* If a period is followed by a number, then we should read it
as a floating point number. Otherwise, it denotes a dotted
pair.
*/
c = readchar (readcharfun);
unreadchar (readcharfun, c);
/* Can't use isdigit on Emchars */
if (c < '0' || c > '9')
return (Fcons (Qunbound, make_number ('.')));
/* Note that read_atom will loop
at least once, assuring that we will not try to UNREAD
two characters in a row.
(I think this doesn't matter anymore because there should
be no more danger in unreading multiple characters) */
return (read_atom (readcharfun, '.', 0));
#else /* ! LISP_FLOAT_TYPE */
return (Fcons (Qunbound, make_number ('.')));
#endif /* ! LISP_FLOAT_TYPE */
}
case '#':
{
c = readchar (readcharfun);
switch (c)
{
case '[':
{
/* "#["-- byte-code constant syntax */
return (read_bytecode (readcharfun, ']'
/* purecons #[...] syntax */
/*, purify_flag */ ));
}
case ':':
{
/* "#:"-- quasi-implemented gensym syntax */
return (read_atom (readcharfun, -1, 1));
}
case '\'':
{
/* #'x => (function x) */
return (list2 (Qfunction, read0 (readcharfun)));
}
#if 0
/* RMS uses this syntax for fat-strings.
If we use it for vectors, then obscure bugs happen.
*/
case '(':
{
/* "#(" -- Scheme/CL vector syntax */
return (read_vector (readcharfun, ')'));
}
#endif
case 'o':
{
/* #o10 => 8 -- octal constant syntax */
return (read_integer (readcharfun, 8));
}
case 'x':
{
/* #xdead => 57005 -- hex constant syntax */
return (read_integer (readcharfun, 16));
}
case 'b':
{
/* #b010 => 2 -- binary constant syntax */
return (read_integer (readcharfun, 2));
}
case '<':
{
unreadchar (readcharfun, c);
return Fsignal (Qinvalid_read_syntax,
list1 (build_string ("Cannot read unreadable object")));
}
default:
{
unreadchar (readcharfun, c);
return Fsignal (Qinvalid_read_syntax,
list1 (build_string ("#")));
}
}
}
case '\'':
{
/* Quote */
return list2 (Qquote, read0 (readcharfun));
}
#ifdef LISP_BACKQUOTES
case '`':
{
Lisp_Object tem;
int speccount = specpdl_depth ();
++reading_backquote;
record_unwind_protect (backquote_unwind,
make_opaque_ptr (&reading_backquote));
tem = read0 (readcharfun);
unbind_to (speccount, Qnil);
return list2 (Qbackquote, tem);
}
case ',':
{
if (reading_backquote)
{
Lisp_Object comma_type = Qnil;
int ch = readchar (readcharfun);
if (ch == '@')
comma_type = Qcomma_at;
else
{
if (ch >= 0)
unreadchar (readcharfun, ch);
comma_type = Qcomma;
}
return list2 (comma_type, read0 (readcharfun));
}
else
{
/* YUCK. 99.999% backwards compatibility. The Right
Thing(tm) is to signal an error here, because it's
really invalid read syntax. Instead, this permits
commas to begin symbols (unless they're inside
backquotes). If an error is signalled here in the
future, then commas should be invalid read syntax
outside of backquotes anywhere they're found (i.e.
they must be quoted in symbols) -- Stig */
return (read_atom (readcharfun, c, 0));
}
}
#endif
case '?':
{
/* Evil GNU Emacs "character" (ie integer) syntax */
c = readchar (readcharfun);
if (c < 0)
return Fsignal (Qend_of_file, list1 (readcharfun));
if (c == '\\')
c = read_escape (readcharfun);
return (make_number (c));
}
case '\"':
{
/* String */
#ifdef I18N3
/* #### If the input stream is translating, then the string
should be marked as translatable by setting its
`string-translatable' property to t. .el and .elc files
normally are translating input streams. See Fgettext()
and print_internal(). */
#endif
int cancel = 0;
Lstream_rewind (XLSTREAM (Vread_buffer_stream));
while ((c = readchar (readcharfun)) >= 0
&& c != '\"')
{
if (c == '\\')
c = read_escape (readcharfun);
/* c is -1 if \ newline has just been seen */
if (c == -1)
{
if (Lstream_byte_count (XLSTREAM (Vread_buffer_stream)) == 0)
cancel = 1;
}
else
Lstream_put_emchar (XLSTREAM (Vread_buffer_stream), c);
QUIT;
}
if (c < 0)
return Fsignal (Qend_of_file, list1 (readcharfun));
/* If purifying, and string starts with \ newline,
return zero instead. This is for doc strings
that we are really going to find in lib-src/DOC.nn.nn */
if (purify_flag && NILP (Vdoc_file_name) && cancel)
return (Qzero);
Lstream_flush (XLSTREAM (Vread_buffer_stream));
return
make_string
(resizing_buffer_stream_ptr (XLSTREAM (Vread_buffer_stream)),
Lstream_byte_count (XLSTREAM (Vread_buffer_stream)));
}
default:
{
/* Ignore whitespace and control characters */
if (c <= 040)
goto retry;
return (read_atom (readcharfun, c, 0));
}
}
}
#ifdef LISP_FLOAT_TYPE
#define LEAD_INT 1
#define DOT_CHAR 2
#define TRAIL_INT 4
#define E_CHAR 8
#define EXP_INT 16
int
isfloat_string (CONST char *cp)
{
int state = 0;
CONST Bufbyte *ucp = (Bufbyte *) cp;
if (*ucp == '+' || *ucp == '-')
ucp++;
if (isdigit (*ucp))
{
state |= LEAD_INT;
while (isdigit (*ucp))
ucp++;
}
if (*ucp == '.')
{
state |= DOT_CHAR;
ucp++;
}
if (isdigit (*ucp))
{
state |= TRAIL_INT;
while (isdigit (*ucp))
ucp++;
}
if (*ucp == 'e' || *ucp == 'E')
{
state |= E_CHAR;
ucp++;
}
if ((*ucp == '+') || (*ucp == '-'))
ucp++;
if (isdigit (*ucp))
{
state |= EXP_INT;
while (isdigit (*ucp))
ucp++;
}
return (*ucp == 0
&& (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)));
}
#endif /* LISP_FLOAT_TYPE */
static void *
sequence_reader (Lisp_Object readcharfun,
Emchar terminator,
void *state,
void * (*conser) (Lisp_Object readcharfun,
void *state, Charcount len))
{
Charcount len;
for (len = 0; ; len++)
{
Emchar ch;
QUIT;
ch = reader_nextchar (readcharfun);
if (ch == terminator)
return (state);
else
unreadchar (readcharfun, ch);
if (ch == ']')
syntax_error ("\"]\" in a list");
else if (ch == ')')
syntax_error ("\")\" in a vector");
state = ((conser) (readcharfun, state, len));
}
}
struct read_list_state
{
Lisp_Object head; Lisp_Object tail;
int allow_dotted_lists;
Emchar terminator;
};
static void *
read_list_conser (Lisp_Object readcharfun, void *state, Charcount len)
{
struct read_list_state *s = state;
Lisp_Object elt;
elt = read1 (readcharfun);
if (CONSP (elt) && EQ (XCAR (elt), Qunbound))
{
Lisp_Object tem = elt;
Emchar ch;
elt = XCDR (elt);
free_cons (XCONS (tem));
tem = Qnil;
ch = XINT (elt);
if (ch != '.')
signal_simple_error ("BUG! Internal reader error", elt);
else if (!s->allow_dotted_lists)
syntax_error ("\".\" in a vector");
else
{
if (!NILP (s->tail))
XCDR (s->tail) = read0 (readcharfun);
else
s->head = read0 (readcharfun);
elt = read1 (readcharfun);
if (CONSP (elt) && EQ (XCAR (elt), Qunbound)
&& XINT (XCDR (elt)) == s->terminator)
{
free_cons (XCONS (elt));
unreadchar (readcharfun, s->terminator);
goto done;
}
syntax_error (". in wrong context");
}
}
#if 0
if (NILP (tail) && defun_hack && EQ (elt, Qdefun) && !read_pure)
{
record_unwind_protect (unreadpure, Qzero);
read_pure = 1;
}
#endif
elt = Fcons (elt, Qnil);
if (!NILP (s->tail))
XCDR (s->tail) = elt;
else
s->head = elt;
s->tail = elt;
done:
return (s);
}
static Lisp_Object
read_list (Lisp_Object readcharfun,
Emchar terminator,
int allow_dotted_lists)
{
struct read_list_state s;
struct gcpro gcpro1, gcpro2;
s.head = Qnil;
s.tail = Qnil;
s.allow_dotted_lists = allow_dotted_lists;
s.terminator = terminator;
GCPRO2 (s.head, s.tail);
(void) sequence_reader (readcharfun,
terminator,
&s,
read_list_conser);
UNGCPRO;
return (s.head);
}
static Lisp_Object
read_vector (Lisp_Object readcharfun,
Emchar terminator)
{
Lisp_Object tem;
Lisp_Object *p;
int len;
int i;
struct read_list_state s;
struct gcpro gcpro1, gcpro2;
s.head = Qnil;
s.tail = Qnil;
s.allow_dotted_lists = 0;
GCPRO2 (s.head, s.tail);
(void) sequence_reader (readcharfun,
terminator,
&s,
read_list_conser);
UNGCPRO;
tem = s.head;
len = XINT (Flength (tem));
s.head = make_vector (len, Qnil);
for (i = 0, p = &(vector_data (XVECTOR (s.head))[0]);
i < len;
i++, p++)
{
struct Lisp_Cons *otem = XCONS (tem);
tem = Fcar (tem);
*p = tem;
tem = otem->cdr;
free_cons (otem);
}
return (s.head);
}
static Lisp_Object
read_bytecode (Lisp_Object readcharfun, Emchar terminator)
{
/* Accept compiled functions at read-time so that we don't
have to build them at load-time. */
Lisp_Object stuff;
Lisp_Object make_byte_code_args[COMPILED_DOMAIN + 1];
struct gcpro gcpro1;
int len;
int iii;
stuff = read_list (readcharfun, terminator, 0);
len = XINT (Flength (stuff));
if (len < COMPILED_STACK_DEPTH + 1 || len > COMPILED_DOMAIN + 1)
return
continuable_syntax_error ("#[...] used with wrong number of elements");
for (iii = 0; CONSP (stuff); iii++)
{
struct Lisp_Cons *victim = XCONS (stuff);
make_byte_code_args[iii] = Fcar (stuff);
stuff = Fcdr (stuff);
free_cons (victim);
}
GCPRO1 (make_byte_code_args[0]);
gcpro1.nvars = len;
/* make-byte-code looks at purify_flag, which should have the same
* value as our "read-pure" argument */
RETURN_UNGCPRO (Fmake_byte_code (len, make_byte_code_args));
}
void
init_lread (void)
{
#ifdef PATH_LOADSEARCH
CONST char *normal = PATH_LOADSEARCH;
/* Don't print this warning. If the hardcoded paths don't exist, then
startup.el will try and deduce one. If it fails, it knows how to
handle things. */
#if 0
/* Warn if dirs in the *standard* path don't exist. */
{
Lisp_Object normal_path = decode_env_path (0, normal);
for (; !NILP (normal_path); normal_path = XCDR (normal_path))
{
Lisp_Object dirfile;
dirfile = Fcar (normal_path);
if (!NILP (dirfile))
{
dirfile = Fdirectory_file_name (dirfile);
if (access ((char *) string_data (XSTRING (dirfile)), 0) < 0)
stdout_out ("Warning: lisp library (%s) does not exist.\n",
string_data (XSTRING (Fcar (normal_path))));
}
}
}
#endif /* 0 */
#else /* !PATH_LOADSEARCH */
CONST char *normal = 0;
#endif /* !PATH_LOADSEARCH */
Vvalues = Qnil;
/* further frobbed by startup.el if nil. */
Vload_path = decode_env_path ("EMACSLOADPATH", normal);
/* Vdump_load_path = Qnil; */
#ifndef CANNOT_DUMP
if (purify_flag && NILP (Vload_path))
{
/* loadup.el will frob this some more. */
/* #### unix-specific */
Vload_path = Fcons (build_string ("../lisp/prim"), Vload_path);
}
#endif /* not CANNOT_DUMP */
load_in_progress = 0;
load_descriptor_list = Qnil;
Vread_buffer_stream = make_resizing_buffer_stream ();
}
void
syms_of_lread (void)
{
defsubr (&Sread);
defsubr (&Sread_from_string);
defsubr (&Sload_internal);
defsubr (&Slocate_file);
defsubr (&Slocate_file_clear_hashing);
defsubr (&Seval_buffer);
defsubr (&Seval_region);
#ifdef standalone
defsubr (&Sread_char);
#endif
defsymbol (&Qstandard_input, "standard-input");
defsymbol (&Qread_char, "read-char");
defsymbol (&Qcurrent_load_list, "current-load-list");
defsymbol (&Qload, "load");
defsymbol (&Qlocate_file_hash_table, "locate-file-hash-table");
}
void
vars_of_lread (void)
{
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\n\
Note that the elements of this list *may not* begin with \"~\", so you must\n\
call `expand-file-name' on them before adding them to this list.\n\n\
Initialized based on EMACSLOADPATH environment variable, if any,\n\
otherwise to default specified in by file `paths.h' when Emacs was built.\n\
If there were no paths specified in `paths.h', then emacs chooses a default\n\
value for this variable by looking around in the file-system near the\n\
directory in which the emacs executable resides.");
/* xxxDEFVAR_LISP ("dump-load-path", &Vdump_load_path,
"*Location of lisp files to be used when dumping ONLY."); */
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_BOOL ("load-warn-when-source-newer", &load_warn_when_source_newer,
"*Whether `load' should check whether the source is newer than the binary;\n\
If this variable is true, then when a `.elc' file is being loaded and the\n\
corresponding `.el' is newer, a warning message will be printed.");
load_warn_when_source_newer = 0;
DEFVAR_BOOL ("load-warn-when-source-only", &load_warn_when_source_only,
"*Whether `load' should warn when loading a .el file instead of an .elc.\n\
If this variable is true, then when load is called with a filename without\n\
an extension, and the .elc version doesn't exist but the .el version does,\n\
then a message will be printed. If an explicit extension is passed to load,\n\
no warning will be printed.");
load_warn_when_source_only = 0;
DEFVAR_BOOL ("load-ignore-elc-files", &load_ignore_elc_files,
"*Whether `load' should ignore `.elc' files when a suffix is not given.\n\
This is normally used only to bootstrap the .elc files when building Emacs.");
load_ignore_elc_files = 0;
#ifdef LOADHIST
DEFVAR_LISP ("load-history", &Vload_history,
"Alist mapping source file names to symbols and features.\n\
Each alist element is a list that starts with a file name,\n\
except for one element (optional) that starts with nil and describes\n\
definitions evaluated from buffers not visiting files.\n\
The remaining elements of each list are symbols defined as functions\n\
or variables, and cons cells `(provide . FEATURE)' and `(require . FEATURE)'.");
Vload_history = Qnil;
DEFVAR_LISP ("current-load-list", &Vcurrent_load_list,
"Used for internal purposes by `load'.");
Vcurrent_load_list = Qnil;
#endif
DEFVAR_BOOL ("fail-on-bucky-bit-character-escapes", &puke_on_fsf_keys,
"Whether `read' should signal an error when it encounters unsupported\n\
character escape syntaxes or just read them incorrectly.");
puke_on_fsf_keys = 0;
/* This must be initialized in init_lread otherwise it may start out
with values saved when the image is dumped. */
staticpro (&load_descriptor_list);
/* This gets initialized in init_lread because all streams get closed
when dumping occurs */
staticpro (&Vread_buffer_stream);
/* So that early-early stuff will work */
Ffset (Qload, intern ("load-internal"));
#ifdef LISP_BACKQUOTES
Qbackquote = intern ("backquote");
staticpro (&Qbackquote);
Qbacktick = intern ("`");
staticpro (&Qbacktick);
Qcomma = intern (",");
staticpro (&Qcomma);
Qcomma_at = intern (",@");
staticpro (&Qcomma_at);
reading_old_backquote = reading_backquote = 0;
#endif
#ifdef I18N3
Vfile_domain = Qnil;
#endif
}
These are the contents of the former NiCE NeXT User Group NeXTSTEP/OpenStep software archive, currently hosted by Netfuture.ch.