#include <config.h>
+#include <inttypes.h>
#include <stdio.h>
#include <sys/types.h>
#include <sys/stat.h>
#endif
/* hash table read constants */
-Lisp_Object Qhash_table, Qdata;
-Lisp_Object Qtest, Qsize;
-Lisp_Object Qweakness;
-Lisp_Object Qrehash_size;
-Lisp_Object Qrehash_threshold;
-
-Lisp_Object Qread_char, Qget_file_char, Qstandard_input, Qcurrent_load_list;
+static Lisp_Object Qhash_table, Qdata;
+static Lisp_Object Qtest, Qsize;
+static Lisp_Object Qweakness;
+static Lisp_Object Qrehash_size;
+static Lisp_Object Qrehash_threshold;
+
+static Lisp_Object Qread_char, Qget_file_char, Qcurrent_load_list;
+Lisp_Object Qstandard_input;
Lisp_Object Qvariable_documentation;
-Lisp_Object Qascii_character, Qload, Qload_file_name;
+static 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;
-Lisp_Object Qfile_truename, Qdo_after_load_evaluation; /* ACM 2006/5/16 */
+static Lisp_Object Qinhibit_file_name_operation;
+static Lisp_Object Qeval_buffer_list;
+static Lisp_Object Qlexical_binding;
+static Lisp_Object Qfile_truename, Qdo_after_load_evaluation; /* ACM 2006/5/16 */
/* Used instead of Qget_file_char while loading *.elc files compiled
by Emacs 21 or older. */
static Lisp_Object Qload_force_doc_strings;
+extern Lisp_Object Qinternal_interpreter_environment;
+
static Lisp_Object Qload_in_progress;
/* The association list of objects read with the #n=object form.
Each member of the list has the form (n . object), and is used to
look up the object for the corresponding #n# construct.
It must be set to nil before all top-level calls to read0. */
-Lisp_Object read_objects;
+static Lisp_Object read_objects;
/* Nonzero means READCHAR should read bytes one by one (not character)
when READCHARFUN is Qget_file_char or Qget_emacs_mule_file_char.
static int read_emacs_mule_char (int, int (*) (int, Lisp_Object),
Lisp_Object);
-static void readevalloop (Lisp_Object, FILE*, Lisp_Object,
- Lisp_Object (*) (Lisp_Object), int,
+static void readevalloop (Lisp_Object, FILE*, Lisp_Object, int,
Lisp_Object, Lisp_Object,
Lisp_Object, Lisp_Object);
static Lisp_Object load_unwind (Lisp_Object);
if (pt_byte >= BUF_ZV_BYTE (inbuffer))
return -1;
- if (! NILP (inbuffer->enable_multibyte_characters))
+ if (! NILP (BVAR (inbuffer, enable_multibyte_characters)))
{
/* Fetch the character code from the buffer. */
unsigned char *p = BUF_BYTE_ADDRESS (inbuffer, pt_byte);
if (bytepos >= BUF_ZV_BYTE (inbuffer))
return -1;
- if (! NILP (inbuffer->enable_multibyte_characters))
+ if (! NILP (BVAR (inbuffer, enable_multibyte_characters)))
{
/* Fetch the character code from the buffer. */
unsigned char *p = BUF_BYTE_ADDRESS (inbuffer, bytepos);
else if (BUFFERP (readcharfun))
{
struct buffer *b = XBUFFER (readcharfun);
+ EMACS_INT charpos = BUF_PT (b);
EMACS_INT bytepos = BUF_PT_BYTE (b);
- BUF_PT (b)--;
- if (! NILP (b->enable_multibyte_characters))
+ if (! NILP (BVAR (b, enable_multibyte_characters)))
BUF_DEC_POS (b, bytepos);
else
bytepos--;
- BUF_PT_BYTE (b) = bytepos;
+ SET_BUF_PT_BOTH (b, charpos - 1, bytepos);
}
else if (MARKERP (readcharfun))
{
EMACS_INT bytepos = XMARKER (readcharfun)->bytepos;
XMARKER (readcharfun)->charpos--;
- if (! NILP (b->enable_multibyte_characters))
+ if (! NILP (BVAR (b, enable_multibyte_characters)))
BUF_DEC_POS (b, bytepos);
else
bytepos--;
\f
+
+/* Return true if the lisp code read using READCHARFUN defines a non-nil
+ `lexical-binding' file variable. After returning, the stream is
+ positioned following the first line, if it is a comment, otherwise
+ nothing is read. */
+
+static int
+lisp_file_lexically_bound_p (Lisp_Object readcharfun)
+{
+ int ch = READCHAR;
+ if (ch != ';')
+ /* The first line isn't a comment, just give up. */
+ {
+ UNREAD (ch);
+ return 0;
+ }
+ else
+ /* Look for an appropriate file-variable in the first line. */
+ {
+ int rv = 0;
+ enum {
+ NOMINAL, AFTER_FIRST_DASH, AFTER_ASTERIX,
+ } beg_end_state = NOMINAL;
+ int in_file_vars = 0;
+
+#define UPDATE_BEG_END_STATE(ch) \
+ if (beg_end_state == NOMINAL) \
+ beg_end_state = (ch == '-' ? AFTER_FIRST_DASH : NOMINAL); \
+ else if (beg_end_state == AFTER_FIRST_DASH) \
+ beg_end_state = (ch == '*' ? AFTER_ASTERIX : NOMINAL); \
+ else if (beg_end_state == AFTER_ASTERIX) \
+ { \
+ if (ch == '-') \
+ in_file_vars = !in_file_vars; \
+ beg_end_state = NOMINAL; \
+ }
+
+ /* Skip until we get to the file vars, if any. */
+ do
+ {
+ ch = READCHAR;
+ UPDATE_BEG_END_STATE (ch);
+ }
+ while (!in_file_vars && ch != '\n' && ch != EOF);
+
+ while (in_file_vars)
+ {
+ char var[100], val[100];
+ unsigned i;
+
+ ch = READCHAR;
+
+ /* Read a variable name. */
+ while (ch == ' ' || ch == '\t')
+ ch = READCHAR;
+
+ i = 0;
+ while (ch != ':' && ch != '\n' && ch != EOF)
+ {
+ if (i < sizeof var - 1)
+ var[i++] = ch;
+ UPDATE_BEG_END_STATE (ch);
+ ch = READCHAR;
+ }
+
+ while (i > 0 && (var[i - 1] == ' ' || var[i - 1] == '\t'))
+ i--;
+ var[i] = '\0';
+
+ if (ch == ':')
+ {
+ /* Read a variable value. */
+ ch = READCHAR;
+
+ while (ch == ' ' || ch == '\t')
+ ch = READCHAR;
+
+ i = 0;
+ while (ch != ';' && ch != '\n' && ch != EOF && in_file_vars)
+ {
+ if (i < sizeof val - 1)
+ val[i++] = ch;
+ UPDATE_BEG_END_STATE (ch);
+ ch = READCHAR;
+ }
+ if (! in_file_vars)
+ /* The value was terminated by an end-marker, which
+ remove. */
+ i -= 3;
+ while (i > 0 && (val[i - 1] == ' ' || val[i - 1] == '\t'))
+ i--;
+ val[i] = '\0';
+
+ if (strcmp (var, "lexical-binding") == 0)
+ /* This is it... */
+ {
+ rv = (strcmp (val, "nil") != 0);
+ break;
+ }
+ }
+ }
+
+ while (ch != '\n' && ch != EOF)
+ ch = READCHAR;
+
+ return rv;
+ }
+}
+\f
/* Value is a version number of byte compiled code if the file
associated with file descriptor FD is a compiled Lisp file that's
safe to load. Only files compiled with Emacs are safe to load.
if (i == 4)
version = buf[i];
- if (i == nbytes
+ if (i >= nbytes
|| fast_c_string_match_ignore_case (Vbytecomp_version_regexp,
buf + i) < 0)
safe_p = 0;
Also, just loading a file recursively is not always an error in
the general case; the second load may do something different. */
{
- int count = 0;
+ int load_count = 0;
Lisp_Object tem;
for (tem = Vloads_in_progress; CONSP (tem); tem = XCDR (tem))
- if (!NILP (Fequal (found, XCAR (tem))) && (++count > 3))
+ if (!NILP (Fequal (found, XCAR (tem))) && (++load_count > 3))
{
if (fd >= 0)
emacs_close (fd);
Vloads_in_progress = Fcons (found, Vloads_in_progress);
}
+ /* All loads are by default dynamic, unless the file itself specifies
+ otherwise using a file-variable in the first line. This is bound here
+ so that it takes effect whether or not we use
+ Vload_source_file_function. */
+ specbind (Qlexical_binding, Qnil);
+
/* Get the name for load-history. */
hist_file_name = (! NILP (Vpurify_flag)
? Fconcat (2, (tmp[0] = Ffile_name_directory (file),
load_descriptor_list
= Fcons (make_number (fileno (stream)), load_descriptor_list);
specbind (Qload_in_progress, Qt);
+
+ instream = stream;
+ if (lisp_file_lexically_bound_p (Qget_file_char))
+ Fset (Qlexical_binding, Qt);
+
if (! version || version >= 22)
readevalloop (Qget_file_char, stream, hist_file_name,
- Feval, 0, Qnil, Qnil, Qnil, Qnil);
+ 0, Qnil, Qnil, Qnil, Qnil);
else
{
/* We can't handle a file which was compiled with
byte-compile-dynamic by older version of Emacs. */
specbind (Qload_force_doc_strings, Qt);
- readevalloop (Qget_emacs_mule_file_char, stream, hist_file_name, Feval,
+ readevalloop (Qget_emacs_mule_file_char, stream, hist_file_name,
0, Qnil, Qnil, Qnil, Qnil);
}
unbind_to (count, Qnil);
file name when searching.
If non-nil, PREDICATE is used instead of `file-readable-p'.
PREDICATE can also be an integer to pass to the access(2) function,
-in which case file-name-handlers are ignored. */)
+in which case file-name-handlers are ignored.
+This function will normally skip directories, so if you want it to find
+directories, make sure the PREDICATE function returns `dir-ok' for them. */)
(Lisp_Object filename, Lisp_Object path, Lisp_Object suffixes, Lisp_Object predicate)
{
Lisp_Object file;
return file;
}
+static Lisp_Object Qdir_ok;
/* Search for a file whose name is STR, looking in directories
in the Lisp list PATH, and trying suffixes from SUFFIX.
openp (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes, Lisp_Object *storeptr, Lisp_Object predicate)
{
register int fd;
- int fn_size = 100;
+ EMACS_INT fn_size = 100;
char buf[100];
register char *fn = buf;
int absolute = 0;
- int want_size;
+ EMACS_INT want_length;
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;
+ EMACS_INT max_suffix_len = 0;
CHECK_STRING (str);
/* Of course, this could conceivably lose if luser sets
default-directory to be something non-absolute... */
{
- filename = Fexpand_file_name (filename, current_buffer->directory);
+ filename = Fexpand_file_name (filename, BVAR (current_buffer, directory));
if (!complete_filename_p (filename))
/* Give up on this path element! */
continue;
}
- /* Calculate maximum size of any filename made from
+ /* Calculate maximum length of any filename made from
this path element/specified file name and any possible suffix. */
- want_size = max_suffix_len + SBYTES (filename) + 1;
- if (fn_size < want_size)
- fn = (char *) alloca (fn_size = 100 + want_size);
+ want_length = max_suffix_len + SBYTES (filename);
+ if (fn_size <= want_length)
+ fn = (char *) alloca (fn_size = 100 + want_length);
/* Loop over suffixes. */
for (tail = NILP (suffixes) ? Fcons (empty_unibyte_string, Qnil) : suffixes;
if (NILP (predicate))
exists = !NILP (Ffile_readable_p (string));
else
- exists = !NILP (call1 (predicate, string));
- if (exists && !NILP (Ffile_directory_p (string)))
- exists = 0;
+ {
+ Lisp_Object tmp = call1 (predicate, string);
+ exists = !NILP (tmp)
+ && (EQ (tmp, Qdir_ok)
+ || NILP (Ffile_directory_p (string)));
+ }
if (exists)
{
encoded_fn = ENCODE_FILE (string);
pfn = SSDATA (encoded_fn);
- exists = (stat (pfn, &st) >= 0
- && (st.st_mode & S_IFMT) != S_IFDIR);
+ exists = (stat (pfn, &st) == 0 && ! S_ISDIR (st.st_mode));
if (exists)
{
/* Check that we can access or open it. */
readevalloop (Lisp_Object readcharfun,
FILE *stream,
Lisp_Object sourcename,
- Lisp_Object (*evalfun) (Lisp_Object),
int printflag,
Lisp_Object unibyte, Lisp_Object readfun,
Lisp_Object start, Lisp_Object end)
struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
struct buffer *b = 0;
int continue_reading_p;
+ Lisp_Object lex_bound;
/* Nonzero if reading an entire buffer. */
int whole_buffer = 0;
/* 1 on the first time around. */
record_unwind_protect (readevalloop_1, load_convert_to_unibyte ? Qt : Qnil);
load_convert_to_unibyte = !NILP (unibyte);
+ /* If lexical binding is active (either because it was specified in
+ the file's header, or via a buffer-local variable), create an empty
+ lexical environment, otherwise, turn off lexical binding. */
+ lex_bound = find_symbol_value (Qlexical_binding);
+ specbind (Qinternal_interpreter_environment,
+ NILP (lex_bound) || EQ (lex_bound, Qunbound)
+ ? Qnil : Fcons (Qt, Qnil));
+
GCPRO4 (sourcename, readfun, start, end);
/* Try to ensure sourcename is a truename, except whilst preloading. */
{
int count1 = SPECPDL_INDEX ();
- if (b != 0 && NILP (b->name))
+ if (b != 0 && NILP (BVAR (b, name)))
error ("Reading from killed buffer");
if (!NILP (start))
to a different value when evaluated. */
if (BUFFERP (readcharfun))
{
- struct buffer *b = XBUFFER (readcharfun);
- if (BUF_PT (b) == BUF_ZV (b))
+ struct buffer *buf = XBUFFER (readcharfun);
+ if (BUF_PT (buf) == BUF_ZV (buf))
continue_reading_p = 0;
}
}
unbind_to (count1, Qnil);
/* Now eval what we just read. */
- val = (*evalfun) (val);
+ val = eval_sub (val);
if (printflag)
{
tem = printflag;
if (NILP (filename))
- filename = XBUFFER (buf)->filename;
+ filename = BVAR (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_TEMP_SET_PT (XBUFFER (buf), BUF_BEGV (XBUFFER (buf)));
- readevalloop (buf, 0, filename, Feval,
+ specbind (Qlexical_binding, lisp_file_lexically_bound_p (buf) ? Qt : Qnil);
+ readevalloop (buf, 0, filename,
!NILP (printflag), unibyte, Qnil, Qnil, Qnil);
unbind_to (count, Qnil);
This function does not move point. */)
(Lisp_Object start, Lisp_Object end, Lisp_Object printflag, Lisp_Object read_function)
{
+ /* FIXME: Do the eval-sexp-add-defvars danse! */
int count = SPECPDL_INDEX ();
Lisp_Object tem, cbuf;
specbind (Qeval_buffer_list, Fcons (cbuf, Veval_buffer_list));
/* readevalloop calls functions which check the type of start and end. */
- readevalloop (cbuf, 0, XBUFFER (cbuf)->filename, Feval,
+ readevalloop (cbuf, 0, BVAR (XBUFFER (cbuf), filename),
!NILP (printflag), Qnil, read_function,
start, end);
read1 (register Lisp_Object readcharfun, int *pch, int first_in_list)
{
register int c;
- int uninterned_symbol = 0;
+ unsigned uninterned_symbol = 0;
int multibyte;
*pch = 0;
{
Lisp_Object tmp;
tmp = read_vector (readcharfun, 0);
- if (XVECTOR (tmp)->size < CHAR_TABLE_STANDARD_SLOTS)
+ if (XVECTOR_SIZE (tmp) < CHAR_TABLE_STANDARD_SLOTS)
error ("Invalid size char-table");
XSETPVECTYPE (XVECTOR (tmp), PVEC_CHAR_TABLE);
return tmp;
depth = XINT (AREF (tmp, 0));
if (depth < 1 || depth > 3)
error ("Invalid depth in char-table");
- size = XVECTOR (tmp)->size - 2;
+ size = XVECTOR_SIZE (tmp) - 2;
if (chartab_size [depth] != size)
error ("Invalid size char-table");
XSETPVECTYPE (XVECTOR (tmp), PVEC_SUB_CHAR_TABLE);
build them using function calls. */
Lisp_Object tmp;
tmp = read_vector (readcharfun, 1);
- return Fmake_byte_code (XVECTOR (tmp)->size,
+ return Fmake_byte_code (XVECTOR_SIZE (tmp),
XVECTOR (tmp)->contents);
}
if (c == '(')
{
char *p = read_buffer;
char *end = read_buffer + read_buffer_size;
- register int c;
+ register int ch;
/* Nonzero if we saw an escape sequence specifying
a multibyte character. */
int force_multibyte = 0;
int cancel = 0;
int nchars = 0;
- while ((c = READCHAR) >= 0
- && c != '\"')
+ while ((ch = READCHAR) >= 0
+ && ch != '\"')
{
if (end - p < MAX_MULTIBYTE_LENGTH)
{
end = read_buffer + read_buffer_size;
}
- if (c == '\\')
+ if (ch == '\\')
{
int modifiers;
- c = read_escape (readcharfun, 1);
+ ch = read_escape (readcharfun, 1);
- /* C is -1 if \ newline has just been seen */
- if (c == -1)
+ /* CH is -1 if \ newline has just been seen */
+ if (ch == -1)
{
if (p == read_buffer)
cancel = 1;
continue;
}
- modifiers = c & CHAR_MODIFIER_MASK;
- c = c & ~CHAR_MODIFIER_MASK;
+ modifiers = ch & CHAR_MODIFIER_MASK;
+ ch = ch & ~CHAR_MODIFIER_MASK;
- if (CHAR_BYTE8_P (c))
+ if (CHAR_BYTE8_P (ch))
force_singlebyte = 1;
- else if (! ASCII_CHAR_P (c))
+ else if (! ASCII_CHAR_P (ch))
force_multibyte = 1;
- else /* i.e. ASCII_CHAR_P (c) */
+ else /* i.e. ASCII_CHAR_P (ch) */
{
/* Allow `\C- ' and `\C-?'. */
if (modifiers == CHAR_CTL)
{
- if (c == ' ')
- c = 0, modifiers = 0;
- else if (c == '?')
- c = 127, modifiers = 0;
+ if (ch == ' ')
+ ch = 0, modifiers = 0;
+ else if (ch == '?')
+ ch = 127, modifiers = 0;
}
if (modifiers & CHAR_SHIFT)
{
/* Shift modifier is valid only with [A-Za-z]. */
- if (c >= 'A' && c <= 'Z')
+ if (ch >= 'A' && ch <= 'Z')
modifiers &= ~CHAR_SHIFT;
- else if (c >= 'a' && c <= 'z')
- c -= ('a' - 'A'), modifiers &= ~CHAR_SHIFT;
+ else if (ch >= 'a' && ch <= 'z')
+ ch -= ('a' - 'A'), modifiers &= ~CHAR_SHIFT;
}
if (modifiers & CHAR_META)
/* Move the meta bit to the right place for a
string. */
modifiers &= ~CHAR_META;
- c = BYTE8_TO_CHAR (c | 0x80);
+ ch = BYTE8_TO_CHAR (ch | 0x80);
force_singlebyte = 1;
}
}
/* Any modifiers remaining are invalid. */
if (modifiers)
error ("Invalid modifier in string");
- p += CHAR_STRING (c, (unsigned char *) p);
+ p += CHAR_STRING (ch, (unsigned char *) p);
}
else
{
- p += CHAR_STRING (c, (unsigned char *) p);
- if (CHAR_BYTE8_P (c))
+ p += CHAR_STRING (ch, (unsigned char *) p);
+ if (CHAR_BYTE8_P (ch))
force_singlebyte = 1;
- else if (! ASCII_CHAR_P (c))
+ else if (! ASCII_CHAR_P (ch))
force_multibyte = 1;
}
nchars++;
}
- if (c < 0)
+ if (ch < 0)
end_of_file_error ();
/* If purifying, and string starts with \ newline,
;
else if (force_singlebyte)
{
- nchars = str_as_unibyte (read_buffer, p - read_buffer);
+ nchars = str_as_unibyte ((unsigned char *) read_buffer,
+ p - read_buffer);
p = read_buffer + nchars;
}
else
- /* Otherwise, READ_BUFFER contains only ASCII. */
- ;
+ {
+ /* Otherwise, READ_BUFFER contains only ASCII. */
+ }
/* We want readchar_count to be the number of characters, not
bytes. Hence we adjust for multibyte characters in the
}
if (multibyte)
- p += CHAR_STRING (c, p);
+ p += CHAR_STRING (c, (unsigned char *) p);
else
*p++ = c;
c = READCHAR;
if (!quoted && !uninterned_symbol)
{
- register char *p1;
- p1 = read_buffer;
- if (*p1 == '+' || *p1 == '-') p1++;
- /* Is it an integer? */
- if (p1 != p)
- {
- while (p1 != p && (c = *p1) >= '0' && c <= '9') p1++;
- /* Integers can have trailing decimal points. */
- if (p1 > read_buffer && p1 < p && *p1 == '.') p1++;
- if (p1 == p)
- /* It is an integer. */
- {
- if (p1[-1] == '.')
- p1[-1] = '\0';
- {
- /* EMACS_INT n = atol (read_buffer); */
- char *endptr = NULL;
- EMACS_INT n = (errno = 0,
- strtol (read_buffer, &endptr, 10));
- if (errno == ERANGE && endptr)
- {
- Lisp_Object args
- = Fcons (make_string (read_buffer,
- endptr - read_buffer),
- Qnil);
- xsignal (Qoverflow_error, args);
- }
- return make_fixnum_or_float (n);
- }
- }
- }
- if (isfloat_string (read_buffer, 0))
- {
- /* Compute NaN and infinities using 0.0 in a variable,
- to cope with compilers that think they are smarter
- than we are. */
- double zero = 0.0;
-
- double value;
-
- /* Negate the value ourselves. This treats 0, NaNs,
- and infinity properly on IEEE floating point hosts,
- and works around a common bug where atof ("-0.0")
- drops the sign. */
- int negative = read_buffer[0] == '-';
-
- /* The only way p[-1] can be 'F' or 'N', after isfloat_string
- returns 1, is if the input ends in e+INF or e+NaN. */
- switch (p[-1])
- {
- case 'F':
- value = 1.0 / zero;
- break;
- case 'N':
- value = zero / zero;
-
- /* If that made a "negative" NaN, negate it. */
-
- {
- 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;
- }
- }
- /* Now VALUE is a positive NaN. */
- break;
- default:
- value = atof (read_buffer + negative);
- break;
- }
-
- return make_float (negative ? - value : value);
- }
+ Lisp_Object result = string_to_number (read_buffer, 10, 0);
+ if (! NILP (result))
+ return result;
}
{
Lisp_Object name, result;
EMACS_INT nbytes = p - read_buffer;
EMACS_INT nchars
- = (multibyte ? multibyte_chars_in_text (read_buffer, nbytes)
+ = (multibyte
+ ? multibyte_chars_in_text ((unsigned char *) read_buffer,
+ nbytes)
: nbytes);
if (uninterned_symbol && ! NILP (Vpurify_flag))
}
\f
+static inline int
+digit_to_number (int character, int base)
+{
+ int digit;
+
+ if ('0' <= character && character <= '9')
+ digit = character - '0';
+ else if ('a' <= character && character <= 'z')
+ digit = character - 'a' + 10;
+ else if ('A' <= character && character <= 'Z')
+ digit = character - 'A' + 10;
+ else
+ return -1;
+
+ return digit < base ? digit : -1;
+}
+
#define LEAD_INT 1
#define DOT_CHAR 2
#define TRAIL_INT 4
-#define E_CHAR 8
-#define EXP_INT 16
+#define E_EXP 16
-int
-isfloat_string (const char *cp, int ignore_trailing)
+
+/* Convert STRING to a number, assuming base BASE. Return a fixnum if CP has
+ integer syntax and fits in a fixnum, else return the nearest float if CP has
+ either floating point or integer syntax and BASE is 10, else return nil. If
+ IGNORE_TRAILING is nonzero, consider just the longest prefix of CP that has
+ valid floating point syntax. Signal an overflow if BASE is not 10 and the
+ number has integer syntax but does not fit. */
+
+Lisp_Object
+string_to_number (char const *string, int base, int ignore_trailing)
{
int state;
- const char *start = cp;
+ char const *cp = string;
+ int leading_digit;
+ int float_syntax = 0;
+ double value = 0;
+
+ /* Compute NaN and infinities using a variable, to cope with compilers that
+ think they are smarter than we are. */
+ double zero = 0;
+
+ /* Negate the value ourselves. This treats 0, NaNs, and infinity properly on
+ IEEE floating point hosts, and works around a formerly-common bug where
+ atof ("-0.0") drops the sign. */
+ int negative = *cp == '-';
+
+ int signedp = negative || *cp == '+';
+ cp += signedp;
state = 0;
- if (*cp == '+' || *cp == '-')
- cp++;
- if (*cp >= '0' && *cp <= '9')
+ leading_digit = digit_to_number (*cp, base);
+ if (0 <= leading_digit)
{
state |= LEAD_INT;
- while (*cp >= '0' && *cp <= '9')
- cp++;
+ do
+ ++cp;
+ while (0 <= digit_to_number (*cp, base));
}
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')
+ if (base == 10)
{
- state |= EXP_INT;
- cp += 3;
+ if ('0' <= *cp && *cp <= '9')
+ {
+ state |= TRAIL_INT;
+ do
+ cp++;
+ while ('0' <= *cp && *cp <= '9');
+ }
+ if (*cp == 'e' || *cp == 'E')
+ {
+ char const *ecp = cp;
+ cp++;
+ if (*cp == '+' || *cp == '-')
+ cp++;
+ if ('0' <= *cp && *cp <= '9')
+ {
+ state |= E_EXP;
+ do
+ cp++;
+ while ('0' <= *cp && *cp <= '9');
+ }
+ else if (cp[-1] == '+'
+ && cp[0] == 'I' && cp[1] == 'N' && cp[2] == 'F')
+ {
+ state |= E_EXP;
+ cp += 3;
+ value = 1.0 / zero;
+ }
+ else if (cp[-1] == '+'
+ && cp[0] == 'N' && cp[1] == 'a' && cp[2] == 'N')
+ {
+ state |= E_EXP;
+ cp += 3;
+ value = zero / zero;
+
+ /* If that made a "negative" NaN, negate it. */
+ {
+ 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;
+ }
+ }
+ /* Now VALUE is a positive NaN. */
+ }
+ else
+ cp = ecp;
+ }
+
+ float_syntax = ((state & (DOT_CHAR|TRAIL_INT)) == (DOT_CHAR|TRAIL_INT)
+ || state == (LEAD_INT|E_EXP));
}
- else if (cp[-1] == '+' && cp[0] == 'N' && cp[1] == 'a' && cp[2] == 'N')
+
+ /* Return nil if the number uses invalid syntax. If IGNORE_TRAILING, accept
+ any prefix that matches. Otherwise, the entire string must match. */
+ if (! (ignore_trailing
+ ? ((state & LEAD_INT) != 0 || float_syntax)
+ : (!*cp && ((state & ~DOT_CHAR) == LEAD_INT || float_syntax))))
+ return Qnil;
+
+ /* If the number uses integer and not float syntax, and is in C-language
+ range, use its value, preferably as a fixnum. */
+ if (0 <= leading_digit && ! float_syntax)
{
- state |= EXP_INT;
- cp += 3;
+ uintmax_t n;
+
+ /* Fast special case for single-digit integers. This also avoids a
+ glitch when BASE is 16 and IGNORE_TRAILING is nonzero, because in that
+ case some versions of strtoumax accept numbers like "0x1" that Emacs
+ does not allow. */
+ if (digit_to_number (string[signedp + 1], base) < 0)
+ return make_number (negative ? -leading_digit : leading_digit);
+
+ errno = 0;
+ n = strtoumax (string + signedp, NULL, base);
+ if (errno == ERANGE)
+ {
+ /* Unfortunately there's no simple and accurate way to convert
+ non-base-10 numbers that are out of C-language range. */
+ if (base != 10)
+ xsignal (Qoverflow_error, list1 (build_string (string)));
+ }
+ else if (n <= (negative ? -MOST_NEGATIVE_FIXNUM : MOST_POSITIVE_FIXNUM))
+ {
+ EMACS_INT signed_n = n;
+ return make_number (negative ? -signed_n : signed_n);
+ }
+ else
+ value = n;
}
- return ((ignore_trailing
- || *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)));
+ /* Either the number uses float syntax, or it does not fit into a fixnum.
+ Convert it from string to floating point, unless the value is already
+ known because it is an infinity, a NAN, or its absolute value fits in
+ uintmax_t. */
+ if (! value)
+ value = atof (string + signedp);
+
+ return make_float (negative ? -value : value);
}
\f
len = Flength (tem);
vector = (read_pure ? make_pure_vector (XINT (len)) : Fmake_vector (len, Qnil));
- size = XVECTOR (vector)->size;
+ size = XVECTOR_SIZE (vector);
ptr = XVECTOR (vector)->contents;
for (i = 0; i < size; i++)
{
}
}
\f
-Lisp_Object initial_obarray;
+static Lisp_Object initial_obarray;
/* oblookup stores the bucket number here, for the sake of Funintern. */
-int oblookup_last_bucket_number;
+static int oblookup_last_bucket_number;
-static int hash_string (const unsigned char *ptr, int len);
+static int hash_string (const char *ptr, int len);
/* Get an error if OBARRAY is not an obarray.
If it is one, return it. */
Lisp_Object
check_obarray (Lisp_Object obarray)
{
- if (!VECTORP (obarray) || XVECTOR (obarray)->size == 0)
+ if (!VECTORP (obarray) || XVECTOR_SIZE (obarray) == 0)
{
/* If Vobarray is now invalid, force it to be valid. */
if (EQ (Vobarray, obarray)) Vobarray = initial_obarray;
Lisp_Object obarray;
obarray = Vobarray;
- if (!VECTORP (obarray) || XVECTOR (obarray)->size == 0)
+ if (!VECTORP (obarray) || XVECTOR_SIZE (obarray) == 0)
obarray = check_obarray (obarray);
tem = oblookup (obarray, str, len, len);
if (SYMBOLP (tem))
Lisp_Object obarray;
obarray = Vobarray;
- if (!VECTORP (obarray) || XVECTOR (obarray)->size == 0)
+ if (!VECTORP (obarray) || XVECTOR_SIZE (obarray) == 0)
obarray = check_obarray (obarray);
tem = oblookup (obarray, str, len, len);
if (SYMBOLP (tem))
return Fintern (make_pure_c_string (str), obarray);
}
-
-/* Create an uninterned symbol with name STR. */
-
-Lisp_Object
-make_symbol (const char *str)
-{
- int len = strlen (str);
-
- return Fmake_symbol (!NILP (Vpurify_flag)
- ? make_pure_string (str, len, len, 0)
- : make_string (str, len));
-}
\f
DEFUN ("intern", Fintern, Sintern, 1, 2, 0,
doc: /* Return the canonical symbol whose name is STRING.
Lisp_Object bucket, tem;
if (!VECTORP (obarray)
- || (obsize = XVECTOR (obarray)->size) == 0)
+ || (obsize = XVECTOR_SIZE (obarray)) == 0)
{
obarray = check_obarray (obarray);
- obsize = XVECTOR (obarray)->size;
+ obsize = XVECTOR_SIZE (obarray);
}
/* This is sometimes needed in the middle of GC. */
obsize &= ~ARRAY_MARK_FLAG;
}
static int
-hash_string (const unsigned char *ptr, int len)
+hash_string (const char *ptr, int len)
{
- register const unsigned char *p = ptr;
- register const unsigned char *end = p + len;
+ register const char *p = ptr;
+ register const char *end = p + len;
register unsigned char c;
register int hash = 0;
register int i;
register Lisp_Object tail;
CHECK_VECTOR (obarray);
- for (i = XVECTOR (obarray)->size - 1; i >= 0; i--)
+ for (i = XVECTOR_SIZE (obarray) - 1; i >= 0; i--)
{
tail = XVECTOR (obarray)->contents[i];
if (SYMBOLP (tail))
{
Lisp_Object sym;
sym = intern_c_string (sname->symbol_name);
- XSETPVECTYPE (sname, PVEC_SUBR);
+ XSETTYPED_PVECTYPE (sname, size, PVEC_SUBR);
XSETSUBR (XSYMBOL (sym)->function, sname);
}
sym = intern_c_string (namestring);
i_fwd->type = Lisp_Fwd_Int;
i_fwd->intvar = address;
+ XSYMBOL (sym)->declared_special = 1;
XSYMBOL (sym)->redirect = SYMBOL_FORWARDED;
SET_SYMBOL_FWD (XSYMBOL (sym), (union Lisp_Fwd *)i_fwd);
}
sym = intern_c_string (namestring);
b_fwd->type = Lisp_Fwd_Bool;
b_fwd->boolvar = address;
+ XSYMBOL (sym)->declared_special = 1;
XSYMBOL (sym)->redirect = SYMBOL_FORWARDED;
SET_SYMBOL_FWD (XSYMBOL (sym), (union Lisp_Fwd *)b_fwd);
Vbyte_boolean_vars = Fcons (sym, Vbyte_boolean_vars);
sym = intern_c_string (namestring);
o_fwd->type = Lisp_Fwd_Obj;
o_fwd->objvar = address;
+ XSYMBOL (sym)->declared_special = 1;
XSYMBOL (sym)->redirect = SYMBOL_FORWARDED;
SET_SYMBOL_FWD (XSYMBOL (sym), (union Lisp_Fwd *)o_fwd);
}
sym = intern_c_string (namestring);
ko_fwd->type = Lisp_Fwd_Kboard_Obj;
ko_fwd->offset = offset;
+ XSYMBOL (sym)->declared_special = 1;
XSYMBOL (sym)->redirect = SYMBOL_FORWARDED;
SET_SYMBOL_FWD (XSYMBOL (sym), (union Lisp_Fwd *)ko_fwd);
}
Vbytecomp_version_regexp
= make_pure_c_string ("^;;;.\\(in Emacs version\\|bytecomp version FSF\\)");
+ Qlexical_binding = intern ("lexical-binding");
+ staticpro (&Qlexical_binding);
+ DEFVAR_LISP ("lexical-binding", Vlexical_binding,
+ doc: /* If non-nil, use lexical binding when evaluating code.
+This only applies to code evaluated by `eval-buffer' and `eval-region'.
+This variable is automatically set from the file variables of an interpreted
+ Lisp file read using `load'. */);
+ Fmake_variable_buffer_local (Qlexical_binding);
+
DEFVAR_LISP ("eval-buffer-list", Veval_buffer_list,
doc: /* List of buffers being read from by calls to `eval-buffer' and `eval-region'. */);
Veval_buffer_list = Qnil;
Qfile_truename = intern_c_string ("file-truename");
staticpro (&Qfile_truename) ;
+ Qdir_ok = intern_c_string ("dir-ok");
+ staticpro (&Qdir_ok);
+
Qdo_after_load_evaluation = intern_c_string ("do-after-load-evaluation");
staticpro (&Qdo_after_load_evaluation) ;
HCoop / bpt / emacs.git / blobdiff