#include <config.h>
-#include <signal.h>
#include <stdio.h>
-#include <setjmp.h>
#include <intprops.h>
#include "syssignal.h"
#include "termhooks.h" /* For FRAME_KBOARD reference in y-or-n-p. */
#include "font.h"
+#include "keymap.h"
#include <float.h>
-/* If IEEE_FLOATING_POINT isn't defined, default it from FLT_*. */
-#ifndef IEEE_FLOATING_POINT
#if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \
&& FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128)
#define IEEE_FLOATING_POINT 1
#else
#define IEEE_FLOATING_POINT 0
#endif
-#endif
-
-#include <math.h>
Lisp_Object Qnil, Qt, Qquote, Qlambda, Qunbound;
static Lisp_Object Qsubr;
Lisp_Object Qerror_conditions, Qerror_message, Qtop_level;
-Lisp_Object Qerror, Qquit, Qargs_out_of_range;
+Lisp_Object Qerror, Quser_error, Qquit, Qargs_out_of_range;
static Lisp_Object Qwrong_type_argument;
Lisp_Object Qvoid_variable, Qvoid_function;
static Lisp_Object Qcyclic_function_indirection;
Lisp_Object Qcdr;
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 Qdomain_error, Qsingularity_error, Qunderflow_error;
+Lisp_Object Qrange_error, Qoverflow_error;
Lisp_Object Qfloatp;
Lisp_Object Qnumberp, Qnumber_or_marker_p;
-Lisp_Object Qinteger;
-static Lisp_Object Qsymbol, Qstring, Qcons, Qmarker, Qoverlay;
+Lisp_Object Qinteger, Qsymbol;
+static Lisp_Object Qcons, Qfloat, Qmisc, Qstring, Qvector;
Lisp_Object Qwindow;
-static Lisp_Object Qfloat, Qwindow_configuration;
-static Lisp_Object Qprocess;
-static Lisp_Object Qcompiled_function, Qframe, Qvector;
+static Lisp_Object Qoverlay, Qwindow_configuration;
+static Lisp_Object Qprocess, Qmarker;
+static Lisp_Object Qcompiled_function, Qframe;
Lisp_Object Qbuffer;
static Lisp_Object Qchar_table, Qbool_vector, Qhash_table;
static Lisp_Object Qsubrp, Qmany, Qunevalled;
Lisp_Object Qfont_spec, Qfont_entity, Qfont_object;
+static Lisp_Object Qdefun;
Lisp_Object Qinteractive_form;
to try and do that by checking the tagbits, but nowadays all
tagbits are potentially valid. */
/* if ((unsigned int) XTYPE (value) >= Lisp_Type_Limit)
- * abort (); */
+ * emacs_abort (); */
xsignal2 (Qwrong_type_argument, predicate, value);
}
}
\f
-/* Data type predicates */
+/* Data type predicates. */
DEFUN ("eq", Feq, Seq, 2, 2, 0,
doc: /* Return t if the two args are the same Lisp object. */)
case Lisp_Misc_Float:
return Qfloat;
}
- abort ();
+ emacs_abort ();
case Lisp_Vectorlike:
if (WINDOW_CONFIGURATIONP (object))
return Qfloat;
default:
- abort ();
+ emacs_abort ();
}
}
return newcdr;
}
\f
-/* Extract and set components of symbols */
+/* Extract and set components of symbols. */
DEFUN ("boundp", Fboundp, Sboundp, 1, 1, 0,
doc: /* Return t if SYMBOL's value is not void. */)
else
{
swap_in_symval_forwarding (sym, blv);
- valcontents = BLV_VALUE (blv);
+ valcontents = blv_value (blv);
}
break;
}
/* In set_internal, we un-forward vars when their value is
set to Qunbound. */
return Qt;
- default: abort ();
+ default: emacs_abort ();
}
return (EQ (valcontents, Qunbound) ? Qnil : Qt);
(register Lisp_Object symbol)
{
CHECK_SYMBOL (symbol);
- return (EQ (XSYMBOL (symbol)->function, Qunbound) ? Qnil : Qt);
+ return EQ (XSYMBOL (symbol)->function, Qunbound) ? Qnil : Qt;
}
DEFUN ("makunbound", Fmakunbound, Smakunbound, 1, 1, 0,
CHECK_SYMBOL (symbol);
if (NILP (symbol) || EQ (symbol, Qt))
xsignal1 (Qsetting_constant, symbol);
- XSYMBOL (symbol)->function = Qunbound;
+ set_symbol_function (symbol, Qunbound);
return symbol;
}
if (CONSP (function) && EQ (XCAR (function), Qautoload))
Fput (symbol, Qautoload, XCDR (function));
- XSYMBOL (symbol)->function = definition;
- /* Handle automatic advice activation */
- if (CONSP (XSYMBOL (symbol)->plist) && !NILP (Fget (symbol, Qad_advice_info)))
+ set_symbol_function (symbol, definition);
+ /* Handle automatic advice activation. */
+ if (CONSP (XSYMBOL (symbol)->plist)
+ && !NILP (Fget (symbol, Qad_advice_info)))
{
call2 (Qad_activate_internal, symbol, Qnil);
definition = XSYMBOL (symbol)->function;
}
DEFUN ("defalias", Fdefalias, Sdefalias, 2, 3, 0,
- doc: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION.
+ doc: /* Set SYMBOL's function definition to DEFINITION.
Associates the function with the current load file, if any.
The optional third argument DOCSTRING specifies the documentation string
for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
-determined by DEFINITION. */)
+determined by DEFINITION.
+The return value is undefined. */)
(register Lisp_Object symbol, Lisp_Object definition, Lisp_Object docstring)
{
CHECK_SYMBOL (symbol);
if (CONSP (XSYMBOL (symbol)->function)
&& EQ (XCAR (XSYMBOL (symbol)->function), Qautoload))
LOADHIST_ATTACH (Fcons (Qt, symbol));
+ if (!NILP (Vpurify_flag)
+ /* If `definition' is a keymap, immutable (and copying) is wrong. */
+ && !KEYMAPP (definition))
+ definition = Fpurecopy (definition);
definition = Ffset (symbol, definition);
LOADHIST_ATTACH (Fcons (Qdefun, symbol));
if (!NILP (docstring))
Fput (symbol, Qfunction_documentation, docstring);
- return definition;
+ /* We used to return `definition', but now that `defun' and `defmacro' expand
+ to a call to `defalias', we return `symbol' for backward compatibility
+ (bug#11686). */
+ return symbol;
}
DEFUN ("setplist", Fsetplist, Ssetplist, 2, 2, 0,
(register Lisp_Object symbol, Lisp_Object newplist)
{
CHECK_SYMBOL (symbol);
- XSYMBOL (symbol)->plist = newplist;
+ set_symbol_plist (symbol, newplist);
return newplist;
}
{
struct gcpro gcpro1;
GCPRO1 (cmd);
- do_autoload (fun, cmd);
+ Fautoload_do_load (fun, cmd, Qnil);
UNGCPRO;
return Finteractive_form (cmd);
}
DEFUN ("indirect-variable", Findirect_variable, Sindirect_variable, 1, 1, 0,
doc: /* Return the variable at the end of OBJECT's variable chain.
-If OBJECT is a symbol, follow all variable indirections and return the final
-variable. If OBJECT is not a symbol, just return it.
-Signal a cyclic-variable-indirection error if there is a loop in the
-variable chain of symbols. */)
+If OBJECT is a symbol, follow its variable indirections (if any), and
+return the variable at the end of the chain of aliases. See Info node
+`(elisp)Variable Aliases'.
+
+If OBJECT is not a symbol, just return it. If there is a loop in the
+chain of aliases, signal a `cyclic-variable-indirection' error. */)
(Lisp_Object object)
{
if (SYMBOLP (object))
return *XOBJFWD (valcontents)->objvar;
case Lisp_Fwd_Buffer_Obj:
- return PER_BUFFER_VALUE (current_buffer,
+ return per_buffer_value (current_buffer,
XBUFFER_OBJFWD (valcontents)->offset);
case Lisp_Fwd_Kboard_Obj:
don't think anything will break. --lorentey */
return *(Lisp_Object *)(XKBOARD_OBJFWD (valcontents)->offset
+ (char *)FRAME_KBOARD (SELECTED_FRAME ()));
- default: abort ();
+ default: emacs_abort ();
}
}
b = XBUFFER (lbuf);
if (! PER_BUFFER_VALUE_P (b, idx))
- PER_BUFFER_VALUE (b, offset) = newval;
+ set_per_buffer_value (b, offset, newval);
}
}
break;
Lisp_Object type = XBUFFER_OBJFWD (valcontents)->slottype;
if (!(NILP (type) || NILP (newval)
- || (XINT (type) == LISP_INT_TAG
+ || (XINT (type) == Lisp_Int0
? INTEGERP (newval)
: XTYPE (newval) == XINT (type))))
buffer_slot_type_mismatch (newval, XINT (type));
if (buf == NULL)
buf = current_buffer;
- PER_BUFFER_VALUE (buf, offset) = newval;
+ set_per_buffer_value (buf, offset, newval);
}
break;
break;
default:
- abort (); /* goto def; */
+ emacs_abort (); /* goto def; */
}
}
-/* Set up SYMBOL to refer to its global binding.
- This makes it safe to alter the status of other bindings. */
+/* Set up SYMBOL to refer to its global binding. This makes it safe
+ to alter the status of other bindings. BEWARE: this may be called
+ during the mark phase of GC, where we assume that Lisp_Object slots
+ of BLV are marked after this function has changed them. */
void
swap_in_global_binding (struct Lisp_Symbol *symbol)
/* Unload the previously loaded binding. */
if (blv->fwd)
- SET_BLV_VALUE (blv, do_symval_forwarding (blv->fwd));
+ set_blv_value (blv, do_symval_forwarding (blv->fwd));
/* Select the global binding in the symbol. */
- blv->valcell = blv->defcell;
+ set_blv_valcell (blv, blv->defcell);
if (blv->fwd)
store_symval_forwarding (blv->fwd, XCDR (blv->defcell), NULL);
/* Indicate that the global binding is set up now. */
- blv->where = Qnil;
- SET_BLV_FOUND (blv, 0);
+ set_blv_where (blv, Qnil);
+ set_blv_found (blv, 0);
}
/* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
/* Unload the previously loaded binding. */
tem1 = blv->valcell;
if (blv->fwd)
- SET_BLV_VALUE (blv, do_symval_forwarding (blv->fwd));
+ set_blv_value (blv, do_symval_forwarding (blv->fwd));
/* Choose the new binding. */
{
Lisp_Object var;
if (blv->frame_local)
{
tem1 = assq_no_quit (var, XFRAME (selected_frame)->param_alist);
- blv->where = selected_frame;
+ set_blv_where (blv, selected_frame);
}
else
{
tem1 = assq_no_quit (var, BVAR (current_buffer, local_var_alist));
- XSETBUFFER (blv->where, current_buffer);
+ set_blv_where (blv, Fcurrent_buffer ());
}
}
if (!(blv->found = !NILP (tem1)))
tem1 = blv->defcell;
/* Load the new binding. */
- blv->valcell = tem1;
+ set_blv_valcell (blv, tem1);
if (blv->fwd)
- store_symval_forwarding (blv->fwd, BLV_VALUE (blv), NULL);
+ store_symval_forwarding (blv->fwd, blv_value (blv), NULL);
}
}
\f
{
struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym);
swap_in_symval_forwarding (sym, blv);
- return blv->fwd ? do_symval_forwarding (blv->fwd) : BLV_VALUE (blv);
+ return blv->fwd ? do_symval_forwarding (blv->fwd) : blv_value (blv);
}
/* FALLTHROUGH */
case SYMBOL_FORWARDED:
return do_symval_forwarding (SYMBOL_FWD (sym));
- default: abort ();
+ default: emacs_abort ();
}
}
return newval;
}
-/* Return 1 if SYMBOL currently has a let-binding
+/* Return true if SYMBOL currently has a let-binding
which was made in the buffer that is now current. */
-static int
+static bool
let_shadows_buffer_binding_p (struct Lisp_Symbol *symbol)
{
struct specbinding *p;
- for (p = specpdl_ptr - 1; p >= specpdl; p--)
- if (p->func == NULL
+ for (p = specpdl_ptr; p > specpdl; )
+ if ((--p)->func == NULL
&& CONSP (p->symbol))
{
struct Lisp_Symbol *let_bound_symbol = XSYMBOL (XCAR (p->symbol));
eassert (let_bound_symbol->redirect != SYMBOL_VARALIAS);
if (symbol == let_bound_symbol
&& XBUFFER (XCDR (XCDR (p->symbol))) == current_buffer)
- break;
+ return 1;
}
- return p >= specpdl;
+ return 0;
}
-static int
+static bool
let_shadows_global_binding_p (Lisp_Object symbol)
{
struct specbinding *p;
- for (p = specpdl_ptr - 1; p >= specpdl; p--)
- if (p->func == NULL && EQ (p->symbol, symbol))
- break;
+ for (p = specpdl_ptr; p > specpdl; )
+ if ((--p)->func == NULL && EQ (p->symbol, symbol))
+ return 1;
- return p >= specpdl;
+ return 0;
}
/* Store the value NEWVAL into SYMBOL.
If buffer/frame-locality is an issue, WHERE specifies which context to use.
(nil stands for the current buffer/frame).
- If BINDFLAG is zero, then if this symbol is supposed to become
+ If BINDFLAG is false, then if this symbol is supposed to become
local in every buffer where it is set, then we make it local.
- If BINDFLAG is nonzero, we don't do that. */
+ If BINDFLAG is true, we don't do that. */
void
-set_internal (register Lisp_Object symbol, register Lisp_Object newval, register Lisp_Object where, int bindflag)
+set_internal (Lisp_Object symbol, Lisp_Object newval, Lisp_Object where,
+ bool bindflag)
{
- int voide = EQ (newval, Qunbound);
+ bool voide = EQ (newval, Qunbound);
struct Lisp_Symbol *sym;
Lisp_Object tem1;
the default binding is loaded, the loaded binding may be the
wrong one. */
if (!EQ (blv->where, where)
- /* Also unload a global binding (if the var is local_if_set). */
+ /* Also unload a global binding (if the var is local_if_set). */
|| (EQ (blv->valcell, blv->defcell)))
{
/* The currently loaded binding is not necessarily valid.
/* Write out `realvalue' to the old loaded binding. */
if (blv->fwd)
- SET_BLV_VALUE (blv, do_symval_forwarding (blv->fwd));
+ set_blv_value (blv, do_symval_forwarding (blv->fwd));
/* Find the new binding. */
XSETSYMBOL (symbol, sym); /* May have changed via aliasing. */
(blv->frame_local
? XFRAME (where)->param_alist
: BVAR (XBUFFER (where), local_var_alist)));
- blv->where = where;
+ set_blv_where (blv, where);
blv->found = 1;
if (NILP (tem1))
bindings, not for frame-local bindings. */
eassert (!blv->frame_local);
tem1 = Fcons (symbol, XCDR (blv->defcell));
- BVAR (XBUFFER (where), local_var_alist)
- = Fcons (tem1, BVAR (XBUFFER (where), local_var_alist));
+ bset_local_var_alist
+ (XBUFFER (where),
+ Fcons (tem1, BVAR (XBUFFER (where), local_var_alist)));
}
}
/* Record which binding is now loaded. */
- blv->valcell = tem1;
+ set_blv_valcell (blv, tem1);
}
/* Store the new value in the cons cell. */
- SET_BLV_VALUE (blv, newval);
+ set_blv_value (blv, newval);
if (blv->fwd)
{
store_symval_forwarding (/* sym, */ innercontents, newval, buf);
break;
}
- default: abort ();
+ default: emacs_abort ();
}
return;
}
{
int offset = XBUFFER_OBJFWD (valcontents)->offset;
if (PER_BUFFER_IDX (offset) != 0)
- return PER_BUFFER_DEFAULT (offset);
+ return per_buffer_default (offset);
}
/* For other variables, get the current value. */
return do_symval_forwarding (valcontents);
}
- default: abort ();
+ default: emacs_abort ();
}
}
int offset = XBUFFER_OBJFWD (valcontents)->offset;
int idx = PER_BUFFER_IDX (offset);
- PER_BUFFER_DEFAULT (offset) = value;
+ set_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. */
{
struct buffer *b;
- for (b = all_buffers; b; b = b->header.next.buffer)
+ FOR_EACH_BUFFER (b)
if (!PER_BUFFER_VALUE_P (b, idx))
- PER_BUFFER_VALUE (b, offset) = value;
+ set_per_buffer_value (b, offset, value);
}
return value;
}
else
return Fset (symbol, value);
}
- default: abort ();
+ default: emacs_abort ();
}
}
};
static struct Lisp_Buffer_Local_Value *
-make_blv (struct Lisp_Symbol *sym, int forwarded, union Lisp_Val_Fwd valcontents)
+make_blv (struct Lisp_Symbol *sym, bool forwarded,
+ union Lisp_Val_Fwd valcontents)
{
- struct Lisp_Buffer_Local_Value *blv
- = xmalloc (sizeof (struct Lisp_Buffer_Local_Value));
+ struct Lisp_Buffer_Local_Value *blv = xmalloc (sizeof *blv);
Lisp_Object symbol;
Lisp_Object tem;
eassert (!(forwarded && BUFFER_OBJFWDP (valcontents.fwd)));
eassert (!(forwarded && KBOARD_OBJFWDP (valcontents.fwd)));
blv->fwd = forwarded ? valcontents.fwd : NULL;
- blv->where = Qnil;
+ set_blv_where (blv, Qnil);
blv->frame_local = 0;
blv->local_if_set = 0;
- blv->defcell = tem;
- blv->valcell = tem;
- SET_BLV_FOUND (blv, 0);
+ set_blv_defcell (blv, tem);
+ set_blv_valcell (blv, tem);
+ set_blv_found (blv, 0);
return blv;
}
{
struct Lisp_Symbol *sym;
struct Lisp_Buffer_Local_Value *blv = NULL;
- union Lisp_Val_Fwd valcontents IF_LINT (= {0});
- int forwarded IF_LINT (= 0);
+ union Lisp_Val_Fwd valcontents IF_LINT (= {LISP_INITIALLY_ZERO});
+ bool forwarded IF_LINT (= 0);
CHECK_SYMBOL (variable);
sym = XSYMBOL (variable);
else if (BUFFER_OBJFWDP (valcontents.fwd))
return variable;
break;
- default: abort ();
+ default: emacs_abort ();
}
if (sym->constant)
Do not use `make-local-variable' to make a hook variable buffer-local.
Instead, use `add-hook' and specify t for the LOCAL argument. */)
- (register Lisp_Object variable)
+ (Lisp_Object variable)
{
- register Lisp_Object tem;
- int forwarded IF_LINT (= 0);
- union Lisp_Val_Fwd valcontents IF_LINT (= {0});
+ Lisp_Object tem;
+ bool forwarded IF_LINT (= 0);
+ union Lisp_Val_Fwd valcontents IF_LINT (= {LISP_INITIALLY_ZERO});
struct Lisp_Symbol *sym;
struct Lisp_Buffer_Local_Value *blv = NULL;
error ("Symbol %s may not be buffer-local",
SDATA (SYMBOL_NAME (variable)));
break;
- default: abort ();
+ default: emacs_abort ();
}
if (sym->constant)
default value. */
find_symbol_value (variable);
- BVAR (current_buffer, local_var_alist)
- = Fcons (Fcons (variable, XCDR (blv->defcell)),
- BVAR (current_buffer, local_var_alist));
+ bset_local_var_alist
+ (current_buffer,
+ Fcons (Fcons (variable, XCDR (blv->defcell)),
+ 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. */
if (current_buffer == XBUFFER (blv->where))
- blv->where = Qnil;
- /* blv->valcell = blv->defcell;
- * SET_BLV_FOUND (blv, 0); */
- blv->found = 0;
+ set_blv_where (blv, Qnil);
+ set_blv_found (blv, 0);
}
/* If the symbol forwards into a C variable, then load the binding
if (idx > 0)
{
SET_PER_BUFFER_VALUE_P (current_buffer, idx, 0);
- PER_BUFFER_VALUE (current_buffer, offset)
- = PER_BUFFER_DEFAULT (offset);
+ set_per_buffer_value (current_buffer, offset,
+ per_buffer_default (offset));
}
}
return variable;
if (blv->frame_local)
return variable;
break;
- default: abort ();
+ default: emacs_abort ();
}
/* Get rid of this buffer's alist element, if any. */
XSETSYMBOL (variable, sym); /* Propagate variable indirection. */
tem = Fassq (variable, BVAR (current_buffer, local_var_alist));
if (!NILP (tem))
- BVAR (current_buffer, local_var_alist)
- = Fdelq (tem, BVAR (current_buffer, local_var_alist));
+ bset_local_var_alist
+ (current_buffer,
+ 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
Lisp_Object buf; XSETBUFFER (buf, current_buffer);
if (EQ (buf, blv->where))
{
- blv->where = Qnil;
- /* blv->valcell = blv->defcell;
- * SET_BLV_FOUND (blv, 0); */
+ set_blv_where (blv, Qnil);
blv->found = 0;
find_symbol_value (variable);
}
Note that since Emacs 23.1, variables cannot be both buffer-local and
frame-local any more (buffer-local bindings used to take precedence over
frame-local bindings). */)
- (register Lisp_Object variable)
+ (Lisp_Object variable)
{
- int forwarded;
+ bool forwarded;
union Lisp_Val_Fwd valcontents;
struct Lisp_Symbol *sym;
struct Lisp_Buffer_Local_Value *blv = NULL;
error ("Symbol %s may not be frame-local",
SDATA (SYMBOL_NAME (variable)));
break;
- default: abort ();
+ default: emacs_abort ();
}
if (sym->constant)
if (EQ (variable, XCAR (elt)))
{
eassert (!blv->frame_local);
- eassert (BLV_FOUND (blv) || !EQ (blv->where, tmp));
+ eassert (blv_found (blv) || !EQ (blv->where, tmp));
return Qt;
}
}
- eassert (!BLV_FOUND (blv) || !EQ (blv->where, tmp));
+ eassert (!blv_found (blv) || !EQ (blv->where, tmp));
return Qnil;
}
case SYMBOL_FORWARDED:
}
return Qnil;
}
- default: abort ();
+ default: emacs_abort ();
}
}
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 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. */)
+ doc: /* Non-nil if VARIABLE is local in buffer BUFFER when set there.
+BUFFER defaults to the current buffer.
+
+More precisely, return non-nil if either VARIABLE already has a local
+value in BUFFER, or if VARIABLE is automatically buffer-local (see
+`make-variable-buffer-local'). */)
(register Lisp_Object variable, Lisp_Object buffer)
{
struct Lisp_Symbol *sym;
case SYMBOL_FORWARDED:
/* All BUFFER_OBJFWD slots become local if they are set. */
return (BUFFER_OBJFWDP (SYMBOL_FWD (sym)) ? Qt : Qnil);
- default: abort ();
+ default: emacs_abort ();
}
}
if (!NILP (Flocal_variable_p (variable, Qnil)))
return Fcurrent_buffer ();
else if (sym->redirect == SYMBOL_LOCALIZED
- && BLV_FOUND (SYMBOL_BLV (sym)))
+ && blv_found (SYMBOL_BLV (sym)))
return SYMBOL_BLV (sym)->where;
else
return Qnil;
- default: abort ();
+ default: emacs_abort ();
}
}
return Qnil;
}
\f
-/* Extract and set vector and string elements */
+/* Extract and set vector and string elements. */
DEFUN ("aref", Faref, Saref, 2, 2, 0,
doc: /* Return the element of ARRAY at index IDX.
if (STRINGP (array))
{
int c;
- EMACS_INT idxval_byte;
+ ptrdiff_t idxval_byte;
if (idxval < 0 || idxval >= SCHARS (array))
args_out_of_range (array, idx);
}
else
{
- int size = 0;
+ ptrdiff_t size = 0;
if (VECTORP (array))
size = ASIZE (array);
else if (COMPILEDP (array))
{
if (idxval < 0 || idxval >= ASIZE (array))
args_out_of_range (array, idx);
- XVECTOR (array)->contents[idxval] = newelt;
+ ASET (array, idxval, newelt);
}
else if (BOOL_VECTOR_P (array))
{
if (STRING_MULTIBYTE (array))
{
- EMACS_INT idxval_byte, prev_bytes, new_bytes, nbytes;
+ ptrdiff_t idxval_byte, nbytes;
+ int prev_bytes, new_bytes;
unsigned char workbuf[MAX_MULTIBYTE_LENGTH], *p0 = workbuf, *p1;
nbytes = SBYTES (array);
if (prev_bytes != new_bytes)
{
/* We must relocate the string data. */
- EMACS_INT nchars = SCHARS (array);
- unsigned char *str;
+ ptrdiff_t nchars = SCHARS (array);
USE_SAFE_ALLOCA;
+ unsigned char *str = SAFE_ALLOCA (nbytes);
- SAFE_ALLOCA (str, unsigned char *, nbytes);
memcpy (str, SDATA (array), nbytes);
allocate_string_data (XSTRING (array), nchars,
nbytes + new_bytes - prev_bytes);
arithcompare (Lisp_Object num1, Lisp_Object num2, enum comparison comparison)
{
double f1 = 0, f2 = 0;
- int floatp = 0;
+ bool floatp = 0;
CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1);
CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2);
return Qnil;
default:
- abort ();
+ emacs_abort ();
}
}
uintmax_t
cons_to_unsigned (Lisp_Object c, uintmax_t max)
{
- int valid = 0;
+ bool valid = 0;
uintmax_t val IF_LINT (= 0);
if (INTEGERP (c))
{
intmax_t
cons_to_signed (Lisp_Object c, intmax_t min, intmax_t max)
{
- int valid = 0;
+ bool valid = 0;
intmax_t val IF_LINT (= 0);
if (INTEGERP (c))
{
NUMBER may be an integer or a floating point number. */)
(Lisp_Object number)
{
- char buffer[VALBITS];
+ char buffer[max (FLOAT_TO_STRING_BUFSIZE, INT_BUFSIZE_BOUND (EMACS_INT))];
+ int len;
CHECK_NUMBER_OR_FLOAT (number);
if (FLOATP (number))
- {
- char pigbuf[FLOAT_TO_STRING_BUFSIZE];
-
- float_to_string (pigbuf, XFLOAT_DATA (number));
- return build_string (pigbuf);
- }
+ len = float_to_string (buffer, XFLOAT_DATA (number));
+ else
+ len = sprintf (buffer, "%"pI"d", XINT (number));
- sprintf (buffer, "%"pI"d", XINT (number));
- return build_string (buffer);
+ return make_unibyte_string (buffer, len);
}
DEFUN ("string-to-number", Fstring_to_number, Sstring_to_number, 1, 2, 0,
else
{
CHECK_NUMBER (base);
- b = XINT (base);
- if (b < 2 || b > 16)
+ if (! (2 <= XINT (base) && XINT (base) <= 16))
xsignal1 (Qargs_out_of_range, base);
+ b = XINT (base);
}
p = SSDATA (string);
static Lisp_Object
arith_driver (enum arithop code, ptrdiff_t nargs, Lisp_Object *args)
{
- register Lisp_Object val;
- ptrdiff_t argnum;
- register EMACS_INT accum = 0;
- register EMACS_INT next;
-
- int overflow = 0;
- ptrdiff_t ok_args;
- EMACS_INT ok_accum;
+ Lisp_Object val;
+ ptrdiff_t argnum, ok_args;
+ EMACS_INT accum = 0;
+ EMACS_INT next, ok_accum;
+ bool overflow = 0;
- switch (SWITCH_ENUM_CAST (code))
+ switch (code)
{
case Alogior:
case Alogxor:
nargs, args);
args[argnum] = val;
next = XINT (args[argnum]);
- switch (SWITCH_ENUM_CAST (code))
+ switch (code)
{
case Aadd:
if (INT_ADD_OVERFLOW (accum, next))
args[argnum] = val; /* runs into a compiler bug. */
next = XINT (args[argnum]);
}
- switch (SWITCH_ENUM_CAST (code))
+ switch (code)
{
case Aadd:
accum += next;
CHECK_NUMBER_COERCE_MARKER (x);
CHECK_NUMBER_COERCE_MARKER (y);
- if (XFASTINT (y) == 0)
+ if (XINT (y) == 0)
xsignal0 (Qarith_error);
XSETINT (val, XINT (x) % XINT (y));
return val;
}
-#ifndef HAVE_FMOD
-double
-fmod (double f1, double f2)
-{
- double r = f1;
-
- if (f2 < 0.0)
- f2 = -f2;
-
- /* If the magnitude of the result exceeds that of the divisor, or
- the sign of the result does not agree with that of the dividend,
- iterate with the reduced value. This does not yield a
- particularly accurate result, but at least it will be in the
- range promised by fmod. */
- do
- r -= f2 * floor (r / f2);
- while (f2 <= (r < 0 ? -r : r) || ((r < 0) != (f1 < 0) && ! isnan (r)));
-
- return r;
-}
-#endif /* ! HAVE_FMOD */
-
DEFUN ("mod", Fmod, Smod, 2, 2, 0,
doc: /* Return X modulo Y.
The result falls between zero (inclusive) and Y (exclusive).
DEFSYM (Qtop_level, "top-level");
DEFSYM (Qerror, "error");
+ DEFSYM (Quser_error, "user-error");
DEFSYM (Qquit, "quit");
DEFSYM (Qwrong_type_argument, "wrong-type-argument");
DEFSYM (Qargs_out_of_range, "args-out-of-range");
Fput (Qerror, Qerror_conditions,
error_tail);
Fput (Qerror, Qerror_message,
- make_pure_c_string ("error"));
-
- Fput (Qquit, Qerror_conditions,
- pure_cons (Qquit, Qnil));
- Fput (Qquit, Qerror_message,
- make_pure_c_string ("Quit"));
-
- Fput (Qwrong_type_argument, Qerror_conditions,
- pure_cons (Qwrong_type_argument, error_tail));
- Fput (Qwrong_type_argument, Qerror_message,
- make_pure_c_string ("Wrong type argument"));
-
- Fput (Qargs_out_of_range, Qerror_conditions,
- pure_cons (Qargs_out_of_range, error_tail));
- Fput (Qargs_out_of_range, Qerror_message,
- make_pure_c_string ("Args out of range"));
-
- Fput (Qvoid_function, Qerror_conditions,
- pure_cons (Qvoid_function, error_tail));
- Fput (Qvoid_function, Qerror_message,
- make_pure_c_string ("Symbol's function definition is void"));
-
- Fput (Qcyclic_function_indirection, Qerror_conditions,
- pure_cons (Qcyclic_function_indirection, error_tail));
- Fput (Qcyclic_function_indirection, Qerror_message,
- make_pure_c_string ("Symbol's chain of function indirections contains a loop"));
-
- Fput (Qcyclic_variable_indirection, Qerror_conditions,
- pure_cons (Qcyclic_variable_indirection, error_tail));
- Fput (Qcyclic_variable_indirection, Qerror_message,
- make_pure_c_string ("Symbol's chain of variable indirections contains a loop"));
-
+ build_pure_c_string ("error"));
+
+#define PUT_ERROR(sym, tail, msg) \
+ Fput (sym, Qerror_conditions, pure_cons (sym, tail)); \
+ Fput (sym, Qerror_message, build_pure_c_string (msg))
+
+ PUT_ERROR (Qquit, Qnil, "Quit");
+
+ PUT_ERROR (Quser_error, error_tail, "");
+ PUT_ERROR (Qwrong_type_argument, error_tail, "Wrong type argument");
+ PUT_ERROR (Qargs_out_of_range, error_tail, "Args out of range");
+ PUT_ERROR (Qvoid_function, error_tail,
+ "Symbol's function definition is void");
+ PUT_ERROR (Qcyclic_function_indirection, error_tail,
+ "Symbol's chain of function indirections contains a loop");
+ PUT_ERROR (Qcyclic_variable_indirection, error_tail,
+ "Symbol's chain of variable indirections contains a loop");
DEFSYM (Qcircular_list, "circular-list");
- Fput (Qcircular_list, Qerror_conditions,
- pure_cons (Qcircular_list, error_tail));
- Fput (Qcircular_list, Qerror_message,
- make_pure_c_string ("List contains a loop"));
-
- Fput (Qvoid_variable, Qerror_conditions,
- pure_cons (Qvoid_variable, error_tail));
- Fput (Qvoid_variable, Qerror_message,
- make_pure_c_string ("Symbol's value as variable is void"));
-
- Fput (Qsetting_constant, Qerror_conditions,
- pure_cons (Qsetting_constant, error_tail));
- Fput (Qsetting_constant, Qerror_message,
- make_pure_c_string ("Attempt to set a constant symbol"));
-
- Fput (Qinvalid_read_syntax, Qerror_conditions,
- pure_cons (Qinvalid_read_syntax, error_tail));
- Fput (Qinvalid_read_syntax, Qerror_message,
- make_pure_c_string ("Invalid read syntax"));
-
- Fput (Qinvalid_function, Qerror_conditions,
- pure_cons (Qinvalid_function, error_tail));
- Fput (Qinvalid_function, Qerror_message,
- make_pure_c_string ("Invalid function"));
-
- Fput (Qwrong_number_of_arguments, Qerror_conditions,
- pure_cons (Qwrong_number_of_arguments, error_tail));
- Fput (Qwrong_number_of_arguments, Qerror_message,
- make_pure_c_string ("Wrong number of arguments"));
-
- Fput (Qno_catch, Qerror_conditions,
- pure_cons (Qno_catch, error_tail));
- Fput (Qno_catch, Qerror_message,
- make_pure_c_string ("No catch for tag"));
-
- Fput (Qend_of_file, Qerror_conditions,
- pure_cons (Qend_of_file, error_tail));
- Fput (Qend_of_file, Qerror_message,
- make_pure_c_string ("End of file during parsing"));
+ PUT_ERROR (Qcircular_list, error_tail, "List contains a loop");
+ PUT_ERROR (Qvoid_variable, error_tail, "Symbol's value as variable is void");
+ PUT_ERROR (Qsetting_constant, error_tail,
+ "Attempt to set a constant symbol");
+ PUT_ERROR (Qinvalid_read_syntax, error_tail, "Invalid read syntax");
+ PUT_ERROR (Qinvalid_function, error_tail, "Invalid function");
+ PUT_ERROR (Qwrong_number_of_arguments, error_tail,
+ "Wrong number of arguments");
+ PUT_ERROR (Qno_catch, error_tail, "No catch for tag");
+ PUT_ERROR (Qend_of_file, error_tail, "End of file during parsing");
arith_tail = pure_cons (Qarith_error, error_tail);
- Fput (Qarith_error, Qerror_conditions,
- arith_tail);
- Fput (Qarith_error, Qerror_message,
- make_pure_c_string ("Arithmetic error"));
-
- Fput (Qbeginning_of_buffer, Qerror_conditions,
- pure_cons (Qbeginning_of_buffer, error_tail));
- Fput (Qbeginning_of_buffer, Qerror_message,
- make_pure_c_string ("Beginning of buffer"));
-
- Fput (Qend_of_buffer, Qerror_conditions,
- pure_cons (Qend_of_buffer, error_tail));
- Fput (Qend_of_buffer, Qerror_message,
- make_pure_c_string ("End of buffer"));
-
- Fput (Qbuffer_read_only, Qerror_conditions,
- pure_cons (Qbuffer_read_only, error_tail));
- Fput (Qbuffer_read_only, Qerror_message,
- make_pure_c_string ("Buffer is read-only"));
-
- Fput (Qtext_read_only, Qerror_conditions,
- pure_cons (Qtext_read_only, error_tail));
- Fput (Qtext_read_only, Qerror_message,
- make_pure_c_string ("Text is read-only"));
+ Fput (Qarith_error, Qerror_conditions, arith_tail);
+ Fput (Qarith_error, Qerror_message, build_pure_c_string ("Arithmetic error"));
+
+ PUT_ERROR (Qbeginning_of_buffer, error_tail, "Beginning of buffer");
+ PUT_ERROR (Qend_of_buffer, error_tail, "End of buffer");
+ PUT_ERROR (Qbuffer_read_only, error_tail, "Buffer is read-only");
+ PUT_ERROR (Qtext_read_only, pure_cons (Qbuffer_read_only, error_tail),
+ "Text is read-only");
DEFSYM (Qrange_error, "range-error");
DEFSYM (Qdomain_error, "domain-error");
DEFSYM (Qoverflow_error, "overflow-error");
DEFSYM (Qunderflow_error, "underflow-error");
- Fput (Qdomain_error, Qerror_conditions,
- pure_cons (Qdomain_error, arith_tail));
- Fput (Qdomain_error, Qerror_message,
- make_pure_c_string ("Arithmetic domain error"));
-
- Fput (Qrange_error, Qerror_conditions,
- pure_cons (Qrange_error, arith_tail));
- Fput (Qrange_error, Qerror_message,
- make_pure_c_string ("Arithmetic range error"));
+ PUT_ERROR (Qdomain_error, arith_tail, "Arithmetic domain error");
- Fput (Qsingularity_error, Qerror_conditions,
- pure_cons (Qsingularity_error, Fcons (Qdomain_error, arith_tail)));
- Fput (Qsingularity_error, Qerror_message,
- make_pure_c_string ("Arithmetic singularity error"));
+ PUT_ERROR (Qrange_error, arith_tail, "Arithmetic range error");
- Fput (Qoverflow_error, Qerror_conditions,
- pure_cons (Qoverflow_error, Fcons (Qdomain_error, arith_tail)));
- Fput (Qoverflow_error, Qerror_message,
- make_pure_c_string ("Arithmetic overflow error"));
+ PUT_ERROR (Qsingularity_error, Fcons (Qdomain_error, arith_tail),
+ "Arithmetic singularity error");
- Fput (Qunderflow_error, Qerror_conditions,
- pure_cons (Qunderflow_error, Fcons (Qdomain_error, arith_tail)));
- Fput (Qunderflow_error, Qerror_message,
- make_pure_c_string ("Arithmetic underflow error"));
+ PUT_ERROR (Qoverflow_error, Fcons (Qdomain_error, arith_tail),
+ "Arithmetic overflow error");
+ PUT_ERROR (Qunderflow_error, Fcons (Qdomain_error, arith_tail),
+ "Arithmetic underflow error");
staticpro (&Qnil);
staticpro (&Qt);
DEFSYM (Qwindow_configuration, "window-configuration");
DEFSYM (Qprocess, "process");
DEFSYM (Qwindow, "window");
- /* DEFSYM (Qsubr, "subr"); */
DEFSYM (Qcompiled_function, "compiled-function");
DEFSYM (Qbuffer, "buffer");
DEFSYM (Qframe, "frame");
DEFSYM (Qchar_table, "char-table");
DEFSYM (Qbool_vector, "bool-vector");
DEFSYM (Qhash_table, "hash-table");
+ DEFSYM (Qmisc, "misc");
+
+ DEFSYM (Qdefun, "defun");
DEFSYM (Qfont_spec, "font-spec");
DEFSYM (Qfont_entity, "font-entity");
defsubr (&Ssubr_arity);
defsubr (&Ssubr_name);
- XSYMBOL (Qwholenump)->function = XSYMBOL (Qnatnump)->function;
+ set_symbol_function (Qwholenump, XSYMBOL (Qnatnump)->function);
DEFVAR_LISP ("most-positive-fixnum", Vmost_positive_fixnum,
doc: /* The largest value that is representable in a Lisp integer. */);
XSYMBOL (intern_c_string ("most-negative-fixnum"))->constant = 1;
}
-#ifndef FORWARD_SIGNAL_TO_MAIN_THREAD
-static void arith_error (int) NO_RETURN;
-#endif
+static _Noreturn void
+handle_arith_signal (int sig)
+{
+ pthread_sigmask (SIG_SETMASK, &empty_mask, 0);
+ xsignal0 (Qarith_error);
+}
static void
-arith_error (int signo)
+deliver_arith_signal (int sig)
{
- sigsetmask (SIGEMPTYMASK);
-
- SIGNAL_THREAD_CHECK (signo);
- xsignal0 (Qarith_error);
+ handle_on_main_thread (sig, handle_arith_signal);
}
void
init_data (void)
{
+ struct sigaction action;
/* Don't do this if just dumping out.
We don't want to call `signal' in this case
so that we don't have trouble with dumping
if (!initialized)
return;
#endif /* CANNOT_DUMP */
- signal (SIGFPE, arith_error);
+ emacs_sigaction_init (&action, deliver_arith_signal);
+ sigaction (SIGFPE, &action, 0);
}
HCoop / bpt / emacs.git / blobdiff