/* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
- Copyright (C) 1985, 1986, 1988 Free Software Foundation, Inc.
+ Copyright (C) 1985, 1986, 1988, 1993 Free Software Foundation, Inc.
This file is part of GNU Emacs.
#include "buffer.h"
#endif
-#include "emacssignal.h"
+#include "syssignal.h"
#ifdef LISP_FLOAT_TYPE
+#ifdef STDC_HEADERS
+#include <stdlib.h>
+#endif
#include <math.h>
#endif /* LISP_FLOAT_TYPE */
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 Qvoid_variable, Qvoid_function;
+Lisp_Object Qvoid_variable, Qvoid_function, Qcyclic_function_indirection;
Lisp_Object Qsetting_constant, Qinvalid_read_syntax;
Lisp_Object Qinvalid_function, Qwrong_number_of_arguments, Qno_catch;
Lisp_Object Qend_of_file, Qarith_error;
Lisp_Object Qintegerp, Qnatnump, Qsymbolp, Qlistp, Qconsp;
Lisp_Object Qstringp, Qarrayp, Qsequencep, Qbufferp;
Lisp_Object Qchar_or_string_p, Qmarkerp, Qinteger_or_marker_p, Qvectorp;
+Lisp_Object Qbuffer_or_string_p;
Lisp_Object Qboundp, Qfboundp;
Lisp_Object Qcdr;
+Lisp_Object Qrange_error, Qdomain_error, Qsingularity_error;
+Lisp_Object Qoverflow_error, Qunderflow_error;
+
#ifdef LISP_FLOAT_TYPE
-Lisp_Object Qfloatp, Qinteger_or_floatp, Qinteger_or_float_or_marker_p;
+Lisp_Object Qfloatp;
Lisp_Object Qnumberp, Qnumber_or_marker_p;
#endif
{
if (XTYPE (value) == Lisp_String &&
(EQ (predicate, Qintegerp) || EQ (predicate, Qinteger_or_marker_p)))
- return Fstring_to_int (value, Qt);
+ return Fstring_to_number (value);
if (XTYPE (value) == Lisp_Int && EQ (predicate, Qstringp))
- return Fint_to_string (value);
+ return Fnumber_to_string (value);
}
value = Fsignal (Qwrong_type_argument, Fcons (predicate, Fcons (value, Qnil)));
tem = call1 (predicate, value);
return Qnil;
}
-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).")
- (obj)
- register Lisp_Object obj;
-{
- if (XTYPE (obj) == Lisp_Marker || XTYPE (obj) == Lisp_Int)
- return Qt;
- return Qnil;
-}
-
DEFUN ("subrp", Fsubrp, Ssubrp, 1, 1, 0, "T if OBJECT is a built-in function.")
(obj)
Lisp_Object obj;
return Qnil;
}
-DEFUN ("compiled-function-p", Fcompiled_function_p, Scompiled_function_p,
- 1, 1, 0, "T if OBJECT is a compiled function 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.")
(obj)
Lisp_Object obj;
{
return Qnil;
}
-DEFUN ("natnump", Fnatnump, Snatnump, 1, 1, 0, "T if OBJECT is a nonnegative number.")
+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).")
(obj)
- Lisp_Object obj;
+ register Lisp_Object obj;
{
- if (XTYPE (obj) == Lisp_Int && XINT (obj) >= 0)
+ if (XTYPE (obj) == Lisp_Marker || XTYPE (obj) == Lisp_Int)
return Qt;
return Qnil;
}
-#ifdef LISP_FLOAT_TYPE
-DEFUN ("floatp", Ffloatp, Sfloatp, 1, 1, 0,
- "T if OBJECT is a floating point number.")
+DEFUN ("natnump", Fnatnump, Snatnump, 1, 1, 0, "T if OBJECT is a nonnegative number.")
(obj)
Lisp_Object obj;
{
- if (XTYPE (obj) == Lisp_Float)
+ if (XTYPE (obj) == Lisp_Int && XINT (obj) >= 0)
return Qt;
return Qnil;
}
(obj)
Lisp_Object obj;
{
- if (XTYPE (obj) == Lisp_Float || XTYPE (obj) == Lisp_Int)
+ if (NUMBERP (obj))
return Qt;
- return Qnil;
+ else
+ return Qnil;
}
DEFUN ("number-or-marker-p", Fnumber_or_marker_p,
(obj)
Lisp_Object obj;
{
- if (XTYPE (obj) == Lisp_Float
- || XTYPE (obj) == Lisp_Int
+ if (NUMBERP (obj)
|| XTYPE (obj) == Lisp_Marker)
return Qt;
return Qnil;
}
+
+#ifdef LISP_FLOAT_TYPE
+DEFUN ("floatp", Ffloatp, Sfloatp, 1, 1, 0,
+ "T if OBJECT is a floating point number.")
+ (obj)
+ Lisp_Object obj;
+{
+ if (XTYPE (obj) == Lisp_Float)
+ return Qt;
+ return Qnil;
+}
#endif /* LISP_FLOAT_TYPE */
\f
/* Extract and set components of lists */
DEFUN ("symbol-function", Fsymbol_function, Ssymbol_function, 1, 1, 0,
"Return SYMBOL's function definition. Error if that is void.")
- (sym)
- register Lisp_Object sym;
+ (symbol)
+ register Lisp_Object symbol;
{
- CHECK_SYMBOL (sym, 0);
- if (EQ (XSYMBOL (sym)->function, Qunbound))
- return Fsignal (Qvoid_function, Fcons (sym, Qnil));
- return XSYMBOL (sym)->function;
+ CHECK_SYMBOL (symbol, 0);
+ if (EQ (XSYMBOL (symbol)->function, Qunbound))
+ return Fsignal (Qvoid_function, Fcons (symbol, Qnil));
+ return XSYMBOL (symbol)->function;
}
DEFUN ("symbol-plist", Fsymbol_plist, Ssymbol_plist, 1, 1, 0, "Return SYMBOL's property list.")
register Lisp_Object sym, newdef;
{
CHECK_SYMBOL (sym, 0);
+
if (!NILP (Vautoload_queue) && !EQ (XSYMBOL (sym)->function, Qunbound))
Vautoload_queue = Fcons (Fcons (sym, XSYMBOL (sym)->function),
Vautoload_queue);
return newdef;
}
+/* This name should be removed once it is eliminated from elsewhere. */
+
+DEFUN ("defalias", Fdefalias, Sdefalias, 2, 2, 0,
+ "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.\n\
+Associates the function with the current load file, if any.")
+ (sym, newdef)
+ register Lisp_Object sym, newdef;
+{
+ CHECK_SYMBOL (sym, 0);
+ if (!NILP (Vautoload_queue) && !EQ (XSYMBOL (sym)->function, Qunbound))
+ Vautoload_queue = Fcons (Fcons (sym, XSYMBOL (sym)->function),
+ Vautoload_queue);
+ XSYMBOL (sym)->function = newdef;
+ LOADHIST_ATTACH (sym);
+ return newdef;
+}
+
+DEFUN ("define-function", Fdefine_function, Sdefine_function, 2, 2, 0,
+ "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.\n\
+Associates the function with the current load file, if any.")
+ (sym, newdef)
+ register Lisp_Object sym, newdef;
+{
+ CHECK_SYMBOL (sym, 0);
+ if (!NILP (Vautoload_queue) && !EQ (XSYMBOL (sym)->function, Qunbound))
+ Vautoload_queue = Fcons (Fcons (sym, XSYMBOL (sym)->function),
+ Vautoload_queue);
+ XSYMBOL (sym)->function = newdef;
+ LOADHIST_ATTACH (sym);
+ return newdef;
+}
+
DEFUN ("setplist", Fsetplist, Ssetplist, 2, 2, 0,
"Set SYMBOL's property list to NEWVAL, and return NEWVAL.")
(sym, newplist)
XSYMBOL (sym)->plist = newplist;
return newplist;
}
+
\f
/* Getting and setting values of symbols */
break;
case Lisp_Buffer_Objfwd:
- *(Lisp_Object *)(XUINT (valcontents) + (char *)current_buffer) = newval;
- break;
+ {
+ unsigned int offset = XUINT (valcontents);
+ Lisp_Object type =
+ *(Lisp_Object *)(offset + (char *)&buffer_local_types);
+
+ if (! NILP (type) && ! NILP (newval)
+ && XTYPE (newval) != XINT (type))
+ buffer_slot_type_mismatch (valcontents, newval);
+
+ *(Lisp_Object *)(XUINT (valcontents) + (char *)current_buffer)
+ = newval;
+ break;
+ }
default:
valcontents = XSYMBOL (sym)->value;
(REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE)).
CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
- local_var_alist, that being the element whose car is this variable.
- Or it can be a pointer to the (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER
- does not have an element in its alist for this variable.
-
- If the current buffer is not BUFFER, we store the current REALVALUE value into
- CURRENT-ALIST-ELEMENT, then find the appropriate alist element for
- the buffer now current and set up CURRENT-ALIST-ELEMENT.
- Then we set REALVALUE out of that element, and store into BUFFER.
+ local_var_alist, that being the element whose car is this
+ variable. Or it can be a pointer to the
+ (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not have
+ an element in its alist for this variable.
+
+ If the current buffer is not BUFFER, we store the current
+ REALVALUE value into CURRENT-ALIST-ELEMENT, then find the
+ appropriate alist element for the buffer now current and set up
+ CURRENT-ALIST-ELEMENT. Then we set REALVALUE out of that
+ element, and store into BUFFER.
+
Note that REALVALUE can be a forwarding pointer. */
register Lisp_Object tem1;
return XCONS (valcontents)->car;
}
\f
-/* Note that it must not be possible to quit within this function.
- Great care is required for this. */
+/* Find the value of a symbol, returning Qunbound if it's not bound.
+ This is helpful for code which just wants to get a variable's value
+ if it has one, without signalling an error.
+ Note that it must not be possible to quit
+ within this function. Great care is required for this. */
-DEFUN ("symbol-value", Fsymbol_value, Ssymbol_value, 1, 1, 0,
- "Return SYMBOL's value. Error if that is void.")
- (sym)
+Lisp_Object
+find_symbol_value (sym)
Lisp_Object sym;
{
register Lisp_Object valcontents, tem1;
case Lisp_Buffer_Objfwd:
return *(Lisp_Object *)(XUINT (valcontents) + (char *)current_buffer);
- case Lisp_Symbol:
- /* For a symbol, check whether it is 'unbound. */
- if (!EQ (valcontents, Qunbound))
- break;
- /* drops through! */
case Lisp_Void:
- return Fsignal (Qvoid_variable, Fcons (sym, Qnil));
+ return Qunbound;
}
return valcontents;
}
+DEFUN ("symbol-value", Fsymbol_value, Ssymbol_value, 1, 1, 0,
+ "Return SYMBOL's value. Error if that is void.")
+ (sym)
+ Lisp_Object sym;
+{
+ Lisp_Object val = find_symbol_value (sym);
+
+ if (EQ (val, Qunbound))
+ return Fsignal (Qvoid_variable, Fcons (sym, Qnil));
+ else
+ return val;
+}
+
DEFUN ("set", Fset, Sset, 2, 2, 0,
"Set SYMBOL's value to NEWVAL, and return NEWVAL.")
(sym, newval)
current_buffer->local_var_flags |= mask;
}
- if (XTYPE (valcontents) == Lisp_Buffer_Local_Value
- || XTYPE (valcontents) == Lisp_Some_Buffer_Local_Value)
+ else if (XTYPE (valcontents) == Lisp_Buffer_Local_Value
+ || XTYPE (valcontents) == Lisp_Some_Buffer_Local_Value)
{
- /* valcontents is a list
- (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE)).
-
- CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
- local_var_alist, that being the element whose car is this variable.
- Or it can be a pointer to the (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER
- does not have an element in its alist for this variable.
-
- If the current buffer is not BUFFER, we store the current REALVALUE value into
- CURRENT-ALIST-ELEMENT, then find the appropriate alist element for
- the buffer now current and set up CURRENT-ALIST-ELEMENT.
- Then we set REALVALUE out of that element, and store into BUFFER.
- Note that REALVALUE can be a forwarding pointer. */
-
- current_alist_element = XCONS (XCONS (XCONS (valcontents)->cdr)->cdr)->car;
- if (current_buffer != ((XTYPE (valcontents) == Lisp_Some_Buffer_Local_Value)
- ? XBUFFER (XCONS (XCONS (valcontents)->cdr)->car)
- : XBUFFER (XCONS (current_alist_element)->car)))
+ /* valcontents is actually a pointer to a cons heading something like:
+ (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE).
+
+ BUFFER is the last buffer for which this symbol's value was
+ made up to date.
+
+ CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
+ local_var_alist, that being the element whose car is this
+ variable. Or it can be a pointer to the
+ (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not
+ have an element in its alist for this variable (that is, if
+ BUFFER sees the default value of this variable).
+
+ If we want to examine or set the value and BUFFER is current,
+ we just examine or set REALVALUE. If BUFFER is not current, we
+ store the current REALVALUE value into CURRENT-ALIST-ELEMENT,
+ then find the appropriate alist element for the buffer now
+ current and set up CURRENT-ALIST-ELEMENT. Then we set
+ REALVALUE out of that element, and store into BUFFER.
+
+ If we are setting the variable and the current buffer does
+ not have an alist entry for this variable, an alist entry is
+ created.
+
+ Note that REALVALUE can be a forwarding pointer. Each time
+ it is examined or set, forwarding must be done. */
+
+ /* What value are we caching right now? */
+ current_alist_element =
+ XCONS (XCONS (XCONS (valcontents)->cdr)->cdr)->car;
+
+ /* If the current buffer is not the buffer whose binding is
+ currently cached, or if it's a Lisp_Buffer_Local_Value and
+ we're looking at the default value, the cache is invalid; we
+ need to write it out, and find the new CURRENT-ALIST-ELEMENT. */
+ if ((current_buffer
+ != XBUFFER (XCONS (XCONS (valcontents)->cdr)->car))
+ || (XTYPE (valcontents) == Lisp_Buffer_Local_Value
+ && EQ (XCONS (current_alist_element)->car,
+ current_alist_element)))
{
- Fsetcdr (current_alist_element, do_symval_forwarding (XCONS (valcontents)->car));
+ /* Write out the cached value for the old buffer; copy it
+ back to its alist element. This works if the current
+ buffer only sees the default value, too. */
+ Fsetcdr (current_alist_element,
+ do_symval_forwarding (XCONS (valcontents)->car));
+ /* Find the new value for CURRENT-ALIST-ELEMENT. */
tem1 = Fassq (sym, current_buffer->local_var_alist);
if (NILP (tem1))
- /* This buffer sees the default value still.
- If type is Lisp_Some_Buffer_Local_Value, set the default value.
- If type is Lisp_Buffer_Local_Value, give this buffer a local value
- and set that. */
- if (XTYPE (valcontents) == Lisp_Some_Buffer_Local_Value)
- tem1 = XCONS (XCONS (valcontents)->cdr)->cdr;
- else
- {
- tem1 = Fcons (sym, Fcdr (current_alist_element));
- current_buffer->local_var_alist = Fcons (tem1, current_buffer->local_var_alist);
- }
+ {
+ /* This buffer still sees the default value. */
+
+ /* If the variable is a Lisp_Some_Buffer_Local_Value,
+ make CURRENT-ALIST-ELEMENT point to itself,
+ indicating that we're seeing the default value. */
+ if (XTYPE (valcontents) == Lisp_Some_Buffer_Local_Value)
+ tem1 = XCONS (XCONS (valcontents)->cdr)->cdr;
+
+ /* If it's a Lisp_Buffer_Local_Value, give this buffer a
+ new assoc for a local value and set
+ CURRENT-ALIST-ELEMENT to point to that. */
+ else
+ {
+ tem1 = Fcons (sym, Fcdr (current_alist_element));
+ current_buffer->local_var_alist =
+ Fcons (tem1, current_buffer->local_var_alist);
+ }
+ }
+ /* Cache the new buffer's assoc in CURRENT-ALIST-ELEMENT. */
XCONS (XCONS (XCONS (valcontents)->cdr)->cdr)->car = tem1;
- XSET (XCONS (XCONS (valcontents)->cdr)->car, Lisp_Buffer, current_buffer);
+
+ /* Set BUFFER, now that CURRENT-ALIST-ELEMENT is accurate. */
+ XSET (XCONS (XCONS (valcontents)->cdr)->car,
+ Lisp_Buffer, current_buffer);
}
valcontents = XCONS (valcontents)->car;
}
+
/* If storing void (making the symbol void), forward only through
buffer-local indicator, not through Lisp_Objfwd, etc. */
if (voide)
store_symval_forwarding (sym, Qnil, newval);
else
store_symval_forwarding (sym, valcontents, newval);
+
return newval;
}
\f
return val;
}
\f
+/* Lisp functions for creating and removing buffer-local variables. */
+
DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local, Smake_variable_buffer_local,
1, 1, "vMake Variable Buffer Local: ",
"Make VARIABLE have a separate value for each buffer.\n\
if (current_buffer == XBUFFER (XCONS (XCONS (xs)->cdr)->car))
XCONS (XCONS (XSYMBOL (sym)->value)->cdr)->car = Qnil;
}
-
}
+
+ /* If the symbol forwards into a C variable, then swap in the
+ variable for this buffer immediately. If C code modifies the
+ variable before we swap in, then that new value will clobber the
+ default value the next time we swap. */
+ valcontents = XCONS (XSYMBOL (sym)->value)->car;
+ if (XTYPE (valcontents) == Lisp_Intfwd
+ || XTYPE (valcontents) == Lisp_Boolfwd
+ || XTYPE (valcontents) == Lisp_Objfwd)
+ swap_in_symval_forwarding (sym, XSYMBOL (sym)->value);
+
return sym;
}
return sym;
}
\f
+/* Find the function at the end of a chain of symbol function indirections. */
+
+/* If OBJECT is a symbol, find the end of its function chain and
+ return the value found there. If OBJECT is not a symbol, just
+ return it. If there is a cycle in the function chain, signal a
+ cyclic-function-indirection error.
+
+ This is like Findirect_function, except that it doesn't signal an
+ error if the chain ends up unbound. */
+Lisp_Object
+indirect_function (object)
+ register Lisp_Object object;
+{
+ Lisp_Object tortoise, hare;
+
+ hare = tortoise = object;
+
+ for (;;)
+ {
+ if (XTYPE (hare) != Lisp_Symbol || EQ (hare, Qunbound))
+ break;
+ hare = XSYMBOL (hare)->function;
+ if (XTYPE (hare) != Lisp_Symbol || EQ (hare, Qunbound))
+ break;
+ hare = XSYMBOL (hare)->function;
+
+ tortoise = XSYMBOL (tortoise)->function;
+
+ if (EQ (hare, tortoise))
+ Fsignal (Qcyclic_function_indirection, Fcons (object, Qnil));
+ }
+
+ return hare;
+}
+
+DEFUN ("indirect-function", Findirect_function, Sindirect_function, 1, 1, 0,
+ "Return the function at the end of OBJECT's function chain.\n\
+If OBJECT is a symbol, follow all function indirections and return the final\n\
+function binding.\n\
+If OBJECT is not a symbol, just return it.\n\
+Signal a void-function error if the final symbol is unbound.\n\
+Signal a cyclic-function-indirection error if there is a loop in the\n\
+function chain of symbols.")
+ (object)
+ register Lisp_Object object;
+{
+ Lisp_Object result;
+
+ result = indirect_function (object);
+
+ if (EQ (result, Qunbound))
+ return Fsignal (Qvoid_function, Fcons (object, Qnil));
+ return result;
+}
+\f
/* Extract and set vector and string elements */
DEFUN ("aref", Faref, Saref, 2, 2, 0,
if (floatp ? f1 >= f2 : XINT (num1) >= XINT (num2))
return Qt;
return Qnil;
+
+ default:
+ abort ();
}
}
return Qnil;
}
\f
-DEFUN ("int-to-string", Fint_to_string, Sint_to_string, 1, 1, 0,
- "Convert INT to a string by printing it in decimal.\n\
-Uses a minus sign if negative.")
+/* Convert between 32-bit values and pairs of lispy 24-bit values. */
+
+Lisp_Object
+long_to_cons (i)
+ unsigned long i;
+{
+ unsigned int top = i >> 16;
+ unsigned int bot = i & 0xFFFF;
+ if (top == 0)
+ return make_number (bot);
+ if (top == 0xFFFF)
+ return Fcons (make_number (-1), make_number (bot));
+ return Fcons (make_number (top), make_number (bot));
+}
+
+unsigned long
+cons_to_long (c)
+ Lisp_Object c;
+{
+ Lisp_Object top, bot;
+ if (INTEGERP (c))
+ return XINT (c);
+ top = XCONS (c)->car;
+ bot = XCONS (c)->cdr;
+ if (CONSP (bot))
+ bot = XCONS (bot)->car;
+ return ((XINT (top) << 16) | XINT (bot));
+}
+\f
+DEFUN ("number-to-string", Fnumber_to_string, Snumber_to_string, 1, 1, 0,
+ "Convert NUM to a string by printing it in decimal.\n\
+Uses a minus sign if negative.\n\
+NUM may be an integer or a floating point number.")
(num)
Lisp_Object num;
{
return build_string (buffer);
}
-DEFUN ("string-to-int", Fstring_to_int, Sstring_to_int, 1, 1, 0,
- "Convert STRING to an integer by parsing it as a decimal number.")
+DEFUN ("string-to-number", Fstring_to_number, Sstring_to_number, 1, 1, 0,
+ "Convert STRING to a number by parsing it as a decimal number.\n\
+This parses both integers and floating point numbers.")
(str)
register Lisp_Object str;
{
+ unsigned char *p;
+
CHECK_STRING (str, 0);
+ p = XSTRING (str)->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. */
+ while (*p == ' ' || *p == '\t')
+ p++;
+
#ifdef LISP_FLOAT_TYPE
- if (isfloat_string (XSTRING (str)->data))
- return make_float (atof (XSTRING (str)->data));
+ if (isfloat_string (p))
+ return make_float (atof (p));
#endif /* LISP_FLOAT_TYPE */
- return make_number (atoi (XSTRING (str)->data));
+ return make_number (atoi (p));
}
\f
enum arithop
{ Aadd, Asub, Amult, Adiv, Alogand, Alogior, Alogxor, Amax, Amin };
+extern Lisp_Object float_arith_driver ();
+
Lisp_Object
-arith_driver
- (code, nargs, args)
+arith_driver (code, nargs, args)
enum arithop code;
int nargs;
register Lisp_Object *args;
case Amult: accum *= next; break;
case Adiv:
if (!argnum) accum = next;
- else accum /= next;
+ else
+ {
+ if (next == 0)
+ Fsignal (Qarith_error, Qnil);
+ accum /= next;
+ }
break;
case Alogand: accum &= next; break;
case Alogior: accum |= next; break;
if (!argnum)
accum = next;
else
- accum /= next;
+ {
+ if (next == 0)
+ Fsignal (Qarith_error, Qnil);
+ accum /= next;
+ }
break;
case Alogand:
case Alogior:
f1 = XTYPE (num1) == Lisp_Float ? XFLOAT (num1)->data : XINT (num1);
f2 = XTYPE (num2) == Lisp_Float ? XFLOAT (num2)->data : XINT (num2);
- return (make_float (drem (f1,f2)));
+ if (f2 == 0)
+ Fsignal (Qarith_error, Qnil);
+
+#if defined (USG) || defined (sun) || defined (ultrix) || defined (hpux)
+ f1 = fmod (f1, f2);
+#else
+ f1 = drem (f1, f2);
+#endif
+ /* If the "remainder" comes out with the wrong sign, fix it. */
+ if ((f1 < 0) != (f2 < 0))
+ f1 += f2;
+ return (make_float (f1));
}
#else /* not LISP_FLOAT_TYPE */
CHECK_NUMBER_COERCE_MARKER (num1, 0);
CHECK_NUMBER_COERCE_MARKER (num2, 1);
#endif /* not LISP_FLOAT_TYPE */
+ if (XFASTINT (num2) == 0)
+ Fsignal (Qarith_error, Qnil);
+
XSET (val, Lisp_Int, XINT (num1) % XINT (num2));
return val;
}
void
syms_of_data ()
{
+ Lisp_Object error_tail, arith_tail;
+
Qquote = intern ("quote");
Qlambda = intern ("lambda");
Qsubr = intern ("subr");
Qwrong_type_argument = intern ("wrong-type-argument");
Qargs_out_of_range = intern ("args-out-of-range");
Qvoid_function = intern ("void-function");
+ Qcyclic_function_indirection = intern ("cyclic-function-indirection");
Qvoid_variable = intern ("void-variable");
Qsetting_constant = intern ("setting-constant");
Qinvalid_read_syntax = intern ("invalid-read-syntax");
Qvectorp = intern ("vectorp");
Qchar_or_string_p = intern ("char-or-string-p");
Qmarkerp = intern ("markerp");
+ Qbuffer_or_string_p = intern ("buffer-or-string-p");
Qinteger_or_marker_p = intern ("integer-or-marker-p");
Qboundp = intern ("boundp");
Qfboundp = intern ("fboundp");
Qcdr = intern ("cdr");
+ error_tail = Fcons (Qerror, Qnil);
+
/* ERROR is used as a signaler for random errors for which nothing else is right */
Fput (Qerror, Qerror_conditions,
- Fcons (Qerror, Qnil));
+ error_tail);
Fput (Qerror, Qerror_message,
build_string ("error"));
build_string ("Quit"));
Fput (Qwrong_type_argument, Qerror_conditions,
- Fcons (Qwrong_type_argument, Fcons (Qerror, Qnil)));
+ Fcons (Qwrong_type_argument, error_tail));
Fput (Qwrong_type_argument, Qerror_message,
build_string ("Wrong type argument"));
Fput (Qargs_out_of_range, Qerror_conditions,
- Fcons (Qargs_out_of_range, Fcons (Qerror, Qnil)));
+ Fcons (Qargs_out_of_range, error_tail));
Fput (Qargs_out_of_range, Qerror_message,
build_string ("Args out of range"));
Fput (Qvoid_function, Qerror_conditions,
- Fcons (Qvoid_function, Fcons (Qerror, Qnil)));
+ Fcons (Qvoid_function, error_tail));
Fput (Qvoid_function, Qerror_message,
build_string ("Symbol's function definition is void"));
+ Fput (Qcyclic_function_indirection, Qerror_conditions,
+ Fcons (Qcyclic_function_indirection, error_tail));
+ Fput (Qcyclic_function_indirection, Qerror_message,
+ build_string ("Symbol's chain of function indirections contains a loop"));
+
Fput (Qvoid_variable, Qerror_conditions,
- Fcons (Qvoid_variable, Fcons (Qerror, Qnil)));
+ Fcons (Qvoid_variable, error_tail));
Fput (Qvoid_variable, Qerror_message,
build_string ("Symbol's value as variable is void"));
Fput (Qsetting_constant, Qerror_conditions,
- Fcons (Qsetting_constant, Fcons (Qerror, Qnil)));
+ Fcons (Qsetting_constant, error_tail));
Fput (Qsetting_constant, Qerror_message,
build_string ("Attempt to set a constant symbol"));
Fput (Qinvalid_read_syntax, Qerror_conditions,
- Fcons (Qinvalid_read_syntax, Fcons (Qerror, Qnil)));
+ Fcons (Qinvalid_read_syntax, error_tail));
Fput (Qinvalid_read_syntax, Qerror_message,
build_string ("Invalid read syntax"));
Fput (Qinvalid_function, Qerror_conditions,
- Fcons (Qinvalid_function, Fcons (Qerror, Qnil)));
+ Fcons (Qinvalid_function, error_tail));
Fput (Qinvalid_function, Qerror_message,
build_string ("Invalid function"));
Fput (Qwrong_number_of_arguments, Qerror_conditions,
- Fcons (Qwrong_number_of_arguments, Fcons (Qerror, Qnil)));
+ Fcons (Qwrong_number_of_arguments, error_tail));
Fput (Qwrong_number_of_arguments, Qerror_message,
build_string ("Wrong number of arguments"));
Fput (Qno_catch, Qerror_conditions,
- Fcons (Qno_catch, Fcons (Qerror, Qnil)));
+ Fcons (Qno_catch, error_tail));
Fput (Qno_catch, Qerror_message,
build_string ("No catch for tag"));
Fput (Qend_of_file, Qerror_conditions,
- Fcons (Qend_of_file, Fcons (Qerror, Qnil)));
+ Fcons (Qend_of_file, error_tail));
Fput (Qend_of_file, Qerror_message,
build_string ("End of file during parsing"));
+ arith_tail = Fcons (Qarith_error, error_tail);
Fput (Qarith_error, Qerror_conditions,
- Fcons (Qarith_error, Fcons (Qerror, Qnil)));
+ arith_tail);
Fput (Qarith_error, Qerror_message,
build_string ("Arithmetic error"));
Fput (Qbeginning_of_buffer, Qerror_conditions,
- Fcons (Qbeginning_of_buffer, Fcons (Qerror, Qnil)));
+ Fcons (Qbeginning_of_buffer, error_tail));
Fput (Qbeginning_of_buffer, Qerror_message,
build_string ("Beginning of buffer"));
Fput (Qend_of_buffer, Qerror_conditions,
- Fcons (Qend_of_buffer, Fcons (Qerror, Qnil)));
+ Fcons (Qend_of_buffer, error_tail));
Fput (Qend_of_buffer, Qerror_message,
build_string ("End of buffer"));
Fput (Qbuffer_read_only, Qerror_conditions,
- Fcons (Qbuffer_read_only, Fcons (Qerror, Qnil)));
+ Fcons (Qbuffer_read_only, error_tail));
Fput (Qbuffer_read_only, Qerror_message,
build_string ("Buffer is read-only"));
+#ifdef LISP_FLOAT_TYPE
+ Qrange_error = intern ("range-error");
+ Qdomain_error = intern ("domain-error");
+ Qsingularity_error = intern ("singularity-error");
+ Qoverflow_error = intern ("overflow-error");
+ Qunderflow_error = intern ("underflow-error");
+
+ Fput (Qdomain_error, Qerror_conditions,
+ Fcons (Qdomain_error, arith_tail));
+ Fput (Qdomain_error, Qerror_message,
+ build_string ("Arithmetic domain error"));
+
+ Fput (Qrange_error, Qerror_conditions,
+ Fcons (Qrange_error, arith_tail));
+ Fput (Qrange_error, Qerror_message,
+ build_string ("Arithmetic range error"));
+
+ Fput (Qsingularity_error, Qerror_conditions,
+ Fcons (Qsingularity_error, Fcons (Qdomain_error, arith_tail)));
+ Fput (Qsingularity_error, Qerror_message,
+ build_string ("Arithmetic singularity error"));
+
+ Fput (Qoverflow_error, Qerror_conditions,
+ Fcons (Qoverflow_error, Fcons (Qdomain_error, arith_tail)));
+ Fput (Qoverflow_error, Qerror_message,
+ build_string ("Arithmetic overflow error"));
+
+ Fput (Qunderflow_error, Qerror_conditions,
+ Fcons (Qunderflow_error, Fcons (Qdomain_error, arith_tail)));
+ Fput (Qunderflow_error, Qerror_message,
+ build_string ("Arithmetic underflow error"));
+
+ staticpro (&Qrange_error);
+ staticpro (&Qdomain_error);
+ staticpro (&Qsingularity_error);
+ staticpro (&Qoverflow_error);
+ staticpro (&Qunderflow_error);
+#endif /* LISP_FLOAT_TYPE */
+
staticpro (&Qnil);
staticpro (&Qt);
staticpro (&Qquote);
staticpro (&Qwrong_type_argument);
staticpro (&Qargs_out_of_range);
staticpro (&Qvoid_function);
+ staticpro (&Qcyclic_function_indirection);
staticpro (&Qvoid_variable);
staticpro (&Qsetting_constant);
staticpro (&Qinvalid_read_syntax);
staticpro (&Qvectorp);
staticpro (&Qchar_or_string_p);
staticpro (&Qmarkerp);
+ staticpro (&Qbuffer_or_string_p);
staticpro (&Qinteger_or_marker_p);
#ifdef LISP_FLOAT_TYPE
staticpro (&Qfloatp);
- staticpro (&Qinteger_or_floatp);
- staticpro (&Qinteger_or_float_or_marker_p);
+ staticpro (&Qnumberp);
+ staticpro (&Qnumber_or_marker_p);
#endif /* LISP_FLOAT_TYPE */
staticpro (&Qboundp);
defsubr (&Sconsp);
defsubr (&Satom);
defsubr (&Sintegerp);
-#ifdef LISP_FLOAT_TYPE
- defsubr (&Sfloatp);
+ defsubr (&Sinteger_or_marker_p);
defsubr (&Snumberp);
defsubr (&Snumber_or_marker_p);
+#ifdef LISP_FLOAT_TYPE
+ defsubr (&Sfloatp);
#endif /* LISP_FLOAT_TYPE */
defsubr (&Snatnump);
defsubr (&Ssymbolp);
defsubr (&Ssequencep);
defsubr (&Sbufferp);
defsubr (&Smarkerp);
- defsubr (&Sinteger_or_marker_p);
defsubr (&Ssubrp);
- defsubr (&Scompiled_function_p);
+ defsubr (&Sbyte_code_function_p);
defsubr (&Schar_or_string_p);
defsubr (&Scar);
defsubr (&Scdr);
defsubr (&Ssetcar);
defsubr (&Ssetcdr);
defsubr (&Ssymbol_function);
+ defsubr (&Sindirect_function);
defsubr (&Ssymbol_plist);
defsubr (&Ssymbol_name);
defsubr (&Smakunbound);
defsubr (&Sboundp);
defsubr (&Sfboundp);
defsubr (&Sfset);
+ defsubr (&Sdefalias);
+ defsubr (&Sdefine_function);
defsubr (&Ssetplist);
defsubr (&Ssymbol_value);
defsubr (&Sset);
defsubr (&Skill_local_variable);
defsubr (&Saref);
defsubr (&Saset);
- defsubr (&Sint_to_string);
- defsubr (&Sstring_to_int);
+ defsubr (&Snumber_to_string);
+ defsubr (&Sstring_to_number);
defsubr (&Seqlsign);
defsubr (&Slss);
defsubr (&Sgtr);
return;
#endif /* CANNOT_DUMP */
signal (SIGFPE, arith_error);
+
#ifdef uts
signal (SIGEMT, arith_error);
#endif /* uts */
HCoop / bpt / emacs.git / blobdiff