/* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
- Copyright (C) 1985, 86, 88, 93, 94, 95 Free Software Foundation, Inc.
+ Copyright (C) 1985,86,88,93,94,95,97, 1998 Free Software Foundation, Inc.
This file is part of GNU Emacs.
#ifdef LISP_FLOAT_TYPE
#ifdef STDC_HEADERS
-#include <float.h>
#include <stdlib.h>
+#include <float.h>
#endif
/* If IEEE_FLOATING_POINT isn't defined, default it from FLT_*. */
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);
}
/* Data type predicates */
DEFUN ("eq", Feq, Seq, 2, 2, 0,
- "T if the two args are the same Lisp object.")
+ "Return t if the two args are the same Lisp object.")
(obj1, obj2)
Lisp_Object obj1, obj2;
{
return Qnil;
}
-DEFUN ("null", Fnull, Snull, 1, 1, 0, "T if OBJECT is nil.")
+DEFUN ("null", Fnull, Snull, 1, 1, 0, "Return t if OBJECT is nil.")
(object)
Lisp_Object object;
{
}
}
-DEFUN ("consp", Fconsp, Sconsp, 1, 1, 0, "T if OBJECT is a cons cell.")
+DEFUN ("consp", Fconsp, Sconsp, 1, 1, 0, "Return t if OBJECT is a cons cell.")
(object)
Lisp_Object object;
{
return Qnil;
}
-DEFUN ("atom", Fatom, Satom, 1, 1, 0, "T if OBJECT is not a cons cell. This includes nil.")
+DEFUN ("atom", Fatom, Satom, 1, 1, 0,
+ "Return t if OBJECT is not a cons cell. This includes nil.")
(object)
Lisp_Object object;
{
return Qt;
}
-DEFUN ("listp", Flistp, Slistp, 1, 1, 0, "T if OBJECT is a list. This includes nil.")
+DEFUN ("listp", Flistp, Slistp, 1, 1, 0,
+ "Return t if OBJECT is a list. This includes nil.")
(object)
Lisp_Object object;
{
return Qnil;
}
-DEFUN ("nlistp", Fnlistp, Snlistp, 1, 1, 0, "T if OBJECT is not a list. Lists include nil.")
+DEFUN ("nlistp", Fnlistp, Snlistp, 1, 1, 0,
+ "Return t if OBJECT is not a list. Lists include nil.")
(object)
Lisp_Object object;
{
return Qt;
}
\f
-DEFUN ("symbolp", Fsymbolp, Ssymbolp, 1, 1, 0, "T if OBJECT is a symbol.")
+DEFUN ("symbolp", Fsymbolp, Ssymbolp, 1, 1, 0,
+ "Return t if OBJECT is a symbol.")
(object)
Lisp_Object object;
{
return Qnil;
}
-DEFUN ("vectorp", Fvectorp, Svectorp, 1, 1, 0, "T if OBJECT is a vector.")
+DEFUN ("vectorp", Fvectorp, Svectorp, 1, 1, 0,
+ "Return t if OBJECT is a vector.")
(object)
Lisp_Object object;
{
return Qnil;
}
-DEFUN ("stringp", Fstringp, Sstringp, 1, 1, 0, "T if OBJECT is a string.")
+DEFUN ("stringp", Fstringp, Sstringp, 1, 1, 0,
+ "Return t if OBJECT is a string.")
(object)
Lisp_Object object;
{
return Qnil;
}
-DEFUN ("char-table-p", Fchar_table_p, Schar_table_p, 1, 1, 0, "T if OBJECT is a char-table.")
+DEFUN ("multibyte-string-p", Fmultibyte_string_p, Smultibyte_string_p,
+ 1, 1, 0, "Return t if OBJECT is a multibyte string.")
+ (object)
+ Lisp_Object object;
+{
+ if (STRINGP (object) && STRING_MULTIBYTE (object))
+ return Qt;
+ return Qnil;
+}
+
+DEFUN ("char-table-p", Fchar_table_p, Schar_table_p, 1, 1, 0,
+ "Return t if OBJECT is a char-table.")
(object)
Lisp_Object object;
{
DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p,
Svector_or_char_table_p, 1, 1, 0,
- "T if OBJECT is a char-table or vector.")
+ "Return t if OBJECT is a char-table or vector.")
(object)
Lisp_Object object;
{
return Qnil;
}
-DEFUN ("bool-vector-p", Fbool_vector_p, Sbool_vector_p, 1, 1, 0, "T if OBJECT is a bool-vector.")
+DEFUN ("bool-vector-p", Fbool_vector_p, Sbool_vector_p, 1, 1, 0, "Return t if OBJECT is a bool-vector.")
(object)
Lisp_Object object;
{
return Qnil;
}
-DEFUN ("arrayp", Farrayp, Sarrayp, 1, 1, 0, "T if OBJECT is an array (string or vector).")
+DEFUN ("arrayp", Farrayp, Sarrayp, 1, 1, 0, "Return t if OBJECT is an array (string or vector).")
(object)
Lisp_Object object;
{
- if (VECTORP (object) || STRINGP (object))
+ if (VECTORP (object) || STRINGP (object)
+ || CHAR_TABLE_P (object) || BOOL_VECTOR_P (object))
return Qt;
return Qnil;
}
DEFUN ("sequencep", Fsequencep, Ssequencep, 1, 1, 0,
- "T if OBJECT is a sequence (list or array).")
+ "Return t if OBJECT is a sequence (list or array).")
(object)
register Lisp_Object object;
{
return Qnil;
}
-DEFUN ("bufferp", Fbufferp, Sbufferp, 1, 1, 0, "T if OBJECT is an editor buffer.")
+DEFUN ("bufferp", Fbufferp, Sbufferp, 1, 1, 0, "Return t if OBJECT is an editor buffer.")
(object)
Lisp_Object object;
{
return Qnil;
}
-DEFUN ("markerp", Fmarkerp, Smarkerp, 1, 1, 0, "T if OBJECT is a marker (editor pointer).")
+DEFUN ("markerp", Fmarkerp, Smarkerp, 1, 1, 0, "Return t if OBJECT is a marker (editor pointer).")
(object)
Lisp_Object object;
{
return Qnil;
}
-DEFUN ("subrp", Fsubrp, Ssubrp, 1, 1, 0, "T if OBJECT is a built-in function.")
+DEFUN ("subrp", Fsubrp, Ssubrp, 1, 1, 0, "Return t if OBJECT is a built-in function.")
(object)
Lisp_Object object;
{
}
DEFUN ("byte-code-function-p", Fbyte_code_function_p, Sbyte_code_function_p,
- 1, 1, 0, "T if OBJECT is a byte-compiled function object.")
+ 1, 1, 0, "Return t if OBJECT is a byte-compiled function object.")
(object)
Lisp_Object object;
{
}
DEFUN ("char-or-string-p", Fchar_or_string_p, Schar_or_string_p, 1, 1, 0,
- "T if OBJECT is a character (an integer) or a string.")
+ "Return t if OBJECT is a character (an integer) or a string.")
(object)
register Lisp_Object object;
{
return Qnil;
}
\f
-DEFUN ("integerp", Fintegerp, Sintegerp, 1, 1, 0, "T if OBJECT is an integer.")
+DEFUN ("integerp", Fintegerp, Sintegerp, 1, 1, 0, "Return t if OBJECT is an integer.")
(object)
Lisp_Object object;
{
}
DEFUN ("integer-or-marker-p", Finteger_or_marker_p, Sinteger_or_marker_p, 1, 1, 0,
- "T if OBJECT is an integer or a marker (editor pointer).")
+ "Return t if OBJECT is an integer or a marker (editor pointer).")
(object)
register Lisp_Object object;
{
}
DEFUN ("natnump", Fnatnump, Snatnump, 1, 1, 0,
- "T if OBJECT is a nonnegative integer.")
+ "Return t if OBJECT is a nonnegative integer.")
(object)
Lisp_Object object;
{
}
DEFUN ("numberp", Fnumberp, Snumberp, 1, 1, 0,
- "T if OBJECT is a number (floating point or integer).")
+ "Return t if OBJECT is a number (floating point or integer).")
(object)
Lisp_Object object;
{
DEFUN ("number-or-marker-p", Fnumber_or_marker_p,
Snumber_or_marker_p, 1, 1, 0,
- "T if OBJECT is a number or a marker.")
+ "Return t if OBJECT is a number or a marker.")
(object)
Lisp_Object object;
{
#ifdef LISP_FLOAT_TYPE
DEFUN ("floatp", Ffloatp, Sfloatp, 1, 1, 0,
- "T if OBJECT is a floating point number.")
+ "Return t if OBJECT is a floating point number.")
(object)
Lisp_Object object;
{
\f
/* Extract and set components of symbols */
-DEFUN ("boundp", Fboundp, Sboundp, 1, 1, 0, "T if SYMBOL's value is not void.")
+DEFUN ("boundp", Fboundp, Sboundp, 1, 1, 0, "Return t if SYMBOL's value is not void.")
(symbol)
register Lisp_Object symbol;
{
return (EQ (valcontents, Qunbound) ? Qnil : Qt);
}
-DEFUN ("fboundp", Ffboundp, Sfboundp, 1, 1, 0, "T if SYMBOL's function definition is not void.")
+DEFUN ("fboundp", Ffboundp, Sfboundp, 1, 1, 0, "Return t if SYMBOL's function definition is not void.")
(symbol)
register Lisp_Object symbol;
{
return set_internal (symbol, newval, 0);
}
-/* Stpre the value NEWVAL into SYMBOL.
+/* Store 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. */
}
DEFUN ("default-boundp", Fdefault_boundp, Sdefault_boundp, 1, 1, 0,
- "Return T if SYMBOL has a non-void default value.\n\
+ "Return t if SYMBOL has a non-void default value.\n\
This is the value that is seen in buffers that do not have their own values\n\
for this variable.")
(symbol)
if (STRINGP (array))
{
Lisp_Object val;
+ int c, idxval_byte;
+
if (idxval < 0 || idxval >= XSTRING (array)->size)
args_out_of_range (array, idx);
- XSETFASTINT (val, (unsigned char) XSTRING (array)->data[idxval]);
- return val;
+ if (! STRING_MULTIBYTE (array))
+ return make_number ((unsigned char) XSTRING (array)->data[idxval]);
+ idxval_byte = string_char_to_byte (array, idxval);
+
+ c = STRING_CHAR (&XSTRING (array)->data[idxval_byte],
+ XSTRING (array)->size_byte - idxval_byte);
+ return make_number (c);
}
else if (BOOL_VECTOR_P (array))
{
args_out_of_range (array, idx);
if (idxval < CHAR_TABLE_ORDINARY_SLOTS)
{
- /* The element is stored in the top table. We may return a
- deeper char-table. */
+ /* 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;
}
else
{
- int idx[3]; /* For charset, code1, and code2. */
- int i, len;
- Lisp_Object sub_array;
-
- /* There's no reason to treat a composite character
- specially here. */
-#if 0
- if (COMPOSITE_CHAR_P (idxval))
- /* For a composite characters, we use the first element as
- the index. */
- idxval = cmpchar_component (idxval, 0);
-#endif
- SPLIT_NON_ASCII_CHAR (idxval, idx[0], idx[1], idx[2]);
- len = (COMPOSITE_CHAR_P (idxval) || idx[2]) ? 3 : (idx[1] ? 2 : 1);
+ int code[4], i;
+ Lisp_Object sub_table;
+
+ 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:
- sub_array = array;
- for (i = 0; i < len; i++)
+ sub_table = array;
+ for (i = 0; code[i] >= 0; i++)
{
- val = XCHAR_TABLE (sub_array)->contents[idx[i]];
- if (NILP (val))
- val = XCHAR_TABLE (sub_array)->defalt;
- if (NILP (val))
+ val = XCHAR_TABLE (sub_table)->contents[code[i]];
+ if (SUB_CHAR_TABLE_P (val))
+ sub_table = val;
+ else
{
- array = XCHAR_TABLE (array)->parent;
- if (NILP (array))
- return Qnil;
- goto try_parent_char_table;
+ 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 (!CHAR_TABLE_P (val))
- return val;
- sub_array = val;
}
- /* We come here because ARRAY is deeper than the specified
- indices. We return a default value stored at the deepest
- level specified. */
- val = XCHAR_TABLE (sub_array)->defalt;
+ /* 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;
- if (NILP (array))
- return Qnil;
- goto try_parent_char_table;
+ if (!NILP (array))
+ goto try_parent_char_table;
}
return val;
}
DEFUN ("aset", Faset, Saset, 3, 3, 0,
"Store into the element of ARRAY at index IDX the value NEWELT.\n\
-ARRAY may be a vector or a string. IDX starts at 0.")
+ARRAY may be a vector, a string, a char-table or a bool-vector.\n\
+IDX starts at 0.")
(array, idx, newelt)
register Lisp_Object array;
Lisp_Object idx, newelt;
XCHAR_TABLE (array)->contents[idxval] = newelt;
else
{
- int idx[3]; /* For charset, code1, and code2. */
- int i, len;
+ int code[4], i;
Lisp_Object val;
- SPLIT_NON_ASCII_CHAR (idxval, idx[0], idx[1], idx[2]);
- len = (COMPOSITE_CHAR_P (idxval) || idx[2]) ? 2 : (idx[1] ? 1 : 0);
-
- for (i = 0; i < len; i++)
+ SPLIT_NON_ASCII_CHAR (idxval, code[0], code[1], code[2]);
+ if (code[0] != CHARSET_COMPOSITION)
{
- val = XCHAR_TABLE (array)->contents[idx[i]];
- if (CHAR_TABLE_P (val))
- /* Look into this deeper array. */
+ 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 the leaf. Create a deeper array with the
- default value VAL, set it in the slot of VAL, and
- look into it. */
- array = XCHAR_TABLE (array)->contents[idx[i]]
- = Fmake_char_table (Qnil, Qnil);
- XCHAR_TABLE (array)->defalt = val;
+ Lisp_Object temp;
+
+ /* VAL is a leaf. Create a sub char table with the
+ default value VAL or XCHAR_TABLE (array)->defalt
+ and look into it. */
+
+ temp = make_sub_char_table (NILP (val)
+ ? XCHAR_TABLE (array)->defalt
+ : val);
+ XCHAR_TABLE (array)->contents[code[i]] = temp;
+ array = temp;
}
}
- return XCHAR_TABLE (array)->contents[idx[i]] = newelt;
+ XCHAR_TABLE (array)->contents[code[i]] = newelt;
}
}
+ else if (STRING_MULTIBYTE (array))
+ {
+ Lisp_Object new_len;
+ int c, idxval_byte, actual_len;
+ unsigned char *p, *str;
+
+ if (idxval < 0 || idxval >= XSTRING (array)->size)
+ args_out_of_range (array, idx);
+
+ idxval_byte = string_char_to_byte (array, idxval);
+ p = &XSTRING (array)->data[idxval_byte];
+
+ actual_len
+ = MULTIBYTE_FORM_LENGTH (p, XSTRING (array)->size_byte - idxval_byte);
+ new_len = Fchar_bytes (newelt);
+ if (actual_len != XINT (new_len))
+ error ("Attempt to change byte length of a string");
+
+ CHAR_STRING (XINT (newelt), p, str);
+ if (p != str)
+ bcopy (str, p, actual_len);
+ }
else
{
if (idxval < 0 || idxval >= XSTRING (array)->size)
}
DEFUN ("=", Feqlsign, Seqlsign, 2, 2, 0,
- "T if two args, both numbers or markers, are equal.")
+ "Return t if two args, both numbers or markers, are equal.")
(num1, num2)
register Lisp_Object num1, num2;
{
}
DEFUN ("<", Flss, Slss, 2, 2, 0,
- "T if first arg is less than second arg. Both must be numbers or markers.")
+ "Return t if first arg is less than second arg. Both must be numbers or markers.")
(num1, num2)
register Lisp_Object num1, num2;
{
}
DEFUN (">", Fgtr, Sgtr, 2, 2, 0,
- "T if first arg is greater than second arg. Both must be numbers or markers.")
+ "Return t if first arg is greater than second arg. Both must be numbers or markers.")
(num1, num2)
register Lisp_Object num1, num2;
{
}
DEFUN ("<=", Fleq, Sleq, 2, 2, 0,
- "T if first arg is less than or equal to second arg.\n\
+ "Return t if first arg is less than or equal to second arg.\n\
Both must be numbers or markers.")
(num1, num2)
register Lisp_Object num1, num2;
}
DEFUN (">=", Fgeq, Sgeq, 2, 2, 0,
- "T if first arg is greater than or equal to second arg.\n\
+ "Return t if first arg is greater than or equal to second arg.\n\
Both must be numbers or markers.")
(num1, num2)
register Lisp_Object num1, num2;
}
DEFUN ("/=", Fneq, Sneq, 2, 2, 0,
- "T if first arg is not equal to second arg. Both must be numbers or markers.")
+ "Return t if first arg is not equal to second arg. Both must be numbers or markers.")
(num1, num2)
register Lisp_Object num1, num2;
{
return arithcompare (num1, num2, notequal);
}
-DEFUN ("zerop", Fzerop, Szerop, 1, 1, 0, "T if NUMBER is zero.")
+DEFUN ("zerop", Fzerop, Szerop, 1, 1, 0, "Return t if NUMBER is zero.")
(number)
register Lisp_Object number;
{
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));
+ return make_float (negative * 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 };
defsubr (&Snatnump);
defsubr (&Ssymbolp);
defsubr (&Sstringp);
+ defsubr (&Smultibyte_string_p);
defsubr (&Svectorp);
defsubr (&Schar_table_p);
defsubr (&Svector_or_char_table_p);
HCoop / bpt / emacs.git / blobdiff