/* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
- Copyright (C) 1985,86,88,93,94,95,97,98, 1999 Free Software Foundation, Inc.
+ Copyright (C) 1985,86,88,93,94,95,97,98,99,2000 Free Software Foundation, Inc.
This file is part of GNU Emacs.
extern double atof ();
#endif /* !atof */
-/* Nonzero means it is an error to set a symbol whose name starts with
- colon. */
-int keyword_symbols_constant_flag;
-
Lisp_Object Qnil, Qt, Qquote, Qlambda, Qsubr, Qunbound;
Lisp_Object Qerror_conditions, Qerror_message, Qtop_level;
Lisp_Object Qerror, Qquit, Qwrong_type_argument, Qargs_out_of_range;
Lisp_Object Qprocess;
static Lisp_Object Qcompiled_function, Qbuffer, Qframe, Qvector;
static Lisp_Object Qchar_table, Qbool_vector, Qhash_table;
+static Lisp_Object Qsubrp, Qmany, Qunevalled;
static Lisp_Object swap_in_symval_forwarding ();
CHECK_SYMBOL (symbol, 0);
if (NILP (symbol) || EQ (symbol, Qt)
|| (XSYMBOL (symbol)->name->data[0] == ':'
- && EQ (XSYMBOL (symbol)->obarray, initial_obarray)
- && keyword_symbols_constant_flag))
+ && EQ (XSYMBOL (symbol)->obarray, initial_obarray)))
return Fsignal (Qsetting_constant, Fcons (symbol, Qnil));
Fset (symbol, Qunbound);
return symbol;
return newplist;
}
+DEFUN ("subr-arity", Fsubr_arity, Ssubr_arity, 1, 1, 0,
+ "Return minimum and maximum number of args allowed for SUBR.\n\
+SUBR must be a built-in function.\n\
+The returned value is a pair (MIN . MAX). MIN is the minimum number\n\
+of args. MAX is the maximum number or the symbol `many', for a\n\
+function with `&rest' args, or `unevalled' for a special form.")
+ (subr)
+ Lisp_Object subr;
+{
+ short minargs, maxargs;
+ if (!SUBRP (subr))
+ wrong_type_argument (Qsubrp, subr);
+ minargs = XSUBR (subr)->min_args;
+ maxargs = XSUBR (subr)->max_args;
+ if (maxargs == MANY)
+ return Fcons (make_number (minargs), Qmany);
+ else if (maxargs == UNEVALLED)
+ return Fcons (make_number (minargs), Qunevalled);
+ else
+ return Fcons (make_number (minargs), make_number (maxargs));
+}
+
\f
/* Getting and setting values of symbols */
case Lisp_Misc_Buffer_Objfwd:
offset = XBUFFER_OBJFWD (valcontents)->offset;
- return *(Lisp_Object *)(offset + (char *)current_buffer);
+ return PER_BUFFER_VALUE (current_buffer, offset);
case Lisp_Misc_Kboard_Objfwd:
offset = XKBOARD_OBJFWD (valcontents)->offset;
int offset = XBUFFER_OBJFWD (valcontents)->offset;
Lisp_Object type;
- type = *(Lisp_Object *)(offset + (char *)&buffer_local_types);
+ type = PER_BUFFER_TYPE (offset);
if (XINT (type) == -1)
error ("Variable %s is read-only", XSYMBOL (symbol)->name->data);
&& XTYPE (newval) != XINT (type))
buffer_slot_type_mismatch (offset);
- *(Lisp_Object *)(offset + (char *)current_buffer) = newval;
+ PER_BUFFER_VALUE (current_buffer, offset) = newval;
}
break;
}
}
+/* Set up SYMBOL to refer to its global binding.
+ This makes it safe to alter the status of other bindings. */
+
+void
+swap_in_global_binding (symbol)
+ Lisp_Object symbol;
+{
+ Lisp_Object valcontents, cdr;
+
+ valcontents = XSYMBOL (symbol)->value;
+ if (!BUFFER_LOCAL_VALUEP (valcontents)
+ && !SOME_BUFFER_LOCAL_VALUEP (valcontents))
+ abort ();
+ cdr = XBUFFER_LOCAL_VALUE (valcontents)->cdr;
+
+ /* Unload the previously loaded binding. */
+ Fsetcdr (XCAR (cdr),
+ do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents)->realvalue));
+
+ /* Select the global binding in the symbol. */
+ XCAR (cdr) = cdr;
+ store_symval_forwarding (symbol, valcontents, XCDR (cdr));
+
+ /* Indicate that the global binding is set up now. */
+ XBUFFER_LOCAL_VALUE (valcontents)->frame = Qnil;
+ XBUFFER_LOCAL_VALUE (valcontents)->buffer = Qnil;
+ XBUFFER_LOCAL_VALUE (valcontents)->found_for_frame = 0;
+ XBUFFER_LOCAL_VALUE (valcontents)->found_for_buffer = 0;
+}
+
/* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
VALCONTENTS is the contents of its value cell,
which points to a struct Lisp_Buffer_Local_Value.
return *XOBJFWD (valcontents)->objvar;
case Lisp_Misc_Buffer_Objfwd:
- return *(Lisp_Object *)(XBUFFER_OBJFWD (valcontents)->offset
- + (char *)current_buffer);
+ return PER_BUFFER_VALUE (current_buffer,
+ XBUFFER_OBJFWD (valcontents)->offset);
case Lisp_Misc_Kboard_Objfwd:
return *(Lisp_Object *)(XKBOARD_OBJFWD (valcontents)->offset
{
int voide = EQ (newval, Qunbound);
- register Lisp_Object valcontents, tem1, current_alist_element;
+ register Lisp_Object valcontents, innercontents, tem1, current_alist_element;
if (buf == 0)
buf = current_buffer;
if (NILP (symbol) || EQ (symbol, Qt)
|| (XSYMBOL (symbol)->name->data[0] == ':'
&& EQ (XSYMBOL (symbol)->obarray, initial_obarray)
- && keyword_symbols_constant_flag && ! EQ (newval, symbol)))
+ && !EQ (newval, symbol)))
return Fsignal (Qsetting_constant, Fcons (symbol, Qnil));
- valcontents = XSYMBOL (symbol)->value;
+
+ innercontents = valcontents = XSYMBOL (symbol)->value;
if (BUFFER_OBJFWDP (valcontents))
{
- register int idx = XBUFFER_OBJFWD (valcontents)->offset;
- register int mask = XINT (*((Lisp_Object *)
- (idx + (char *)&buffer_local_flags)));
- if (mask > 0 && ! bindflag
- && ! let_shadows_buffer_binding_p (symbol))
- buf->local_var_flags |= mask;
+ int offset = XBUFFER_OBJFWD (valcontents)->offset;
+ int idx = PER_BUFFER_IDX (offset);
+ if (idx > 0
+ && !bindflag
+ && !let_shadows_buffer_binding_p (symbol))
+ SET_PER_BUFFER_VALUE_P (buf, idx, 1);
}
else if (BUFFER_LOCAL_VALUEP (valcontents)
isn't the right one, or if it's a Lisp_Buffer_Local_Value and
the default binding is loaded, the loaded binding may be the
wrong one. */
- if (buf != XBUFFER (XBUFFER_LOCAL_VALUE (valcontents)->buffer)
+ if (!BUFFERP (XBUFFER_LOCAL_VALUE (valcontents)->buffer)
+ || buf != XBUFFER (XBUFFER_LOCAL_VALUE (valcontents)->buffer)
|| (XBUFFER_LOCAL_VALUE (valcontents)->check_frame
&& !EQ (selected_frame, XBUFFER_LOCAL_VALUE (valcontents)->frame))
|| (BUFFER_LOCAL_VALUEP (valcontents)
XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents)->buffer, buf);
XBUFFER_LOCAL_VALUE (valcontents)->frame = selected_frame;
}
- valcontents = XBUFFER_LOCAL_VALUE (valcontents)->realvalue;
+ innercontents = XBUFFER_LOCAL_VALUE (valcontents)->realvalue;
}
/* If storing void (making the symbol void), forward only through
if (voide)
store_symval_forwarding (symbol, Qnil, newval);
else
- store_symval_forwarding (symbol, valcontents, newval);
+ store_symval_forwarding (symbol, innercontents, newval);
+
+ /* If we just set a variable whose current binding is frame-local,
+ store the new value in the frame parameter too. */
+
+ if (BUFFER_LOCAL_VALUEP (valcontents)
+ || SOME_BUFFER_LOCAL_VALUEP (valcontents))
+ {
+ /* What binding is loaded right now? */
+ current_alist_element
+ = XCAR (XBUFFER_LOCAL_VALUE (valcontents)->cdr);
+
+ /* If the current buffer is not the buffer whose binding is
+ loaded, or if there may be frame-local bindings and the frame
+ isn't the right one, or if it's a Lisp_Buffer_Local_Value and
+ the default binding is loaded, the loaded binding may be the
+ wrong one. */
+ if (XBUFFER_LOCAL_VALUE (valcontents)->found_for_frame)
+ XCDR (current_alist_element) = newval;
+ }
return newval;
}
rather than letting do_symval_forwarding get the current value. */
if (BUFFER_OBJFWDP (valcontents))
{
- register int idx = XBUFFER_OBJFWD (valcontents)->offset;
-
- if (XINT (*(Lisp_Object *) (idx + (char *) &buffer_local_flags)) != 0)
- return *(Lisp_Object *)(idx + (char *) &buffer_defaults);
+ int offset = XBUFFER_OBJFWD (valcontents)->offset;
+ if (PER_BUFFER_IDX (offset) != 0)
+ return PER_BUFFER_DEFAULT (offset);
}
/* Handle user-created local variables. */
variables. */
if (BUFFER_OBJFWDP (valcontents))
{
- register int idx = XBUFFER_OBJFWD (valcontents)->offset;
- register struct buffer *b;
- register int mask = XINT (*((Lisp_Object *)
- (idx + (char *)&buffer_local_flags)));
+ int offset = XBUFFER_OBJFWD (valcontents)->offset;
+ int idx = PER_BUFFER_IDX (offset);
- *(Lisp_Object *)(idx + (char *) &buffer_defaults) = value;
+ PER_BUFFER_DEFAULT (offset) = value;
/* If this variable is not always local in all buffers,
set it in the buffers that don't nominally have a local value. */
- if (mask > 0)
+ if (idx > 0)
{
+ struct buffer *b;
+
for (b = all_buffers; b; b = b->next)
- if (!(b->local_var_flags & mask))
- *(Lisp_Object *)(idx + (char *) b) = value;
+ if (!PER_BUFFER_VALUE_P (b, idx))
+ PER_BUFFER_VALUE (b, offset) = value;
}
return value;
}
if (BUFFER_OBJFWDP (valcontents))
{
- register int idx = XBUFFER_OBJFWD (valcontents)->offset;
- register int mask = XINT (*((Lisp_Object*)
- (idx + (char *)&buffer_local_flags)));
+ int offset = XBUFFER_OBJFWD (valcontents)->offset;
+ int idx = PER_BUFFER_IDX (offset);
- if (mask > 0)
+ if (idx > 0)
{
- *(Lisp_Object *)(idx + (char *) current_buffer)
- = *(Lisp_Object *)(idx + (char *) &buffer_defaults);
- current_buffer->local_var_flags &= ~mask;
+ SET_PER_BUFFER_VALUE_P (current_buffer, idx, 0);
+ PER_BUFFER_VALUE (current_buffer, offset)
+ = PER_BUFFER_DEFAULT (offset);
}
return variable;
}
if (BUFFER_OBJFWDP (valcontents))
{
int offset = XBUFFER_OBJFWD (valcontents)->offset;
- int mask = XINT (*(Lisp_Object *)(offset + (char *)&buffer_local_flags));
- if (mask == -1 || (buf->local_var_flags & mask))
+ int idx = PER_BUFFER_IDX (offset);
+ if (idx == -1 || PER_BUFFER_VALUE_P (buf, idx))
return Qt;
}
return Qnil;
{
Lisp_Object val;
+ val = Qnil;
+
if (idxval < 0)
args_out_of_range (array, idx);
if (idxval < CHAR_TABLE_ORDINARY_SLOTS)
int code[4], i;
Lisp_Object sub_table;
- SPLIT_NON_ASCII_CHAR (idxval, code[0], code[1], code[2]);
+ SPLIT_CHAR (idxval, code[0], code[1], code[2]);
if (code[1] < 32) code[1] = -1;
else if (code[2] < 32) code[2] = -1;
}
else
{
- int size;
+ int size = 0;
if (VECTORP (array))
size = XVECTOR (array)->size;
else if (COMPILEDP (array))
}
}
+/* Don't use alloca for relocating string data larger than this, lest
+ we overflow their stack. The value is the same as what used in
+ fns.c for base64 handling. */
+#define MAX_ALLOCA 16*1024
+
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, a string, a char-table or a bool-vector.\n\
int code[4], i;
Lisp_Object val;
- SPLIT_NON_ASCII_CHAR (idxval, code[0], code[1], code[2]);
+ SPLIT_CHAR (idxval, code[0], code[1], code[2]);
if (code[1] < 32) code[1] = -1;
else if (code[2] < 32) code[2] = -1;
}
else if (STRING_MULTIBYTE (array))
{
- int idxval_byte, new_len, actual_len;
- int prev_byte;
- unsigned char *p, workbuf[MAX_MULTIBYTE_LENGTH], *str = workbuf;
+ int idxval_byte, prev_bytes, new_bytes;
+ unsigned char workbuf[MAX_MULTIBYTE_LENGTH], *p0 = workbuf, *p1;
if (idxval < 0 || idxval >= XSTRING (array)->size)
args_out_of_range (array, idx);
+ CHECK_NUMBER (newelt, 2);
idxval_byte = string_char_to_byte (array, idxval);
- p = &XSTRING (array)->data[idxval_byte];
-
- actual_len = MULTIBYTE_FORM_LENGTH (p, STRING_BYTES (XSTRING (array)));
- CHECK_NUMBER (newelt, 2);
- new_len = CHAR_STRING (XINT (newelt), str);
- if (actual_len != new_len)
- error ("Attempt to change byte length of a string");
-
- /* We can't accept a change causing byte combining. */
- if (!ASCII_BYTE_P (*str)
- && ((idxval > 0 && !CHAR_HEAD_P (*str)
- && (prev_byte = string_char_to_byte (array, idxval - 1),
- BYTES_BY_CHAR_HEAD (XSTRING (array)->data[prev_byte])
- > idxval_byte - prev_byte))
- || (idxval < XSTRING (array)->size - 1
- && !CHAR_HEAD_P (p[actual_len])
- && new_len < BYTES_BY_CHAR_HEAD (*str))))
- error ("Attempt to change char length of a string");
- while (new_len--)
- *p++ = *str++;
+ p1 = &XSTRING (array)->data[idxval_byte];
+ PARSE_MULTIBYTE_SEQ (p1, nbytes - idxval_byte, prev_bytes);
+ new_bytes = CHAR_STRING (XINT (newelt), p0);
+ if (prev_bytes != new_bytes)
+ {
+ /* We must relocate the string data. */
+ int nchars = XSTRING (array)->size;
+ int nbytes = STRING_BYTES (XSTRING (array));
+ unsigned char *str;
+
+ str = (nbytes <= MAX_ALLOCA
+ ? (unsigned char *) alloca (nbytes)
+ : (unsigned char *) xmalloc (nbytes));
+ bcopy (XSTRING (array)->data, str, nbytes);
+ allocate_string_data (XSTRING (array), nchars,
+ nbytes + new_bytes - prev_bytes);
+ bcopy (str, XSTRING (array)->data, idxval_byte);
+ p1 = XSTRING (array)->data + idxval_byte;
+ bcopy (str + idxval_byte + prev_bytes, p1 + new_bytes,
+ nbytes - (idxval_byte + prev_bytes));
+ if (nbytes > MAX_ALLOCA)
+ xfree (str);
+ clear_string_char_byte_cache ();
+ }
+ while (new_bytes--)
+ *p1++ = *p0++;
}
else
{
if (idxval < 0 || idxval >= XSTRING (array)->size)
args_out_of_range (array, idx);
CHECK_NUMBER (newelt, 2);
- XSTRING (array)->data[idxval] = XINT (newelt);
+
+ if (XINT (newelt) < 0 || SINGLE_BYTE_CHAR_P (XINT (newelt)))
+ XSTRING (array)->data[idxval] = XINT (newelt);
+ else
+ {
+ /* We must relocate the string data while converting it to
+ multibyte. */
+ int idxval_byte, prev_bytes, new_bytes;
+ unsigned char workbuf[MAX_MULTIBYTE_LENGTH], *p0 = workbuf, *p1;
+ unsigned char *origstr = XSTRING (array)->data, *str;
+ int nchars, nbytes;
+
+ nchars = XSTRING (array)->size;
+ nbytes = idxval_byte = count_size_as_multibyte (origstr, idxval);
+ nbytes += count_size_as_multibyte (origstr + idxval,
+ nchars - idxval);
+ str = (nbytes <= MAX_ALLOCA
+ ? (unsigned char *) alloca (nbytes)
+ : (unsigned char *) xmalloc (nbytes));
+ copy_text (XSTRING (array)->data, str, nchars, 0, 1);
+ PARSE_MULTIBYTE_SEQ (str + idxval_byte, nbytes - idxval_byte,
+ prev_bytes);
+ new_bytes = CHAR_STRING (XINT (newelt), p0);
+ allocate_string_data (XSTRING (array), nchars,
+ nbytes + new_bytes - prev_bytes);
+ bcopy (str, XSTRING (array)->data, idxval_byte);
+ p1 = XSTRING (array)->data + idxval_byte;
+ while (new_bytes--)
+ *p1++ = *p0++;
+ bcopy (str + idxval_byte + prev_bytes, p1,
+ nbytes - (idxval_byte + prev_bytes));
+ if (nbytes > MAX_ALLOCA)
+ xfree (str);
+ clear_string_char_byte_cache ();
+ }
}
return newelt;
Lisp_Object num1, num2;
enum comparison comparison;
{
- double f1, f2;
+ double f1 = 0, f2 = 0;
int floatp = 0;
CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1, 0);
register Lisp_Object string, base;
{
register unsigned char *p;
- register int b, v = 0;
- int negative = 1;
+ register int b;
+ int sign = 1;
+ Lisp_Object val;
CHECK_STRING (string, 0);
Fsignal (Qargs_out_of_range, Fcons (base, Qnil));
}
- p = XSTRING (string)->data;
-
/* Skip any whitespace at the front of the number. Some versions of
atoi do this anyway, so we might as well make Emacs lisp consistent. */
+ p = XSTRING (string)->data;
while (*p == ' ' || *p == '\t')
p++;
if (*p == '-')
{
- negative = -1;
+ sign = -1;
p++;
}
else if (*p == '+')
p++;
if (isfloat_string (p) && b == 10)
- return make_float (negative * atof (p));
-
- while (1)
+ val = make_float (sign * atof (p));
+ else
{
- int digit = digit_to_number (*p++, b);
- if (digit < 0)
- break;
- v = v * b + digit;
+ double v = 0;
+
+ while (1)
+ {
+ int digit = digit_to_number (*p++, b);
+ if (digit < 0)
+ break;
+ v = v * b + digit;
+ }
+
+ if (v > (EMACS_UINT) (VALMASK >> 1))
+ val = make_float (sign * v);
+ else
+ val = make_number (sign * (int) v);
}
-
- return make_number (negative * v);
+
+ return val;
}
\f
Qchar_table_p = intern ("char-table-p");
Qvector_or_char_table_p = intern ("vector-or-char-table-p");
+ Qsubrp = intern ("subrp");
+ Qunevalled = intern ("unevalled");
+ Qmany = intern ("many");
+
Qcdr = intern ("cdr");
/* Handle automatic advice activation */
staticpro (&Qnumber_or_marker_p);
staticpro (&Qchar_table_p);
staticpro (&Qvector_or_char_table_p);
+ staticpro (&Qsubrp);
+ staticpro (&Qmany);
+ staticpro (&Qunevalled);
staticpro (&Qboundp);
staticpro (&Qfboundp);
staticpro (&Qbool_vector);
staticpro (&Qhash_table);
- DEFVAR_BOOL ("keyword-symbols-constant-flag", &keyword_symbols_constant_flag,
- "Non-nil means it is an error to set a keyword symbol.\n\
-A keyword symbol is a symbol whose name starts with a colon (`:').");
- keyword_symbols_constant_flag = 1;
-
defsubr (&Seq);
defsubr (&Snull);
defsubr (&Stype_of);
defsubr (&Sadd1);
defsubr (&Ssub1);
defsubr (&Slognot);
+ defsubr (&Ssubr_arity);
XSYMBOL (Qwholenump)->function = XSYMBOL (Qnatnump)->function;
}