#include <config.h>
#include "lisp.h"
#include "puresize.h"
+#include "charset.h"
#ifndef standalone
#include "buffer.h"
#ifdef LISP_FLOAT_TYPE
#ifdef STDC_HEADERS
+#include <float.h>
#include <stdlib.h>
#endif
+/* If IEEE_FLOATING_POINT isn't defined, default it from FLT_*. */
+#ifndef IEEE_FLOATING_POINT
+#if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \
+ && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128)
+#define IEEE_FLOATING_POINT 1
+#else
+#define IEEE_FLOATING_POINT 0
+#endif
+#endif
+
/* Work around a problem that happens because math.h on hpux 7
defines two static variables--which, in Emacs, are not really static,
because `static' is defined as nothing. The problem is that they are
#endif
static Lisp_Object Qinteger, Qsymbol, Qstring, Qcons, Qmarker, Qoverlay;
-static Lisp_Object Qfloat, Qwindow_configuration, Qprocess, Qwindow;
+static Lisp_Object Qfloat, Qwindow_configuration, Qwindow;
+Lisp_Object Qprocess;
static Lisp_Object Qcompiled_function, Qbuffer, Qframe, Qvector;
static Lisp_Object Qchar_table, Qbool_vector;
static Lisp_Object swap_in_symval_forwarding ();
+Lisp_Object set_internal ();
+
Lisp_Object
wrong_type_argument (predicate, value)
register Lisp_Object predicate, value;
{
if (STRINGP (value) &&
(EQ (predicate, Qintegerp) || EQ (predicate, Qinteger_or_marker_p)))
- return Fstring_to_number (value);
+ return Fstring_to_number (value, Qnil);
if (INTEGERP (value) && EQ (predicate, Qstringp))
return Fnumber_to_string (value);
}
"Set SYMBOL's value to NEWVAL, and return NEWVAL.")
(symbol, newval)
register Lisp_Object symbol, newval;
+{
+ return set_internal (symbol, newval, 0);
+}
+
+/* Stpre the value NEWVAL into SYMBOL.
+ If BINDFLAG is zero, then if this symbol is supposed to become
+ local in every buffer where it is set, then we make it local.
+ If BINDFLAG is nonzero, we don't do that. */
+
+Lisp_Object
+set_internal (symbol, newval, bindflag)
+ register Lisp_Object symbol, newval;
+ int bindflag;
{
int voide = EQ (newval, Qunbound);
/* This buffer still sees the default value. */
/* If the variable is a Lisp_Some_Buffer_Local_Value,
+ or if this is `let' rather than `set',
make CURRENT-ALIST-ELEMENT point to itself,
indicating that we're seeing the default value. */
- if (SOME_BUFFER_LOCAL_VALUEP (valcontents))
+ if (bindflag || SOME_BUFFER_LOCAL_VALUEP (valcontents))
tem1 = XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr;
- /* If it's a Lisp_Buffer_Local_Value, give this buffer a
- new assoc for a local value and set
+ /* If it's a Lisp_Buffer_Local_Value, being set not bound,
+ give this buffer a new assoc for a local value and set
CURRENT-ALIST-ELEMENT to point to that. */
else
{
if (idxval < 0)
args_out_of_range (array, idx);
-#if 1
- if ((unsigned) idxval >= CHAR_TABLE_ORDINARY_SLOTS)
- args_out_of_range (array, idx);
- return val = XCHAR_TABLE (array)->contents[idxval];
-#else /* 0 */
- if ((unsigned) idxval < CHAR_TABLE_ORDINARY_SLOTS)
- val = XCHAR_TABLE (array)->data[idxval];
+ if (idxval < CHAR_TABLE_SINGLE_BYTE_SLOTS)
+ {
+ /* For ASCII and 8-bit European characters, the element is
+ stored in the top table. */
+ val = XCHAR_TABLE (array)->contents[idxval];
+ if (NILP (val))
+ val = XCHAR_TABLE (array)->defalt;
+ while (NILP (val)) /* Follow parents until we find some value. */
+ {
+ array = XCHAR_TABLE (array)->parent;
+ if (NILP (array))
+ return Qnil;
+ val = XCHAR_TABLE (array)->contents[idxval];
+ if (NILP (val))
+ val = XCHAR_TABLE (array)->defalt;
+ }
+ return val;
+ }
else
{
- int charset;
- unsigned char c1, c2;
- Lisp_Object val, temp;
+ int code[4], i;
+ Lisp_Object sub_table;
- BREAKUP_NON_ASCII_CHAR (idxval, charset, c1, c2);
+ SPLIT_NON_ASCII_CHAR (idxval, code[0], code[1], code[2]);
+ if (code[0] != CHARSET_COMPOSITION)
+ {
+ if (code[1] < 32) code[1] = -1;
+ else if (code[2] < 32) code[2] = -1;
+ }
+ /* Here, the possible range of CODE[0] (== charset ID) is
+ 128..MAX_CHARSET. Since the top level char table contains
+ data for multibyte characters after 256th element, we must
+ increment CODE[0] by 128 to get a correct index. */
+ code[0] += 128;
+ code[3] = -1; /* anchor */
try_parent_char_table:
- val = XCHAR_TABLE (array)->contents[charset];
- if (c1 == 0 || !CHAR_TABLE_P (val))
- return val;
-
- temp = XCHAR_TABLE (val)->contents[c1];
- if (NILP (temp))
- val = XCHAR_TABLE (val)->defalt;
- else
- val = temp;
-
- if (NILP (val) && !NILP (XCHAR_TABLE (array)->parent))
+ sub_table = array;
+ for (i = 0; code[i] >= 0; i++)
{
- array = XCHAR_TABLE (array)->parent;
- goto try_parent_char_table;
-
+ val = XCHAR_TABLE (sub_table)->contents[code[i]];
+ if (SUB_CHAR_TABLE_P (val))
+ sub_table = val;
+ else
+ {
+ if (NILP (val))
+ val = XCHAR_TABLE (sub_table)->defalt;
+ if (NILP (val))
+ {
+ array = XCHAR_TABLE (array)->parent;
+ if (!NILP (array))
+ goto try_parent_char_table;
+ }
+ return val;
+ }
}
-
- if (c2 == 0 || !CHAR_TABLE_P (val))
- return val;
-
- temp = XCHAR_TABLE (val)->contents[c2];
- if (NILP (temp))
- val = XCHAR_TABLE (val)->defalt;
- else
- val = temp;
-
- if (NILP (val) && !NILP (XCHAR_TABLE (array)->parent))
+ /* Here, VAL is a sub char table. We try the default value
+ and parent. */
+ val = XCHAR_TABLE (val)->defalt;
+ if (NILP (val))
{
array = XCHAR_TABLE (array)->parent;
- goto try_parent_char_table;
+ if (!NILP (array))
+ goto try_parent_char_table;
}
-
return val;
}
-#endif /* 0 */
}
else
{
if (idxval < 0)
args_out_of_range (array, idx);
-#if 1
- if (idxval >= CHAR_TABLE_ORDINARY_SLOTS)
- args_out_of_range (array, idx);
- XCHAR_TABLE (array)->contents[idxval] = newelt;
- return newelt;
-#else /* 0 */
- if (idxval < CHAR_TABLE_ORDINARY_SLOTS)
- val = XCHAR_TABLE (array)->contents[idxval];
+ if (idxval < CHAR_TABLE_SINGLE_BYTE_SLOTS)
+ XCHAR_TABLE (array)->contents[idxval] = newelt;
else
{
- int charset;
- unsigned char c1, c2;
- Lisp_Object val, val2;
-
- BREAKUP_NON_ASCII_CHAR (idxval, charset, c1, c2);
+ int code[4], i;
+ Lisp_Object val;
- if (c1 == 0)
- return XCHAR_TABLE (array)->contents[charset] = newelt;
-
- val = XCHAR_TABLE (array)->contents[charset];
- if (!CHAR_TABLE_P (val))
- XCHAR_TABLE (array)->contents[charset]
- = val = Fmake_char_table (Qnil);
-
- if (c2 == 0)
- return XCHAR_TABLE (val)->contents[c1] = newelt;
-
- val2 = XCHAR_TABLE (val)->contents[c2];
- if (!CHAR_TABLE_P (val2))
- XCHAR_TABLE (val)->contents[charset]
- = val2 = Fmake_char_table (Qnil);
-
- return XCHAR_TABLE (val2)->contents[c2] = newelt;
+ SPLIT_NON_ASCII_CHAR (idxval, code[0], code[1], code[2]);
+ if (code[0] != CHARSET_COMPOSITION)
+ {
+ if (code[1] < 32) code[1] = -1;
+ else if (code[2] < 32) code[2] = -1;
+ }
+ /* See the comment of the corresponding part in Faref. */
+ code[0] += 128;
+ code[3] = -1; /* anchor */
+ for (i = 0; code[i + 1] >= 0; i++)
+ {
+ val = XCHAR_TABLE (array)->contents[code[i]];
+ if (SUB_CHAR_TABLE_P (val))
+ array = val;
+ else
+ /* VAL is a leaf. Create a sub char table with the
+ default value VAL here and look into it. */
+ array = (XCHAR_TABLE (array)->contents[code[i]]
+ = make_sub_char_table (val));
+ }
+ XCHAR_TABLE (array)->contents[code[i]] = newelt;
}
-#endif /* 0 */
}
else
{
return build_string (buffer);
}
-DEFUN ("string-to-number", Fstring_to_number, Sstring_to_number, 1, 1, 0,
+INLINE static int
+digit_to_number (character, base)
+ int character, base;
+{
+ int digit;
+
+ if (character >= '0' && character <= '9')
+ digit = character - '0';
+ else if (character >= 'a' && character <= 'z')
+ digit = character - 'a' + 10;
+ else if (character >= 'A' && character <= 'Z')
+ digit = character - 'A' + 10;
+ else
+ return -1;
+
+ if (digit >= base)
+ return -1;
+ else
+ return digit;
+}
+
+DEFUN ("string-to-number", Fstring_to_number, Sstring_to_number, 1, 2, 0,
"Convert STRING to a number by parsing it as a decimal number.\n\
This parses both integers and floating point numbers.\n\
-It ignores leading spaces and tabs.")
- (string)
- register Lisp_Object string;
+It ignores leading spaces and tabs.\n\
+\n\
+If BASE, interpret STRING as a number in that base. If BASE isn't\n\
+present, base 10 is used. BASE must be between 2 and 16 (inclusive).\n\
+Floating point numbers always use base 10.")
+ (string, base)
+ register Lisp_Object string, base;
{
- Lisp_Object value;
- unsigned char *p;
+ register unsigned char *p;
+ register int b, digit, v = 0;
+ int negative = 1;
CHECK_STRING (string, 0);
+ if (NILP (base))
+ b = 10;
+ else
+ {
+ CHECK_NUMBER (base, 1);
+ b = XINT (base);
+ if (b < 2 || b > 16)
+ Fsignal (Qargs_out_of_range, Fcons (base, Qnil));
+ }
+
p = XSTRING (string)->data;
/* Skip any whitespace at the front of the number. Some versions of
while (*p == ' ' || *p == '\t')
p++;
+ if (*p == '-')
+ {
+ negative = -1;
+ p++;
+ }
+ else if (*p == '+')
+ p++;
+
#ifdef LISP_FLOAT_TYPE
if (isfloat_string (p))
return make_float (atof (p));
#endif /* LISP_FLOAT_TYPE */
- if (sizeof (int) == sizeof (EMACS_INT))
- XSETINT (value, atoi (p));
- else if (sizeof (long) == sizeof (EMACS_INT))
- XSETINT (value, atol (p));
- else
- abort ();
- return value;
+ while (1)
+ {
+ int digit = digit_to_number (*p++, b);
+ if (digit < 0)
+ break;
+ v = v * b + digit;
+ }
+
+ return make_number (negative * v);
}
+
\f
enum arithop
{ Aadd, Asub, Amult, Adiv, Alogand, Alogior, Alogxor, Amax, Amin };
extern Lisp_Object float_arith_driver ();
+extern Lisp_Object fmod_float ();
Lisp_Object
arith_driver (code, nargs, args)
return val;
}
-#ifdef LISP_FLOAT_TYPE
-
#undef isnan
#define isnan(x) ((x) != (x))
+#ifdef LISP_FLOAT_TYPE
+
Lisp_Object
float_arith_driver (accum, argnum, code, nargs, args)
double accum;
accum = next;
else
{
- if (next == 0)
+ if (! IEEE_FLOATING_POINT && next == 0)
Fsignal (Qarith_error, Qnil);
accum /= next;
}
fmod (f1, f2)
double f1, f2;
{
+ double r = f1;
+
if (f2 < 0.0)
f2 = -f2;
- return (f1 - f2 * floor (f1/f2));
+
+ /* If the magnitude of the result exceeds that of the divisor, or
+ the sign of the result does not agree with that of the dividend,
+ iterate with the reduced value. This does not yield a
+ particularly accurate result, but at least it will be in the
+ range promised by fmod. */
+ do
+ r -= f2 * floor (r / f2);
+ while (f2 <= (r < 0 ? -r : r) || ((r < 0) != (f1 < 0) && ! isnan (r)));
+
+ return r;
}
#endif /* ! HAVE_FMOD */
CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y, 1);
if (FLOATP (x) || FLOATP (y))
- {
- double f1, f2;
-
- f1 = FLOATP (x) ? XFLOAT (x)->data : XINT (x);
- f2 = FLOATP (y) ? XFLOAT (y)->data : XINT (y);
- if (f2 == 0)
- Fsignal (Qarith_error, Qnil);
-
- f1 = fmod (f1, f2);
- /* If the "remainder" comes out with the wrong sign, fix it. */
- if (f2 < 0 ? f1 > 0 : f1 < 0)
- f1 += f2;
- return (make_float (f1));
- }
+ return fmod_float (x, y);
+
#else /* not LISP_FLOAT_TYPE */
CHECK_NUMBER_COERCE_MARKER (x, 0);
CHECK_NUMBER_COERCE_MARKER (y, 1);