/* 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, 2007, 2008, 2009, 2010
+ Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2011
Free Software Foundation, Inc.
This file is part of GNU Emacs.
#include <math.h>
-#if !defined (atof)
-extern double atof (const char *);
-#endif /* !atof */
-
-Lisp_Object Qnil, Qt, Qquote, Qlambda, Qsubr, Qunbound;
+Lisp_Object Qnil, Qt, Qquote, Qlambda, Qunbound;
+static Lisp_Object Qsubr;
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, Qcyclic_function_indirection;
-Lisp_Object Qcyclic_variable_indirection, Qcircular_list;
-Lisp_Object Qsetting_constant, Qinvalid_read_syntax;
+Lisp_Object Qerror, Qquit, Qargs_out_of_range;
+static Lisp_Object Qwrong_type_argument;
+Lisp_Object Qvoid_variable, Qvoid_function;
+static Lisp_Object Qcyclic_function_indirection;
+static Lisp_Object Qcyclic_variable_indirection;
+Lisp_Object Qcircular_list;
+static Lisp_Object Qsetting_constant;
+Lisp_Object Qinvalid_read_syntax;
Lisp_Object Qinvalid_function, Qwrong_number_of_arguments, Qno_catch;
Lisp_Object Qend_of_file, Qarith_error, Qmark_inactive;
Lisp_Object Qbeginning_of_buffer, Qend_of_buffer, Qbuffer_read_only;
Lisp_Object Qtext_read_only;
-Lisp_Object Qintegerp, Qnatnump, Qwholenump, Qsymbolp, Qlistp, Qconsp;
+Lisp_Object Qintegerp, Qwholenump, Qsymbolp, Qlistp, Qconsp;
+static Lisp_Object Qnatnump;
Lisp_Object Qstringp, Qarrayp, Qsequencep, Qbufferp;
Lisp_Object Qchar_or_string_p, Qmarkerp, Qinteger_or_marker_p, Qvectorp;
-Lisp_Object Qbuffer_or_string_p, Qkeywordp;
-Lisp_Object Qboundp, Qfboundp;
+Lisp_Object Qbuffer_or_string_p;
+static Lisp_Object Qkeywordp, Qboundp;
+Lisp_Object Qfboundp;
Lisp_Object Qchar_table_p, Qvector_or_char_table_p;
Lisp_Object Qcdr;
-Lisp_Object Qad_advice_info, Qad_activate_internal;
+static Lisp_Object Qad_advice_info, Qad_activate_internal;
Lisp_Object Qrange_error, Qdomain_error, Qsingularity_error;
Lisp_Object Qoverflow_error, Qunderflow_error;
static Lisp_Object Qsymbol, Qstring, Qcons, Qmarker, Qoverlay;
Lisp_Object Qwindow;
static Lisp_Object Qfloat, Qwindow_configuration;
-Lisp_Object Qprocess;
-static Lisp_Object Qcompiled_function, Qfunction_vector, Qbuffer, Qframe, Qvector;
+static 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;
Lisp_Object Qfont_spec, Qfont_entity, Qfont_object;
static void swap_in_symval_forwarding (struct Lisp_Symbol *, struct Lisp_Buffer_Local_Value *);
-Lisp_Object Vmost_positive_fixnum, Vmost_negative_fixnum;
-
-
-void
-circular_list_error (Lisp_Object list)
-{
- xsignal (Qcircular_list, list);
-}
-
Lisp_Object
wrong_type_argument (register Lisp_Object predicate, register Lisp_Object value)
xsignal3 (Qargs_out_of_range, a1, a2, a3);
}
-/* On some machines, XINT needs a temporary location.
- Here it is, in case it is needed. */
-
-int sign_extend_temp;
-
-/* On a few machines, XINT can only be done by calling this. */
-
-int
-sign_extend_lisp_int (EMACS_INT num)
-{
- if (num & (((EMACS_INT) 1) << (VALBITS - 1)))
- return num | (((EMACS_INT) (-1)) << VALBITS);
- else
- return num & ((((EMACS_INT) 1) << VALBITS) - 1);
-}
\f
/* Data type predicates */
return Qwindow;
if (SUBRP (object))
return Qsubr;
- if (FUNVECP (object))
- if (FUNVEC_COMPILED_P (object))
- return Qcompiled_function;
- else
- return Qfunction_vector;
+ if (COMPILEDP (object))
+ return Qcompiled_function;
if (BUFFERP (object))
return Qbuffer;
if (CHAR_TABLE_P (object))
return Qnil;
}
-DEFUN ("funvecp", Ffunvecp, Sfunvecp, 1, 1, 0,
- doc: /* Return t if OBJECT is a `function vector' object. */)
- (Lisp_Object object)
-{
- return FUNVECP (object) ? Qt : Qnil;
-}
-
DEFUN ("char-or-string-p", Fchar_or_string_p, Schar_or_string_p, 1, 1, 0,
doc: /* Return t if OBJECT is a character or a string. */)
(register Lisp_Object object)
else if (CONSP (fun))
{
Lisp_Object funcar = XCAR (fun);
- if (EQ (funcar, Qlambda))
+ if (EQ (funcar, Qclosure))
+ return Fassq (Qinteractive, Fcdr (Fcdr (XCDR (fun))));
+ else if (EQ (funcar, Qlambda))
return Fassq (Qinteractive, Fcdr (XCDR (fun)));
else if (EQ (funcar, Qautoload))
{
(Lisp_Object object)
{
if (SYMBOLP (object))
- XSETSYMBOL (object, indirect_variable (XSYMBOL (object)));
+ {
+ struct Lisp_Symbol *sym = indirect_variable (XSYMBOL (object));
+ XSETSYMBOL (object, sym);
+ }
return object;
}
This does not handle buffer-local variables; use
swap_in_symval_forwarding for that. */
-#define do_blv_forwarding(blv) \
- ((blv)->forwarded ? do_symval_forwarding (BLV_FWD (blv)) : BLV_VALUE (blv))
-
Lisp_Object
do_symval_forwarding (register union Lisp_Fwd *valcontents)
{
BUF non-zero means set the value in buffer BUF instead of the
current buffer. This only plays a role for per-buffer variables. */
-#define store_blv_forwarding(blv, newval, buf) \
- do { \
- if ((blv)->forwarded) \
- store_symval_forwarding (BLV_FWD (blv), (newval), (buf)); \
- else \
- SET_BLV_VALUE (blv, newval); \
- } while (0)
-
static void
store_symval_forwarding (union Lisp_Fwd *valcontents, register Lisp_Object newval, struct buffer *buf)
{
for (tail = Vbuffer_alist; CONSP (tail); tail = XCDR (tail))
{
- Lisp_Object buf;
+ Lisp_Object lbuf;
struct buffer *b;
- buf = Fcdr (XCAR (tail));
- if (!BUFFERP (buf)) continue;
- b = XBUFFER (buf);
+ lbuf = Fcdr (XCAR (tail));
+ if (!BUFFERP (lbuf)) continue;
+ b = XBUFFER (lbuf);
if (! PER_BUFFER_VALUE_P (b, idx))
PER_BUFFER_VALUE (b, offset) = newval;
}
else
{
- tem1 = assq_no_quit (var, current_buffer->local_var_alist);
+ tem1 = assq_no_quit (var, BVAR (current_buffer, local_var_alist));
XSETBUFFER (blv->where, current_buffer);
}
}
tem1 = Fassq (symbol,
(blv->frame_local
? XFRAME (where)->param_alist
- : XBUFFER (where)->local_var_alist));
+ : BVAR (XBUFFER (where), local_var_alist)));
blv->where = where;
blv->found = 1;
bindings, not for frame-local bindings. */
eassert (!blv->frame_local);
tem1 = Fcons (symbol, XCDR (blv->defcell));
- XBUFFER (where)->local_var_alist
- = Fcons (tem1, XBUFFER (where)->local_var_alist);
+ BVAR (XBUFFER (where), local_var_alist)
+ = Fcons (tem1, BVAR (XBUFFER (where), local_var_alist));
}
}
/* Return the default value of SYMBOL, but don't check for voidness.
Return Qunbound if it is void. */
-Lisp_Object
+static Lisp_Object
default_value (Lisp_Object symbol)
{
struct Lisp_Symbol *sym;
do
{
- val = Feval (Fcar (Fcdr (args_left)));
+ val = eval_sub (Fcar (Fcdr (args_left)));
symbol = XCAR (args_left);
Fset_default (symbol, val);
args_left = Fcdr (XCDR (args_left));
return blv;
}
-DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local, Smake_variable_buffer_local,
- 1, 1, "vMake Variable Buffer Local: ",
+DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local,
+ Smake_variable_buffer_local, 1, 1, "vMake Variable Buffer Local: ",
doc: /* Make VARIABLE become buffer-local whenever it is set.
At any time, the value for the current buffer is in effect,
unless the variable has never been set in this buffer,
{
struct Lisp_Symbol *sym;
struct Lisp_Buffer_Local_Value *blv = NULL;
- union Lisp_Val_Fwd valcontents;
- int forwarded;
+ union Lisp_Val_Fwd valcontents IF_LINT (= {0});
+ int forwarded IF_LINT (= 0);
CHECK_SYMBOL (variable);
sym = XSYMBOL (variable);
(register Lisp_Object variable)
{
register Lisp_Object tem;
- int forwarded;
- union Lisp_Val_Fwd valcontents;
+ int forwarded IF_LINT (= 0);
+ union Lisp_Val_Fwd valcontents IF_LINT (= {0});
struct Lisp_Symbol *sym;
struct Lisp_Buffer_Local_Value *blv = NULL;
if (let_shadows_global_binding_p (symbol))
message ("Making %s local to %s while let-bound!",
SDATA (SYMBOL_NAME (variable)),
- SDATA (current_buffer->name));
+ SDATA (BVAR (current_buffer, name)));
}
}
/* Make sure this buffer has its own value of symbol. */
XSETSYMBOL (variable, sym); /* Update in case of aliasing. */
- tem = Fassq (variable, current_buffer->local_var_alist);
+ tem = Fassq (variable, BVAR (current_buffer, local_var_alist));
if (NILP (tem))
{
if (let_shadows_buffer_binding_p (sym))
default value. */
find_symbol_value (variable);
- current_buffer->local_var_alist
+ BVAR (current_buffer, local_var_alist)
= Fcons (Fcons (variable, XCDR (blv->defcell)),
- current_buffer->local_var_alist);
+ BVAR (current_buffer, local_var_alist));
/* Make sure symbol does not think it is set up for this buffer;
force it to look once again for this buffer's value. */
/* Get rid of this buffer's alist element, if any. */
XSETSYMBOL (variable, sym); /* Propagate variable indirection. */
- tem = Fassq (variable, current_buffer->local_var_alist);
+ tem = Fassq (variable, BVAR (current_buffer, local_var_alist));
if (!NILP (tem))
- current_buffer->local_var_alist
- = Fdelq (tem, current_buffer->local_var_alist);
+ BVAR (current_buffer, local_var_alist)
+ = Fdelq (tem, BVAR (current_buffer, local_var_alist));
/* If the symbol is set up with the current buffer's binding
loaded, recompute its value. We have to do it now, or else
XSETBUFFER (tmp, buf);
XSETSYMBOL (variable, sym); /* Update in case of aliasing. */
- for (tail = buf->local_var_alist; CONSP (tail); tail = XCDR (tail))
+ for (tail = BVAR (buf, local_var_alist); CONSP (tail); tail = XCDR (tail))
{
elt = XCAR (tail);
if (EQ (variable, XCAR (elt)))
#if 0
extern struct terminal *get_terminal (Lisp_Object display, int);
-DEFUN ("terminal-local-value", Fterminal_local_value, Sterminal_local_value, 2, 2, 0,
+DEFUN ("terminal-local-value", Fterminal_local_value,
+ Sterminal_local_value, 2, 2, 0,
doc: /* Return the terminal-local value of SYMBOL on TERMINAL.
If SYMBOL is not a terminal-local variable, then return its normal
value, like `symbol-value'.
return result;
}
-DEFUN ("set-terminal-local-value", Fset_terminal_local_value, Sset_terminal_local_value, 3, 3, 0,
+DEFUN ("set-terminal-local-value", Fset_terminal_local_value,
+ Sset_terminal_local_value, 3, 3, 0,
doc: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
If VARIABLE is not a terminal-local variable, then set its normal
binding, like `set'.
{
int size = 0;
if (VECTORP (array))
- size = ASIZE (array);
- else if (FUNVECP (array))
- size = FUNVEC_SIZE (array);
+ size = XVECTOR (array)->size;
+ else if (COMPILEDP (array))
+ size = XVECTOR (array)->size & PSEUDOVECTOR_SIZE_MASK;
else
wrong_type_argument (Qarrayp, array);
enum comparison { equal, notequal, less, grtr, less_or_equal, grtr_or_equal };
-Lisp_Object
+static Lisp_Object
arithcompare (Lisp_Object num1, Lisp_Object num2, enum comparison comparison)
{
double f1 = 0, f2 = 0;
if (FLOATP (number))
{
- char pigbuf[350]; /* see comments in float_to_string */
+ char pigbuf[FLOAT_TO_STRING_BUFSIZE];
float_to_string (pigbuf, XFLOAT_DATA (number));
return build_string (pigbuf);
}
- if (sizeof (int) == sizeof (EMACS_INT))
- sprintf (buffer, "%d", (int) XINT (number));
- else if (sizeof (long) == sizeof (EMACS_INT))
- sprintf (buffer, "%ld", (long) XINT (number));
- else
- abort ();
+ sprintf (buffer, "%"pI"d", XINT (number));
return build_string (buffer);
}
-INLINE static int
-digit_to_number (int character, int 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,
doc: /* Parse STRING as a decimal number and return the number.
This parses both integers and floating point numbers.
If the base used is not 10, STRING is always parsed as integer. */)
(register Lisp_Object string, Lisp_Object base)
{
- register unsigned char *p;
+ register char *p;
register int b;
- int sign = 1;
Lisp_Object val;
CHECK_STRING (string);
xsignal1 (Qargs_out_of_range, base);
}
- /* 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 = SDATA (string);
+ p = SSDATA (string);
while (*p == ' ' || *p == '\t')
p++;
- if (*p == '-')
- {
- sign = -1;
- p++;
- }
- else if (*p == '+')
- p++;
-
- if (isfloat_string (p, 1) && b == 10)
- val = make_float (sign * atof (p));
- else
- {
- double v = 0;
-
- while (1)
- {
- int digit = digit_to_number (*p++, b);
- if (digit < 0)
- break;
- v = v * b + digit;
- }
-
- val = make_fixnum_or_float (sign * v);
- }
-
- return val;
+ val = string_to_number (p, b, 1);
+ return NILP (val) ? make_number (0) : val;
}
-
\f
enum arithop
{
Amin
};
-static Lisp_Object float_arith_driver (double, int, enum arithop,
- int, Lisp_Object *);
-Lisp_Object
-arith_driver (enum arithop code, int nargs, register Lisp_Object *args)
+static Lisp_Object float_arith_driver (double, size_t, enum arithop,
+ size_t, Lisp_Object *);
+static Lisp_Object
+arith_driver (enum arithop code, size_t nargs, register Lisp_Object *args)
{
register Lisp_Object val;
- register int argnum;
+ register size_t argnum;
register EMACS_INT accum = 0;
register EMACS_INT next;
#define isnan(x) ((x) != (x))
static Lisp_Object
-float_arith_driver (double accum, register int argnum, enum arithop code, int nargs, register Lisp_Object *args)
+float_arith_driver (double accum, register size_t argnum, enum arithop code,
+ size_t nargs, register Lisp_Object *args)
{
register Lisp_Object val;
double next;
DEFUN ("+", Fplus, Splus, 0, MANY, 0,
doc: /* Return sum of any number of arguments, which are numbers or markers.
usage: (+ &rest NUMBERS-OR-MARKERS) */)
- (int nargs, Lisp_Object *args)
+ (size_t nargs, Lisp_Object *args)
{
return arith_driver (Aadd, nargs, args);
}
With one arg, negates it. With more than one arg,
subtracts all but the first from the first.
usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
- (int nargs, Lisp_Object *args)
+ (size_t nargs, Lisp_Object *args)
{
return arith_driver (Asub, nargs, args);
}
DEFUN ("*", Ftimes, Stimes, 0, MANY, 0,
doc: /* Return product of any number of arguments, which are numbers or markers.
usage: (* &rest NUMBERS-OR-MARKERS) */)
- (int nargs, Lisp_Object *args)
+ (size_t nargs, Lisp_Object *args)
{
return arith_driver (Amult, nargs, args);
}
doc: /* Return first argument divided by all the remaining arguments.
The arguments must be numbers or markers.
usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
- (int nargs, Lisp_Object *args)
+ (size_t nargs, Lisp_Object *args)
{
- int argnum;
+ size_t argnum;
for (argnum = 2; argnum < nargs; argnum++)
if (FLOATP (args[argnum]))
return float_arith_driver (0, 0, Adiv, nargs, args);
doc: /* Return largest of all the arguments (which must be numbers or markers).
The value is always a number; markers are converted to numbers.
usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
- (int nargs, Lisp_Object *args)
+ (size_t nargs, Lisp_Object *args)
{
return arith_driver (Amax, nargs, args);
}
doc: /* Return smallest of all the arguments (which must be numbers or markers).
The value is always a number; markers are converted to numbers.
usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
- (int nargs, Lisp_Object *args)
+ (size_t nargs, Lisp_Object *args)
{
return arith_driver (Amin, nargs, args);
}
doc: /* Return bitwise-and of all the arguments.
Arguments may be integers, or markers converted to integers.
usage: (logand &rest INTS-OR-MARKERS) */)
- (int nargs, Lisp_Object *args)
+ (size_t nargs, Lisp_Object *args)
{
return arith_driver (Alogand, nargs, args);
}
doc: /* Return bitwise-or of all the arguments.
Arguments may be integers, or markers converted to integers.
usage: (logior &rest INTS-OR-MARKERS) */)
- (int nargs, Lisp_Object *args)
+ (size_t nargs, Lisp_Object *args)
{
return arith_driver (Alogior, nargs, args);
}
doc: /* Return bitwise-exclusive-or of all the arguments.
Arguments may be integers, or markers converted to integers.
usage: (logxor &rest INTS-OR-MARKERS) */)
- (int nargs, Lisp_Object *args)
+ (size_t nargs, Lisp_Object *args)
{
return arith_driver (Alogxor, nargs, args);
}
Qwindow = intern_c_string ("window");
/* Qsubr = intern_c_string ("subr"); */
Qcompiled_function = intern_c_string ("compiled-function");
- Qfunction_vector = intern_c_string ("function-vector");
Qbuffer = intern_c_string ("buffer");
Qframe = intern_c_string ("frame");
Qvector = intern_c_string ("vector");
staticpro (&Qwindow);
/* staticpro (&Qsubr); */
staticpro (&Qcompiled_function);
- staticpro (&Qfunction_vector);
staticpro (&Qbuffer);
staticpro (&Qframe);
staticpro (&Qvector);
defsubr (&Smarkerp);
defsubr (&Ssubrp);
defsubr (&Sbyte_code_function_p);
- defsubr (&Sfunvecp);
defsubr (&Schar_or_string_p);
defsubr (&Scar);
defsubr (&Scdr);
XSYMBOL (Qwholenump)->function = XSYMBOL (Qnatnump)->function;
- DEFVAR_LISP ("most-positive-fixnum", &Vmost_positive_fixnum,
+ DEFVAR_LISP ("most-positive-fixnum", Vmost_positive_fixnum,
doc: /* The largest value that is representable in a Lisp integer. */);
Vmost_positive_fixnum = make_number (MOST_POSITIVE_FIXNUM);
XSYMBOL (intern_c_string ("most-positive-fixnum"))->constant = 1;
- DEFVAR_LISP ("most-negative-fixnum", &Vmost_negative_fixnum,
+ DEFVAR_LISP ("most-negative-fixnum", Vmost_negative_fixnum,
doc: /* The smallest value that is representable in a Lisp integer. */);
Vmost_negative_fixnum = make_number (MOST_NEGATIVE_FIXNUM);
XSYMBOL (intern_c_string ("most-negative-fixnum"))->constant = 1;
}
-SIGTYPE
+#ifndef FORWARD_SIGNAL_TO_MAIN_THREAD
+static void arith_error (int) NO_RETURN;
+#endif
+
+static void
arith_error (int signo)
{
sigsetmask (SIGEMPTYMASK);
signal (SIGEMT, arith_error);
#endif /* uts */
}
-
-/* arch-tag: 25879798-b84d-479a-9c89-7d148e2109f7
- (do not change this comment) */
HCoop / bpt / emacs.git / blobdiff