/* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
Copyright (C) 1985, 1986, 1988, 1993, 1994, 1995, 1997, 1998, 1999, 2000,
- 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
+ 2001, 2002, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc.
This file is part of GNU Emacs.
GNU Emacs is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
+the Free Software Foundation; either version 3, or (at your option)
any later version.
GNU Emacs is distributed in the hope that it will be useful,
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));
- /* This function is marked as NO_RETURN, gcc would warn if it has a
- return statement or if falls off the function. Other compilers
- warn if no return statement is present. */
-#ifndef __GNUC__
- return value;
-#else
- abort ();
-#endif
+ 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.
(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;
}
(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,
(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);
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));
}
(cmd)
Lisp_Object cmd;
{
- Lisp_Object fun = indirect_function (cmd);
+ Lisp_Object fun = indirect_function (cmd); /* Check cycles. */
+
+ if (NILP (fun) || EQ (fun, Qunbound))
+ return Qnil;
+
+ /* Use an `interactive-form' property if present, analogous to the
+ function-documentation property. */
+ fun = cmd;
+ while (SYMBOLP (fun))
+ {
+ Lisp_Object tmp = Fget (fun, intern ("interactive-form"));
+ if (!NILP (tmp))
+ return tmp;
+ else
+ fun = Fsymbol_function (fun);
+ }
if (SUBRP (fun))
{
- if (XSUBR (fun)->prompt)
- return list2 (Qinteractive, build_string (XSUBR (fun)->prompt));
+ char *spec = XSUBR (fun)->intspec;
+ if (spec)
+ return list2 (Qinteractive,
+ (*spec != '(') ? build_string (spec) :
+ Fcar (Fread_from_string (build_string (spec), Qnil, Qnil)));
}
else if (COMPILEDP (fun))
{
tortoise = XSYMBOL (tortoise)->value;
if (EQ (hare, tortoise))
- Fsignal (Qcyclic_variable_indirection, Fcons (symbol, Qnil));
+ xsignal1 (Qcyclic_variable_indirection, symbol);
}
return hare;
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);
XSETCAR (XBUFFER_LOCAL_VALUE (valcontents)->cdr,
tem1);
- /* Set `buffer' and `frame' slots for thebinding now loaded. */
+ /* Set `buffer' and `frame' slots for the binding now loaded. */
XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents)->buffer, buf);
XBUFFER_LOCAL_VALUE (valcontents)->frame = selected_frame;
}
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,
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...]) */)
+usage: (setq-default [VAR VALUE]...) */)
(args)
Lisp_Object args;
{
XBUFFER_LOCAL_VALUE (newval)->found_for_frame = 0;
XBUFFER_LOCAL_VALUE (newval)->check_frame = 0;
XBUFFER_LOCAL_VALUE (newval)->cdr = tem;
- SET_SYMBOL_VALUE (variable, newval);;
+ SET_SYMBOL_VALUE (variable, newval);
}
/* Make sure this buffer has its own value of symbol. */
tem = Fassq (variable, current_buffer->local_var_alist);
tortoise = XSYMBOL (tortoise)->function;
if (EQ (hare, tortoise))
- Fsignal (Qcyclic_function_indirection, Fcons (object, Qnil));
+ xsignal1 (Qcyclic_function_indirection, object);
}
return hare;
{
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 (EQ (result, Qunbound))
- return (NILP (noerror)
- ? Fsignal (Qvoid_function, Fcons (object, Qnil))
- : Qnil);
- return result;
+ if (NILP (noerror))
+ xsignal1 (Qvoid_function, object);
+
+ return Qnil;
}
\f
/* Extract and set vector and string elements */
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))
return Qnil;
}
\f
-/* Convert between long values and pairs of Lisp integers. */
+/* Convert between long values and pairs of Lisp integers.
+ Note that long_to_cons returns a single Lisp integer
+ when the value fits in one. */
Lisp_Object
long_to_cons (i)
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;
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;
#endif /* not BSD4_1 */
SIGNAL_THREAD_CHECK (signo);
- Fsignal (Qarith_error, Qnil);
+ xsignal0 (Qarith_error);
}
void