/* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
- Copyright (C) 1985,86,88,93,94,95,97,98,99, 2000, 2001, 03, 2004
- Free Software Foundation, Inc.
+ Copyright (C) 1985, 1986, 1988, 1993, 1994, 1995, 1997, 1998, 1999, 2000,
+ 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
This file is part of GNU Emacs.
You should have received a copy of the GNU General Public License
along with GNU Emacs; see the file COPYING. If not, write to
-the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-Boston, MA 02111-1307, USA. */
+the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+Boston, MA 02110-1301, USA. */
#include <config.h>
circular_list_error (list)
Lisp_Object list;
{
- Fsignal (Qcircular_list, list);
+ xsignal (Qcircular_list, list);
}
wrong_type_argument (predicate, value)
register Lisp_Object predicate, value;
{
- register Lisp_Object tem;
- do
- {
- /* If VALUE is not even a valid Lisp object, abort here
- where we can get a backtrace showing where it came from. */
- if ((unsigned int) XGCTYPE (value) >= Lisp_Type_Limit)
- abort ();
+ /* If VALUE is not even a valid Lisp object, abort here
+ where we can get a backtrace showing where it came from. */
+ if ((unsigned int) XGCTYPE (value) >= Lisp_Type_Limit)
+ abort ();
- value = Fsignal (Qwrong_type_argument, Fcons (predicate, Fcons (value, Qnil)));
- tem = call1 (predicate, value);
- }
- while (NILP (tem));
- return value;
+ xsignal2 (Qwrong_type_argument, predicate, value);
}
void
args_out_of_range (a1, a2)
Lisp_Object a1, a2;
{
- while (1)
- Fsignal (Qargs_out_of_range, Fcons (a1, Fcons (a2, Qnil)));
+ xsignal2 (Qargs_out_of_range, a1, a2);
}
void
args_out_of_range_3 (a1, a2, a3)
Lisp_Object a1, a2, a3;
{
- while (1)
- Fsignal (Qargs_out_of_range, Fcons (a1, Fcons (a2, Fcons (a3, Qnil))));
+ xsignal3 (Qargs_out_of_range, a1, a2, a3);
}
/* On some machines, XINT needs a temporary location.
}
DEFUN ("listp", Flistp, Slistp, 1, 1, 0,
- doc: /* Return t if OBJECT is a list. This includes nil. */)
+ doc: /* Return t if OBJECT is a list, that is, a cons cell or nil.
+Otherwise, return nil. */)
(object)
Lisp_Object object;
{
(object)
Lisp_Object object;
{
- if (VECTORP (object) || STRINGP (object)
- || CHAR_TABLE_P (object) || BOOL_VECTOR_P (object))
+ if (ARRAYP (object))
return Qt;
return Qnil;
}
(object)
register Lisp_Object object;
{
- if (CONSP (object) || NILP (object) || VECTORP (object) || STRINGP (object)
- || CHAR_TABLE_P (object) || BOOL_VECTOR_P (object))
+ if (CONSP (object) || NILP (object) || ARRAYP (object))
return Qt;
return Qnil;
}
DEFUN ("car", Fcar, Scar, 1, 1, 0,
doc: /* Return the car of LIST. If arg is nil, return nil.
-Error if arg is not nil and not a cons cell. See also `car-safe'. */)
+Error if arg is not nil and not a cons cell. See also `car-safe'.
+
+See Info node `(elisp)Cons Cells' for a discussion of related basic
+Lisp concepts such as car, cdr, cons cell and list. */)
(list)
register Lisp_Object list;
{
- while (1)
- {
- if (CONSP (list))
- return XCAR (list);
- else if (EQ (list, Qnil))
- return Qnil;
- else
- list = wrong_type_argument (Qlistp, list);
- }
+ return CAR (list);
}
DEFUN ("car-safe", Fcar_safe, Scar_safe, 1, 1, 0,
(object)
Lisp_Object object;
{
- if (CONSP (object))
- return XCAR (object);
- else
- return Qnil;
+ return CAR_SAFE (object);
}
DEFUN ("cdr", Fcdr, Scdr, 1, 1, 0,
doc: /* Return the cdr of LIST. If arg is nil, return nil.
-Error if arg is not nil and not a cons cell. See also `cdr-safe'. */)
+Error if arg is not nil and not a cons cell. See also `cdr-safe'.
+
+See Info node `(elisp)Cons Cells' for a discussion of related basic
+Lisp concepts such as cdr, car, cons cell and list. */)
(list)
register Lisp_Object list;
{
- while (1)
- {
- if (CONSP (list))
- return XCDR (list);
- else if (EQ (list, Qnil))
- return Qnil;
- else
- list = wrong_type_argument (Qlistp, list);
- }
+ return CDR (list);
}
DEFUN ("cdr-safe", Fcdr_safe, Scdr_safe, 1, 1, 0,
(object)
Lisp_Object object;
{
- if (CONSP (object))
- return XCDR (object);
- else
- return Qnil;
+ return CDR_SAFE (object);
}
DEFUN ("setcar", Fsetcar, Ssetcar, 2, 2, 0,
(cell, newcar)
register Lisp_Object cell, newcar;
{
- if (!CONSP (cell))
- cell = wrong_type_argument (Qconsp, cell);
-
+ CHECK_CONS (cell);
CHECK_IMPURE (cell);
XSETCAR (cell, newcar);
return newcar;
(cell, newcdr)
register Lisp_Object cell, newcdr;
{
- if (!CONSP (cell))
- cell = wrong_type_argument (Qconsp, cell);
-
+ CHECK_CONS (cell);
CHECK_IMPURE (cell);
XSETCDR (cell, newcdr);
return newcdr;
register Lisp_Object symbol;
{
CHECK_SYMBOL (symbol);
- if (XSYMBOL (symbol)->constant)
- return Fsignal (Qsetting_constant, Fcons (symbol, Qnil));
+ if (SYMBOL_CONSTANT_P (symbol))
+ xsignal1 (Qsetting_constant, symbol);
Fset (symbol, Qunbound);
return symbol;
}
{
CHECK_SYMBOL (symbol);
if (NILP (symbol) || EQ (symbol, Qt))
- return Fsignal (Qsetting_constant, Fcons (symbol, Qnil));
+ xsignal1 (Qsetting_constant, symbol);
XSYMBOL (symbol)->function = Qunbound;
return symbol;
}
register Lisp_Object symbol;
{
CHECK_SYMBOL (symbol);
- if (EQ (XSYMBOL (symbol)->function, Qunbound))
- return Fsignal (Qvoid_function, Fcons (symbol, Qnil));
- return XSYMBOL (symbol)->function;
+ if (!EQ (XSYMBOL (symbol)->function, Qunbound))
+ return XSYMBOL (symbol)->function;
+ xsignal1 (Qvoid_function, symbol);
}
DEFUN ("symbol-plist", Fsymbol_plist, Ssymbol_plist, 1, 1, 0,
{
CHECK_SYMBOL (symbol);
if (NILP (symbol) || EQ (symbol, Qt))
- return Fsignal (Qsetting_constant, Fcons (symbol, Qnil));
+ xsignal1 (Qsetting_constant, symbol);
if (!NILP (Vautoload_queue) && !EQ (XSYMBOL (symbol)->function, Qunbound))
Vautoload_queue = Fcons (Fcons (symbol, XSYMBOL (symbol)->function),
Vautoload_queue);
(symbol, definition, docstring)
register Lisp_Object symbol, definition, docstring;
{
+ CHECK_SYMBOL (symbol);
if (CONSP (XSYMBOL (symbol)->function)
&& EQ (XCAR (XSYMBOL (symbol)->function), Qautoload))
LOADHIST_ATTACH (Fcons (Qt, symbol));
definition = Ffset (symbol, definition);
- LOADHIST_ATTACH (symbol);
+ LOADHIST_ATTACH (Fcons (Qdefun, symbol));
if (!NILP (docstring))
Fput (symbol, Qfunction_documentation, docstring);
return definition;
Lisp_Object subr;
{
short minargs, maxargs;
- if (!SUBRP (subr))
- wrong_type_argument (Qsubrp, subr);
+ CHECK_SUBR (subr);
minargs = XSUBR (subr)->min_args;
maxargs = XSUBR (subr)->max_args;
if (maxargs == MANY)
Lisp_Object subr;
{
const char *name;
- if (!SUBRP (subr))
- wrong_type_argument (Qsubrp, subr);
+ CHECK_SUBR (subr);
name = XSUBR (subr)->symbol_name;
return make_string (name, strlen (name));
}
DEFUN ("interactive-form", Finteractive_form, Sinteractive_form, 1, 1, 0,
doc: /* Return the interactive form of CMD or nil if none.
-CMD must be a command. Value, if non-nil, is a list
-\(interactive SPEC). */)
+If CMD is not a command, the return value is nil.
+Value, if non-nil, is a list \(interactive SPEC). */)
(cmd)
Lisp_Object cmd;
{
tortoise = XSYMBOL (tortoise)->value;
if (EQ (hare, tortoise))
- Fsignal (Qcyclic_variable_indirection, Fcons (symbol, Qnil));
+ xsignal1 (Qcyclic_variable_indirection, symbol);
}
return hare;
register Lisp_Object valcontents, newval;
struct buffer *buf;
{
- int offset;
-
switch (SWITCH_ENUM_CAST (XTYPE (valcontents)))
{
case Lisp_Misc:
- (char *) &buffer_defaults);
int idx = PER_BUFFER_IDX (offset);
- Lisp_Object tail, buf;
+ Lisp_Object tail;
if (idx <= 0)
break;
Lisp_Object val;
val = find_symbol_value (symbol);
- if (EQ (val, Qunbound))
- return Fsignal (Qvoid_variable, Fcons (symbol, Qnil));
- else
+ if (!EQ (val, Qunbound))
return val;
+
+ xsignal1 (Qvoid_variable, symbol);
}
DEFUN ("set", Fset, Sset, 2, 2, 0,
if (SYMBOL_CONSTANT_P (symbol)
&& (NILP (Fkeywordp (symbol))
|| !EQ (newval, SYMBOL_VALUE (symbol))))
- return Fsignal (Qsetting_constant, Fcons (symbol, Qnil));
+ xsignal1 (Qsetting_constant, symbol);
innercontents = valcontents = SYMBOL_VALUE (symbol);
register Lisp_Object value;
value = default_value (symbol);
- if (EQ (value, Qunbound))
- return Fsignal (Qvoid_variable, Fcons (symbol, Qnil));
- return value;
+ if (!EQ (value, Qunbound))
+ return value;
+
+ xsignal1 (Qvoid_variable, symbol);
}
DEFUN ("set-default", Fset_default, Sset_default, 2, 2, 0,
- doc: /* Set SYMBOL's default value to VAL. SYMBOL and VAL are evaluated.
+ doc: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
The default value is seen in buffers that do not have their own values
for this variable. */)
(symbol, value)
return value;
}
-DEFUN ("setq-default", Fsetq_default, Ssetq_default, 2, UNEVALLED, 0,
+DEFUN ("setq-default", Fsetq_default, Ssetq_default, 0, UNEVALLED, 0,
doc: /* Set the default value of variable VAR to VALUE.
VAR, the variable name, is literal (not evaluated);
VALUE is an expression: it is evaluated and its value returned.
This sets each VAR's default value to the corresponding VALUE.
The VALUE for the Nth VAR can refer to the new default values
of previous VARs.
-usage: (setq-default VAR VALUE [VAR VALUE...]) */)
+usage: (setq-default [VAR VALUE...]) */)
(args)
Lisp_Object args;
{
a `let'-style binding made in this buffer is in effect,
does not make the variable buffer-local. Return VARIABLE.
+In most cases it is better to use `make-local-variable',
+which makes a variable local in just one buffer.
+
The function `default-value' gets the default value and `set-default' sets it. */)
(variable)
register Lisp_Object variable;
Other buffers will continue to share a common default value.
\(The buffer-local value of VARIABLE starts out as the same value
VARIABLE previously had. If VARIABLE was void, it remains void.\)
-See also `make-variable-buffer-local'. Return VARIABLE.
+Return VARIABLE.
If the variable is already arranged to become local when set,
this function causes a local value to exist for this buffer,
(set (make-local-variable 'VARIABLE) VALUE-EXP)
works.
+See also `make-variable-buffer-local'.
+
Do not use `make-local-variable' to make a hook variable buffer-local.
Instead, use `add-hook' and specify t for the LOCAL argument. */)
(variable)
DEFUN ("make-variable-frame-local", Fmake_variable_frame_local, Smake_variable_frame_local,
1, 1, "vMake Variable Frame Local: ",
doc: /* Enable VARIABLE to have frame-local bindings.
-When a frame-local binding exists in the current frame,
-it is in effect whenever the current buffer has no buffer-local binding.
-A frame-local binding is actually a frame parameter value;
-thus, any given frame has a local binding for VARIABLE if it has
-a value for the frame parameter named VARIABLE. Return VARIABLE.
-See `modify-frame-parameters' for how to set frame parameters. */)
+This does not create any frame-local bindings for VARIABLE,
+it just makes them possible.
+
+A frame-local binding is actually a frame parameter value.
+If a frame F has a value for the frame parameter named VARIABLE,
+that also acts as a frame-local binding for VARIABLE in F--
+provided this function has been called to enable VARIABLE
+to have frame-local bindings at all.
+
+The only way to create a frame-local binding for VARIABLE in a frame
+is to set the VARIABLE frame parameter of that frame. See
+`modify-frame-parameters' for how to set frame parameters.
+
+Buffer-local bindings take precedence over frame-local bindings. */)
(variable)
register Lisp_Object variable;
{
DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p, Slocal_variable_if_set_p,
1, 2, 0,
- doc: /* Non-nil if VARIABLE will be local in buffer BUFFER if it is set there.
+ doc: /* Non-nil if VARIABLE will be local in buffer BUFFER when set there.
+More precisely, this means that setting the variable \(with `set' or`setq'),
+while it does not have a `let'-style binding that was made in BUFFER,
+will produce a buffer local binding. See Info node
+`(elisp)Creating Buffer-Local'.
BUFFER defaults to the current buffer. */)
(variable, buffer)
register Lisp_Object variable, buffer;
tortoise = XSYMBOL (tortoise)->function;
if (EQ (hare, tortoise))
- Fsignal (Qcyclic_function_indirection, Fcons (object, Qnil));
+ xsignal1 (Qcyclic_function_indirection, object);
}
return hare;
}
-DEFUN ("indirect-function", Findirect_function, Sindirect_function, 1, 1, 0,
+DEFUN ("indirect-function", Findirect_function, Sindirect_function, 1, 2, 0,
doc: /* Return the function at the end of OBJECT's function chain.
-If OBJECT is a symbol, follow all function indirections and return the final
-function binding.
-If OBJECT is not a symbol, just return it.
-Signal a void-function error if the final symbol is unbound.
+If OBJECT is not a symbol, just return it. Otherwise, follow all
+function indirections to find the final function binding and return it.
+If the final symbol in the chain is unbound, signal a void-function error.
+Optional arg NOERROR non-nil means to return nil instead of signalling.
Signal a cyclic-function-indirection error if there is a loop in the
function chain of symbols. */)
- (object)
+ (object, noerror)
register Lisp_Object object;
+ Lisp_Object noerror;
{
Lisp_Object result;
- result = indirect_function (object);
+ /* Optimize for no indirection. */
+ result = object;
+ if (SYMBOLP (result) && !EQ (result, Qunbound)
+ && (result = XSYMBOL (result)->function, SYMBOLP (result)))
+ result = indirect_function (result);
+ if (!EQ (result, Qunbound))
+ return result;
+
+ if (NILP (noerror))
+ xsignal1 (Qvoid_function, object);
- if (EQ (result, Qunbound))
- return Fsignal (Qvoid_function, Fcons (object, Qnil));
- return result;
+ return Qnil;
}
\f
/* Extract and set vector and string elements */
args_out_of_range (array, idx);
if (idxval < CHAR_TABLE_ORDINARY_SLOTS)
{
+ if (! SINGLE_BYTE_CHAR_P (idxval))
+ args_out_of_range (array, idx);
/* For ASCII and 8-bit European characters, the element is
stored in the top table. */
val = XCHAR_TABLE (array)->contents[idxval];
+ if (NILP (val))
+ {
+ int default_slot
+ = (idxval < 0x80 ? CHAR_TABLE_DEFAULT_SLOT_ASCII
+ : idxval < 0xA0 ? CHAR_TABLE_DEFAULT_SLOT_8_BIT_CONTROL
+ : CHAR_TABLE_DEFAULT_SLOT_8_BIT_GRAPHIC);
+ val = XCHAR_TABLE (array)->contents[default_slot];
+ }
if (NILP (val))
val = XCHAR_TABLE (array)->defalt;
while (NILP (val)) /* Follow parents until we find some value. */
{
int code[4], i;
Lisp_Object sub_table;
+ Lisp_Object current_default;
SPLIT_CHAR (idxval, code[0], code[1], code[2]);
if (code[1] < 32) code[1] = -1;
code[3] = -1; /* anchor */
try_parent_char_table:
+ current_default = XCHAR_TABLE (array)->defalt;
sub_table = array;
for (i = 0; code[i] >= 0; i++)
{
val = XCHAR_TABLE (sub_table)->contents[code[i]];
if (SUB_CHAR_TABLE_P (val))
- sub_table = val;
+ {
+ sub_table = val;
+ if (! NILP (XCHAR_TABLE (sub_table)->defalt))
+ current_default = XCHAR_TABLE (sub_table)->defalt;
+ }
else
{
if (NILP (val))
- val = XCHAR_TABLE (sub_table)->defalt;
+ val = current_default;
if (NILP (val))
{
array = XCHAR_TABLE (array)->parent;
return val;
}
}
- /* Here, VAL is a sub char table. We try the default value
- and parent. */
- val = XCHAR_TABLE (val)->defalt;
+ /* Reaching here means IDXVAL is a generic character in
+ which each character or a group has independent value.
+ Essentially it's nonsense to get a value for such a
+ generic character, but for backward compatibility, we try
+ the default value and parent. */
+ val = current_default;
if (NILP (val))
{
array = XCHAR_TABLE (array)->parent;
}
}
-/* 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,
doc: /* Store into the element of ARRAY at index IDX the value NEWELT.
Return NEWELT. ARRAY may be a vector, a string, a char-table or a
CHECK_NUMBER (idx);
idxval = XINT (idx);
- if (!VECTORP (array) && !STRINGP (array) && !BOOL_VECTOR_P (array)
- && ! CHAR_TABLE_P (array))
- array = wrong_type_argument (Qarrayp, array);
+ CHECK_ARRAY (array, Qarrayp);
CHECK_IMPURE (array);
if (VECTORP (array))
if (idxval < 0)
args_out_of_range (array, idx);
if (idxval < CHAR_TABLE_ORDINARY_SLOTS)
- XCHAR_TABLE (array)->contents[idxval] = newelt;
+ {
+ if (! SINGLE_BYTE_CHAR_P (idxval))
+ args_out_of_range (array, idx);
+ XCHAR_TABLE (array)->contents[idxval] = newelt;
+ }
else
{
int code[4], i;
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. */
+ initial value VAL and look into it. */
- temp = make_sub_char_table (NILP (val)
- ? XCHAR_TABLE (array)->defalt
- : val);
+ temp = make_sub_char_table (val);
XCHAR_TABLE (array)->contents[code[i]] = temp;
array = temp;
}
/* We must relocate the string data. */
int nchars = SCHARS (array);
unsigned char *str;
+ USE_SAFE_ALLOCA;
- str = (nbytes <= MAX_ALLOCA
- ? (unsigned char *) alloca (nbytes)
- : (unsigned char *) xmalloc (nbytes));
+ SAFE_ALLOCA (str, unsigned char *, nbytes);
bcopy (SDATA (array), str, nbytes);
allocate_string_data (XSTRING (array), nchars,
nbytes + new_bytes - prev_bytes);
p1 = SDATA (array) + idxval_byte;
bcopy (str + idxval_byte + prev_bytes, p1 + new_bytes,
nbytes - (idxval_byte + prev_bytes));
- if (nbytes > MAX_ALLOCA)
- xfree (str);
+ SAFE_FREE ();
clear_string_char_byte_cache ();
}
while (new_bytes--)
unsigned char workbuf[MAX_MULTIBYTE_LENGTH], *p0 = workbuf, *p1;
unsigned char *origstr = SDATA (array), *str;
int nchars, nbytes;
+ USE_SAFE_ALLOCA;
nchars = SCHARS (array);
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));
+ SAFE_ALLOCA (str, unsigned char *, nbytes);
copy_text (SDATA (array), str, nchars, 0, 1);
PARSE_MULTIBYTE_SEQ (str + idxval_byte, nbytes - idxval_byte,
prev_bytes);
*p1++ = *p0++;
bcopy (str + idxval_byte + prev_bytes, p1,
nbytes - (idxval_byte + prev_bytes));
- if (nbytes > MAX_ALLOCA)
- xfree (str);
+ SAFE_FREE ();
clear_string_char_byte_cache ();
}
}
CHECK_NUMBER (base);
b = XINT (base);
if (b < 2 || b > 16)
- Fsignal (Qargs_out_of_range, Fcons (base, Qnil));
+ xsignal1 (Qargs_out_of_range, base);
}
/* Skip any whitespace at the front of the number. Some versions of
else
{
if (next == 0)
- Fsignal (Qarith_error, Qnil);
+ xsignal0 (Qarith_error);
accum /= next;
}
break;
else
{
if (! IEEE_FLOATING_POINT && next == 0)
- Fsignal (Qarith_error, Qnil);
+ xsignal0 (Qarith_error);
accum /= next;
}
break;
int nargs;
Lisp_Object *args;
{
+ int argnum;
+ for (argnum = 2; argnum < nargs; argnum++)
+ if (FLOATP (args[argnum]))
+ return float_arith_driver (0, 0, Adiv, nargs, args);
return arith_driver (Adiv, nargs, args);
}
CHECK_NUMBER_COERCE_MARKER (y);
if (XFASTINT (y) == 0)
- Fsignal (Qarith_error, Qnil);
+ xsignal0 (Qarith_error);
XSETINT (val, XINT (x) % XINT (y));
return val;
i2 = XINT (y);
if (i2 == 0)
- Fsignal (Qarith_error, Qnil);
+ xsignal0 (Qarith_error);
i1 %= i2;
DEFUN ("logxor", Flogxor, Slogxor, 0, MANY, 0,
doc: /* Return bitwise-exclusive-or of all the arguments.
Arguments may be integers, or markers converted to integers.
-usage: (logxor &rest INTS-OR-MARKERS) */)
+usage: (logxor &rest INTS-OR-MARKERS) */)
(nargs, args)
int nargs;
Lisp_Object *args;
staticpro (&Qargs_out_of_range);
staticpro (&Qvoid_function);
staticpro (&Qcyclic_function_indirection);
+ staticpro (&Qcyclic_variable_indirection);
staticpro (&Qvoid_variable);
staticpro (&Qsetting_constant);
staticpro (&Qinvalid_read_syntax);
sigsetmask (SIGEMPTYMASK);
#endif /* not BSD4_1 */
- Fsignal (Qarith_error, Qnil);
+ SIGNAL_THREAD_CHECK (signo);
+ xsignal0 (Qarith_error);
}
void