X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/f0398ec17f8a00d6c6d828c3d04522d94337d156..844e0de1bc2bf56118b749f50a4880db7c918fd5:/src/data.c
diff --git a/src/data.c b/src/data.c
index dedbd51f36..79e605b731 100644
--- a/src/data.c
+++ b/src/data.c
@@ -1,5 +1,5 @@
/* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
- Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2013 Free Software
+ Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2014 Free Software
Foundation, Inc.
This file is part of GNU Emacs.
@@ -21,6 +21,9 @@ along with GNU Emacs. If not, see . */
#include
#include
+#include
+#include
+#include
#include
#include "lisp.h"
@@ -35,9 +38,11 @@ along with GNU Emacs. If not, see . */
#include "keymap.h"
Lisp_Object Qnil, Qt, Qquote, Qlambda, Qunbound;
+Lisp_Object Qnil_, Qt_;
static Lisp_Object Qsubr;
Lisp_Object Qerror_conditions, Qerror_message, Qtop_level;
Lisp_Object Qerror, Quser_error, Qquit, Qargs_out_of_range;
+static Lisp_Object Qwrong_length_argument;
static Lisp_Object Qwrong_type_argument;
Lisp_Object Qvoid_variable, Qvoid_function;
static Lisp_Object Qcyclic_function_indirection;
@@ -54,6 +59,7 @@ 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 Qbool_vector_p;
Lisp_Object Qbuffer_or_string_p;
static Lisp_Object Qkeywordp, Qboundp;
Lisp_Object Qfboundp;
@@ -81,10 +87,11 @@ static Lisp_Object Qmany, Qunevalled;
Lisp_Object Qfont_spec, Qfont_entity, Qfont_object;
static Lisp_Object Qdefun;
+Lisp_Object Qspecial_operator;
Lisp_Object Qinteractive_form;
static Lisp_Object Qdefalias_fset_function;
-static void swap_in_symval_forwarding (struct Lisp_Symbol *, struct Lisp_Buffer_Local_Value *);
+static void swap_in_symval_forwarding (sym_t, struct Lisp_Buffer_Local_Value *);
static bool
BOOLFWDP (union Lisp_Fwd *a)
@@ -135,7 +142,7 @@ XOBJFWD (union Lisp_Fwd *a)
static void
CHECK_SUBR (Lisp_Object x)
{
- CHECK_TYPE (SUBRP (x), Qsubrp, x);
+ CHECK_TYPE (! NILP (Fsubrp (x)), Qsubrp, x);
}
static void
@@ -175,6 +182,18 @@ set_blv_valcell (struct Lisp_Buffer_Local_Value *blv, Lisp_Object val)
blv->valcell = val;
}
+static _Noreturn void
+wrong_length_argument (Lisp_Object a1, Lisp_Object a2, Lisp_Object a3)
+{
+ Lisp_Object size1 = make_number (bool_vector_size (a1));
+ Lisp_Object size2 = make_number (bool_vector_size (a2));
+ if (NILP (a3))
+ xsignal2 (Qwrong_length_argument, size1, size2);
+ else
+ xsignal3 (Qwrong_length_argument, size1, size2,
+ make_number (bool_vector_size (a3)));
+}
+
Lisp_Object
wrong_type_argument (register Lisp_Object predicate, register Lisp_Object value)
{
@@ -188,12 +207,6 @@ wrong_type_argument (register Lisp_Object predicate, register Lisp_Object value)
xsignal2 (Qwrong_type_argument, predicate, value);
}
-void
-pure_write_error (Lisp_Object obj)
-{
- xsignal2 (Qerror, build_string ("Attempt to modify read-only object"), obj);
-}
-
void
args_out_of_range (Lisp_Object a1, Lisp_Object a2)
{
@@ -233,21 +246,16 @@ The symbol returned names the object's basic type;
for example, (type-of 1) returns `integer'. */)
(Lisp_Object object)
{
- switch (XTYPE (object))
+ if (INTEGERP (object))
+ return Qinteger;
+ else if (SYMBOLP (object))
+ return Qsymbol;
+ else if (STRINGP (object))
+ return Qstring;
+ else if (CONSP (object))
+ return Qcons;
+ else if (MISCP (object))
{
- case_Lisp_Int:
- return Qinteger;
-
- case Lisp_Symbol:
- return Qsymbol;
-
- case Lisp_String:
- return Qstring;
-
- case Lisp_Cons:
- return Qcons;
-
- case Lisp_Misc:
switch (XMISCTYPE (object))
{
case Lisp_Misc_Marker:
@@ -258,16 +266,15 @@ for example, (type-of 1) returns `integer'. */)
return Qfloat;
}
emacs_abort ();
-
- case Lisp_Vectorlike:
+ }
+ else if (VECTORLIKEP (object))
+ {
if (WINDOW_CONFIGURATIONP (object))
return Qwindow_configuration;
if (PROCESSP (object))
return Qprocess;
if (WINDOWP (object))
return Qwindow;
- if (SUBRP (object))
- return Qsubr;
if (COMPILEDP (object))
return Qcompiled_function;
if (BUFFERP (object))
@@ -287,13 +294,13 @@ for example, (type-of 1) returns `integer'. */)
if (FONT_OBJECT_P (object))
return Qfont_object;
return Qvector;
-
- case Lisp_Float:
- return Qfloat;
-
- default:
- emacs_abort ();
}
+ else if (FLOATP (object))
+ return Qfloat;
+ else if (! NILP (Fsubrp (object)))
+ return Qsubr;
+ else
+ return Qt;
}
DEFUN ("consp", Fconsp, Sconsp, 1, 1, 0,
@@ -342,6 +349,15 @@ DEFUN ("symbolp", Fsymbolp, Ssymbolp, 1, 1, 0,
return Qnil;
}
+static bool
+SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (Lisp_Object sym)
+{
+ /* Should be initial_obarray */
+ Lisp_Object tem = Ffind_symbol (SYMBOL_NAME (sym), Vobarray);
+ return (! NILP (scm_c_value_ref (tem, 1))
+ && (EQ (sym, scm_c_value_ref (tem, 0))));
+}
+
/* Define this in C to avoid unnecessarily consing up the symbol
name. */
DEFUN ("keywordp", Fkeywordp, Skeywordp, 1, 1, 0,
@@ -454,7 +470,9 @@ DEFUN ("subrp", Fsubrp, Ssubrp, 1, 1, 0,
doc: /* Return t if OBJECT is a built-in function. */)
(Lisp_Object object)
{
- if (SUBRP (object))
+ if (CONSP (object) && EQ (XCAR (object), Qspecial_operator))
+ object = XCDR (object);
+ if (SCM_PRIMITIVE_P (object))
return Qt;
return Qnil;
}
@@ -602,12 +620,12 @@ global value outside of any lexical scope. */)
(register Lisp_Object symbol)
{
Lisp_Object valcontents;
- struct Lisp_Symbol *sym;
+ sym_t sym;
CHECK_SYMBOL (symbol);
sym = XSYMBOL (symbol);
start:
- switch (sym->redirect)
+ switch (SYMBOL_REDIRECT (sym))
{
case SYMBOL_PLAINVAL: valcontents = SYMBOL_VAL (sym); break;
case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
@@ -616,7 +634,7 @@ global value outside of any lexical scope. */)
struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym);
if (blv->fwd)
/* In set_internal, we un-forward vars when their value is
- set to Qunbound. */
+ set to Qunbound. */
return Qt;
else
{
@@ -627,7 +645,7 @@ global value outside of any lexical scope. */)
}
case SYMBOL_FORWARDED:
/* In set_internal, we un-forward vars when their value is
- set to Qunbound. */
+ set to Qunbound. */
return Qt;
default: emacs_abort ();
}
@@ -641,7 +659,7 @@ DEFUN ("fboundp", Ffboundp, Sfboundp, 1, 1, 0,
(register Lisp_Object symbol)
{
CHECK_SYMBOL (symbol);
- return NILP (XSYMBOL (symbol)->function) ? Qnil : Qt;
+ return NILP (SYMBOL_FUNCTION (symbol)) ? Qnil : Qt;
}
DEFUN ("makunbound", Fmakunbound, Smakunbound, 1, 1, 0,
@@ -669,11 +687,11 @@ Return SYMBOL. */)
}
DEFUN ("symbol-function", Fsymbol_function, Ssymbol_function, 1, 1, 0,
- doc: /* Return SYMBOL's function definition. Error if that is void. */)
+ doc: /* Return SYMBOL's function definition, or nil if that is void. */)
(register Lisp_Object symbol)
{
CHECK_SYMBOL (symbol);
- return XSYMBOL (symbol)->function;
+ return SYMBOL_FUNCTION (symbol);
}
DEFUN ("symbol-plist", Fsymbol_plist, Ssymbol_plist, 1, 1, 0,
@@ -681,7 +699,7 @@ DEFUN ("symbol-plist", Fsymbol_plist, Ssymbol_plist, 1, 1, 0,
(register Lisp_Object symbol)
{
CHECK_SYMBOL (symbol);
- return XSYMBOL (symbol)->plist;
+ return symbol_plist (symbol);
}
DEFUN ("symbol-name", Fsymbol_name, Ssymbol_name, 1, 1, 0,
@@ -702,7 +720,7 @@ DEFUN ("fset", Ffset, Sfset, 2, 2, 0,
register Lisp_Object function;
CHECK_SYMBOL (symbol);
- function = XSYMBOL (symbol)->function;
+ function = SYMBOL_FUNCTION (symbol);
if (!NILP (Vautoload_queue) && !NILP (function))
Vautoload_queue = Fcons (Fcons (symbol, function), Vautoload_queue);
@@ -710,6 +728,11 @@ DEFUN ("fset", Ffset, Sfset, 2, 2, 0,
if (AUTOLOADP (function))
Fput (symbol, Qautoload, XCDR (function));
+ /* Convert to eassert or remove after GC bug is found. In the
+ meantime, check unconditionally, at a slight perf hit. */
+ if (valid_lisp_object_p (definition) < 1)
+ emacs_abort ();
+
set_symbol_function (symbol, definition);
return definition;
@@ -721,6 +744,10 @@ 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.
+
+Internally, this normally uses `fset', but if SYMBOL has a
+`defalias-fset-function' property, the associated value is used instead.
+
The return value is undefined. */)
(register Lisp_Object symbol, Lisp_Object definition, Lisp_Object docstring)
{
@@ -736,7 +763,7 @@ The return value is undefined. */)
{ /* Only add autoload entries after dumping, because the ones before are
not useful and else we get loads of them from the loaddefs.el. */
- if (AUTOLOADP (XSYMBOL (symbol)->function))
+ if (AUTOLOADP (SYMBOL_FUNCTION (symbol)))
/* Remember that the function was already an autoload. */
LOADHIST_ATTACH (Fcons (Qt, symbol));
LOADHIST_ATTACH (Fcons (autoload ? Qautoload : Qdefun, symbol));
@@ -776,14 +803,27 @@ of args. MAX is the maximum number or the symbol `many', for a
function with `&rest' args, or `unevalled' for a special form. */)
(Lisp_Object subr)
{
- short minargs, maxargs;
+ Lisp_Object min, max;
+ Lisp_Object arity;
+ bool special = false;
+
CHECK_SUBR (subr);
- minargs = XSUBR (subr)->min_args;
- maxargs = XSUBR (subr)->max_args;
- return Fcons (make_number (minargs),
- maxargs == MANY ? Qmany
- : maxargs == UNEVALLED ? Qunevalled
- : make_number (maxargs));
+ if (CONSP (subr) && EQ (XCAR (subr), Qspecial_operator))
+ {
+ subr = XCDR (subr);
+ special = true;
+ }
+ arity = scm_procedure_minimum_arity (subr);
+ if (scm_is_false (arity))
+ return Qnil;
+ min = XCAR (arity);
+ if (special)
+ max = Qunevalled;
+ else if (scm_is_true (XCAR (XCDR (XCDR (arity)))))
+ max = Qmany;
+ else
+ max = scm_sum (min, XCAR (XCDR (arity)));
+ return Fcons (min, max);
}
DEFUN ("subr-name", Fsubr_name, Ssubr_name, 1, 1, 0,
@@ -791,10 +831,10 @@ DEFUN ("subr-name", Fsubr_name, Ssubr_name, 1, 1, 0,
SUBR must be a built-in function. */)
(Lisp_Object subr)
{
- const char *name;
CHECK_SUBR (subr);
- name = XSUBR (subr)->symbol_name;
- return build_string (name);
+ if (CONSP (subr) && EQ (XCAR (subr), Qspecial_operator))
+ subr = XCDR (subr);
+ return Fsymbol_name (SCM_SUBR_NAME (subr));
}
DEFUN ("interactive-form", Finteractive_form, Sinteractive_form, 1, 1, 0,
@@ -820,13 +860,11 @@ Value, if non-nil, is a list \(interactive SPEC). */)
fun = Fsymbol_function (fun);
}
- if (SUBRP (fun))
+ if (scm_is_true (scm_procedure_p (fun)))
{
- const char *spec = XSUBR (fun)->intspec;
- if (spec)
- return list2 (Qinteractive,
- (*spec != '(') ? build_string (spec) :
- Fcar (Fread_from_string (build_string (spec), Qnil, Qnil)));
+ Lisp_Object tem = scm_procedure_property (fun, Qinteractive_form);
+ if (scm_is_true (tem))
+ return list2 (Qinteractive, tem);
}
else if (COMPILEDP (fun))
{
@@ -855,17 +893,17 @@ Value, if non-nil, is a list \(interactive SPEC). */)
`cyclic-variable-indirection' if SYMBOL's chain of variable
indirections contains a loop. */
-struct Lisp_Symbol *
-indirect_variable (struct Lisp_Symbol *symbol)
+sym_t
+indirect_variable (sym_t symbol)
{
- struct Lisp_Symbol *tortoise, *hare;
+ sym_t tortoise, hare;
hare = tortoise = symbol;
- while (hare->redirect == SYMBOL_VARALIAS)
+ while (SYMBOL_REDIRECT (hare) == SYMBOL_VARALIAS)
{
hare = SYMBOL_ALIAS (hare);
- if (hare->redirect != SYMBOL_VARALIAS)
+ if (SYMBOL_REDIRECT (hare) != SYMBOL_VARALIAS)
break;
hare = SYMBOL_ALIAS (hare);
@@ -895,7 +933,7 @@ chain of aliases, signal a `cyclic-variable-indirection' error. */)
{
if (SYMBOLP (object))
{
- struct Lisp_Symbol *sym = indirect_variable (XSYMBOL (object));
+ sym_t sym = indirect_variable (XSYMBOL (object));
XSETSYMBOL (object, sym);
}
return object;
@@ -981,19 +1019,14 @@ store_symval_forwarding (union Lisp_Fwd *valcontents, register Lisp_Object newva
- (char *) &buffer_defaults);
int idx = PER_BUFFER_IDX (offset);
- Lisp_Object tail;
+ Lisp_Object tail, buf;
if (idx <= 0)
break;
- for (tail = Vbuffer_alist; CONSP (tail); tail = XCDR (tail))
+ FOR_EACH_LIVE_BUFFER (tail, buf)
{
- Lisp_Object lbuf;
- struct buffer *b;
-
- lbuf = Fcdr (XCAR (tail));
- if (!BUFFERP (lbuf)) continue;
- b = XBUFFER (lbuf);
+ struct buffer *b = XBUFFER (buf);
if (! PER_BUFFER_VALUE_P (b, idx))
set_per_buffer_value (b, offset, newval);
@@ -1035,7 +1068,7 @@ store_symval_forwarding (union Lisp_Fwd *valcontents, register Lisp_Object newva
of BLV are marked after this function has changed them. */
void
-swap_in_global_binding (struct Lisp_Symbol *symbol)
+swap_in_global_binding (sym_t symbol)
{
struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (symbol);
@@ -1061,7 +1094,7 @@ swap_in_global_binding (struct Lisp_Symbol *symbol)
This could be another forwarding pointer. */
static void
-swap_in_symval_forwarding (struct Lisp_Symbol *symbol, struct Lisp_Buffer_Local_Value *blv)
+swap_in_symval_forwarding (sym_t symbol, struct Lisp_Buffer_Local_Value *blv)
{
register Lisp_Object tem1;
@@ -1113,13 +1146,13 @@ swap_in_symval_forwarding (struct Lisp_Symbol *symbol, struct Lisp_Buffer_Local_
Lisp_Object
find_symbol_value (Lisp_Object symbol)
{
- struct Lisp_Symbol *sym;
+ sym_t sym;
CHECK_SYMBOL (symbol);
sym = XSYMBOL (symbol);
start:
- switch (sym->redirect)
+ switch (SYMBOL_REDIRECT (sym))
{
case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
case SYMBOL_PLAINVAL: return SYMBOL_VAL (sym);
@@ -1172,7 +1205,7 @@ set_internal (Lisp_Object symbol, Lisp_Object newval, Lisp_Object where,
bool bindflag)
{
bool voide = EQ (newval, Qunbound);
- struct Lisp_Symbol *sym;
+ sym_t sym;
Lisp_Object tem1;
/* If restoring in a dead buffer, do nothing. */
@@ -1193,7 +1226,7 @@ set_internal (Lisp_Object symbol, Lisp_Object newval, Lisp_Object where,
sym = XSYMBOL (symbol);
start:
- switch (sym->redirect)
+ switch (SYMBOL_REDIRECT (sym))
{
case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
case SYMBOL_PLAINVAL: SET_SYMBOL_VAL (sym , newval); return;
@@ -1303,7 +1336,7 @@ set_internal (Lisp_Object symbol, Lisp_Object newval, Lisp_Object where,
if (voide)
{ /* If storing void (making the symbol void), forward only through
buffer-local indicator, not through Lisp_Objfwd, etc. */
- sym->redirect = SYMBOL_PLAINVAL;
+ SET_SYMBOL_REDIRECT (sym, SYMBOL_PLAINVAL);
SET_SYMBOL_VAL (sym, newval);
}
else
@@ -1323,13 +1356,13 @@ set_internal (Lisp_Object symbol, Lisp_Object newval, Lisp_Object where,
static Lisp_Object
default_value (Lisp_Object symbol)
{
- struct Lisp_Symbol *sym;
+ sym_t sym;
CHECK_SYMBOL (symbol);
sym = XSYMBOL (symbol);
start:
- switch (sym->redirect)
+ switch (SYMBOL_REDIRECT (sym))
{
case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
case SYMBOL_PLAINVAL: return SYMBOL_VAL (sym);
@@ -1384,9 +1417,7 @@ for this variable. The default value is meaningful for variables with
local bindings in certain buffers. */)
(Lisp_Object symbol)
{
- register Lisp_Object value;
-
- value = default_value (symbol);
+ Lisp_Object value = default_value (symbol);
if (!EQ (value, Qunbound))
return value;
@@ -1399,7 +1430,7 @@ The default value is seen in buffers that do not have their own values
for this variable. */)
(Lisp_Object symbol, Lisp_Object value)
{
- struct Lisp_Symbol *sym;
+ sym_t sym;
CHECK_SYMBOL (symbol);
if (SYMBOL_CONSTANT_P (symbol))
@@ -1414,7 +1445,7 @@ for this variable. */)
sym = XSYMBOL (symbol);
start:
- switch (sym->redirect)
+ switch (SYMBOL_REDIRECT (sym))
{
case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
case SYMBOL_PLAINVAL: return Fset (symbol, value);
@@ -1478,24 +1509,19 @@ of previous VARs.
usage: (setq-default [VAR VALUE]...) */)
(Lisp_Object args)
{
- register Lisp_Object args_left;
- register Lisp_Object val, symbol;
+ Lisp_Object args_left, symbol, val;
struct gcpro gcpro1;
- if (NILP (args))
- return Qnil;
-
- args_left = args;
+ args_left = val = args;
GCPRO1 (args);
- do
+ while (CONSP (args_left))
{
- val = eval_sub (Fcar (Fcdr (args_left)));
+ val = eval_sub (Fcar (XCDR (args_left)));
symbol = XCAR (args_left);
Fset_default (symbol, val);
args_left = Fcdr (XCDR (args_left));
}
- while (!NILP (args_left));
UNGCPRO;
return val;
@@ -1510,7 +1536,7 @@ union Lisp_Val_Fwd
};
static struct Lisp_Buffer_Local_Value *
-make_blv (struct Lisp_Symbol *sym, bool forwarded,
+make_blv (sym_t sym, bool forwarded,
union Lisp_Val_Fwd valcontents)
{
struct Lisp_Buffer_Local_Value *blv = xmalloc (sizeof *blv);
@@ -1546,13 +1572,17 @@ Note that binding the variable with `let', or setting it while
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.
+This globally affects all uses of this variable, so it belongs together with
+the variable declaration, rather than with its uses (if you just want to make
+a variable local to the current buffer for one particular use, use
+`make-local-variable'). Buffer-local bindings are normally cleared
+while setting up a new major mode, unless they have a `permanent-local'
+property.
The function `default-value' gets the default value and `set-default' sets it. */)
(register Lisp_Object variable)
{
- struct Lisp_Symbol *sym;
+ sym_t sym;
struct Lisp_Buffer_Local_Value *blv = NULL;
union Lisp_Val_Fwd valcontents IF_LINT (= {LISP_INITIALLY_ZERO});
bool forwarded IF_LINT (= 0);
@@ -1561,7 +1591,7 @@ The function `default-value' gets the default value and `set-default' sets it.
sym = XSYMBOL (variable);
start:
- switch (sym->redirect)
+ switch (SYMBOL_REDIRECT (sym))
{
case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
case SYMBOL_PLAINVAL:
@@ -1586,13 +1616,13 @@ The function `default-value' gets the default value and `set-default' sets it.
default: emacs_abort ();
}
- if (sym->constant)
+ if (SYMBOL_CONSTANT (sym))
error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable)));
if (!blv)
{
blv = make_blv (sym, forwarded, valcontents);
- sym->redirect = SYMBOL_LOCALIZED;
+ SET_SYMBOL_REDIRECT (sym, SYMBOL_LOCALIZED);
SET_SYMBOL_BLV (sym, blv);
{
Lisp_Object symbol;
@@ -1632,14 +1662,14 @@ Instead, use `add-hook' and specify t for the LOCAL argument. */)
Lisp_Object tem;
bool forwarded IF_LINT (= 0);
union Lisp_Val_Fwd valcontents IF_LINT (= {LISP_INITIALLY_ZERO});
- struct Lisp_Symbol *sym;
+ sym_t sym;
struct Lisp_Buffer_Local_Value *blv = NULL;
CHECK_SYMBOL (variable);
sym = XSYMBOL (variable);
start:
- switch (sym->redirect)
+ switch (SYMBOL_REDIRECT (sym))
{
case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
case SYMBOL_PLAINVAL:
@@ -1659,7 +1689,7 @@ Instead, use `add-hook' and specify t for the LOCAL argument. */)
default: emacs_abort ();
}
- if (sym->constant)
+ if (SYMBOL_CONSTANT (sym))
error ("Symbol %s may not be buffer-local",
SDATA (SYMBOL_NAME (variable)));
@@ -1675,7 +1705,7 @@ Instead, use `add-hook' and specify t for the LOCAL argument. */)
if (!blv)
{
blv = make_blv (sym, forwarded, valcontents);
- sym->redirect = SYMBOL_LOCALIZED;
+ SET_SYMBOL_REDIRECT (sym, SYMBOL_LOCALIZED);
SET_SYMBOL_BLV (sym, blv);
{
Lisp_Object symbol;
@@ -1731,13 +1761,13 @@ From now on the default value will apply in this buffer. Return VARIABLE. */)
{
register Lisp_Object tem;
struct Lisp_Buffer_Local_Value *blv;
- struct Lisp_Symbol *sym;
+ sym_t sym;
CHECK_SYMBOL (variable);
sym = XSYMBOL (variable);
start:
- switch (sym->redirect)
+ switch (SYMBOL_REDIRECT (sym))
{
case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
case SYMBOL_PLAINVAL: return variable;
@@ -1818,14 +1848,14 @@ frame-local bindings). */)
{
bool forwarded;
union Lisp_Val_Fwd valcontents;
- struct Lisp_Symbol *sym;
+ sym_t sym;
struct Lisp_Buffer_Local_Value *blv = NULL;
CHECK_SYMBOL (variable);
sym = XSYMBOL (variable);
start:
- switch (sym->redirect)
+ switch (SYMBOL_REDIRECT (sym))
{
case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
case SYMBOL_PLAINVAL:
@@ -1848,12 +1878,12 @@ frame-local bindings). */)
default: emacs_abort ();
}
- if (sym->constant)
+ if (SYMBOL_CONSTANT (sym))
error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable)));
blv = make_blv (sym, forwarded, valcontents);
blv->frame_local = 1;
- sym->redirect = SYMBOL_LOCALIZED;
+ SET_SYMBOL_REDIRECT (sym, SYMBOL_LOCALIZED);
SET_SYMBOL_BLV (sym, blv);
{
Lisp_Object symbol;
@@ -1872,7 +1902,7 @@ BUFFER defaults to the current buffer. */)
(register Lisp_Object variable, Lisp_Object buffer)
{
register struct buffer *buf;
- struct Lisp_Symbol *sym;
+ sym_t sym;
if (NILP (buffer))
buf = current_buffer;
@@ -1886,7 +1916,7 @@ BUFFER defaults to the current buffer. */)
sym = XSYMBOL (variable);
start:
- switch (sym->redirect)
+ switch (SYMBOL_REDIRECT (sym))
{
case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
case SYMBOL_PLAINVAL: return Qnil;
@@ -1937,13 +1967,13 @@ 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;
+ sym_t sym;
CHECK_SYMBOL (variable);
sym = XSYMBOL (variable);
start:
- switch (sym->redirect)
+ switch (SYMBOL_REDIRECT (sym))
{
case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
case SYMBOL_PLAINVAL: return Qnil;
@@ -1970,7 +2000,7 @@ If the current binding is frame-local, the value is the selected frame.
If the current binding is global (the default), the value is nil. */)
(register Lisp_Object variable)
{
- struct Lisp_Symbol *sym;
+ sym_t sym;
CHECK_SYMBOL (variable);
sym = XSYMBOL (variable);
@@ -1979,7 +2009,7 @@ If the current binding is global (the default), the value is nil. */)
find_symbol_value (variable);
start:
- switch (sym->redirect)
+ switch (SYMBOL_REDIRECT (sym))
{
case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
case SYMBOL_PLAINVAL: return Qnil;
@@ -1987,7 +2017,7 @@ If the current binding is global (the default), the value is nil. */)
{
union Lisp_Fwd *valcontents = SYMBOL_FWD (sym);
if (KBOARD_OBJFWDP (valcontents))
- return Fframe_terminal (Fselected_frame ());
+ return Fframe_terminal (selected_frame);
else if (!BUFFER_OBJFWDP (valcontents))
return Qnil;
}
@@ -1997,7 +2027,7 @@ If the current binding is global (the default), the value is nil. */)
buffer's or frame's value we are saving. */
if (!NILP (Flocal_variable_p (variable, Qnil)))
return Fcurrent_buffer ();
- else if (sym->redirect == SYMBOL_LOCALIZED
+ else if (SYMBOL_REDIRECT (sym) == SYMBOL_LOCALIZED
&& blv_found (SYMBOL_BLV (sym)))
return SYMBOL_BLV (sym)->where;
else
@@ -2007,7 +2037,7 @@ If the current binding is global (the default), the value is nil. */)
}
/* This code is disabled now that we use the selected frame to return
- keyboard-local-values. */
+ keyboard-local-values. */
#if 0
extern struct terminal *get_terminal (Lisp_Object display, int);
@@ -2068,12 +2098,12 @@ indirect_function (register Lisp_Object object)
{
if (!SYMBOLP (hare) || NILP (hare))
break;
- hare = XSYMBOL (hare)->function;
+ hare = SYMBOL_FUNCTION (hare);
if (!SYMBOLP (hare) || NILP (hare))
break;
- hare = XSYMBOL (hare)->function;
+ hare = SYMBOL_FUNCTION (hare);
- tortoise = XSYMBOL (tortoise)->function;
+ tortoise = SYMBOL_FUNCTION (tortoise);
if (EQ (hare, tortoise))
xsignal1 (Qcyclic_function_indirection, object);
@@ -2097,7 +2127,7 @@ function chain of symbols. */)
/* Optimize for no indirection. */
result = object;
if (SYMBOLP (result) && !NILP (result)
- && (result = XSYMBOL (result)->function, SYMBOLP (result)))
+ && (result = SYMBOL_FUNCTION (result), SYMBOLP (result)))
result = indirect_function (result);
if (!NILP (result))
return result;
@@ -2136,13 +2166,9 @@ or a byte-code object. IDX starts at 0. */)
}
else if (BOOL_VECTOR_P (array))
{
- int val;
-
- if (idxval < 0 || idxval >= XBOOL_VECTOR (array)->size)
+ if (idxval < 0 || idxval >= bool_vector_size (array))
args_out_of_range (array, idx);
-
- val = (unsigned char) XBOOL_VECTOR (array)->data[idxval / BOOL_VECTOR_BITS_PER_CHAR];
- return (val & (1 << (idxval % BOOL_VECTOR_BITS_PER_CHAR)) ? Qt : Qnil);
+ return bool_vector_ref (array, idxval);
}
else if (CHAR_TABLE_P (array))
{
@@ -2186,18 +2212,9 @@ bool-vector. IDX starts at 0. */)
}
else if (BOOL_VECTOR_P (array))
{
- int val;
-
- if (idxval < 0 || idxval >= XBOOL_VECTOR (array)->size)
+ if (idxval < 0 || idxval >= bool_vector_size (array))
args_out_of_range (array, idx);
-
- val = (unsigned char) XBOOL_VECTOR (array)->data[idxval / BOOL_VECTOR_BITS_PER_CHAR];
-
- if (! NILP (newelt))
- val |= 1 << (idxval % BOOL_VECTOR_BITS_PER_CHAR);
- else
- val &= ~(1 << (idxval % BOOL_VECTOR_BITS_PER_CHAR));
- XBOOL_VECTOR (array)->data[idxval / BOOL_VECTOR_BITS_PER_CHAR] = val;
+ bool_vector_set (array, idxval, !NILP (newelt));
}
else if (CHAR_TABLE_P (array))
{
@@ -2267,10 +2284,8 @@ bool-vector. IDX starts at 0. */)
/* Arithmetic functions */
-enum comparison { equal, notequal, less, grtr, less_or_equal, grtr_or_equal };
-
-static Lisp_Object
-arithcompare (Lisp_Object num1, Lisp_Object num2, enum comparison comparison)
+Lisp_Object
+arithcompare (Lisp_Object num1, Lisp_Object num2, enum Arith_Comparison comparison)
{
double f1 = 0, f2 = 0;
bool floatp = 0;
@@ -2287,32 +2302,32 @@ arithcompare (Lisp_Object num1, Lisp_Object num2, enum comparison comparison)
switch (comparison)
{
- case equal:
+ case ARITH_EQUAL:
if (floatp ? f1 == f2 : XINT (num1) == XINT (num2))
return Qt;
return Qnil;
- case notequal:
+ case ARITH_NOTEQUAL:
if (floatp ? f1 != f2 : XINT (num1) != XINT (num2))
return Qt;
return Qnil;
- case less:
+ case ARITH_LESS:
if (floatp ? f1 < f2 : XINT (num1) < XINT (num2))
return Qt;
return Qnil;
- case less_or_equal:
+ case ARITH_LESS_OR_EQUAL:
if (floatp ? f1 <= f2 : XINT (num1) <= XINT (num2))
return Qt;
return Qnil;
- case grtr:
+ case ARITH_GRTR:
if (floatp ? f1 > f2 : XINT (num1) > XINT (num2))
return Qt;
return Qnil;
- case grtr_or_equal:
+ case ARITH_GRTR_OR_EQUAL:
if (floatp ? f1 >= f2 : XINT (num1) >= XINT (num2))
return Qt;
return Qnil;
@@ -2322,66 +2337,64 @@ arithcompare (Lisp_Object num1, Lisp_Object num2, enum comparison comparison)
}
}
-DEFUN ("=", Feqlsign, Seqlsign, 2, 2, 0,
- doc: /* Return t if two args, both numbers or markers, are equal. */)
- (register Lisp_Object num1, Lisp_Object num2)
+static Lisp_Object
+arithcompare_driver (ptrdiff_t nargs, Lisp_Object *args,
+ enum Arith_Comparison comparison)
{
- return arithcompare (num1, num2, equal);
+ ptrdiff_t argnum;
+ for (argnum = 1; argnum < nargs; ++argnum)
+ {
+ if (EQ (Qnil, arithcompare (args[argnum - 1], args[argnum], comparison)))
+ return Qnil;
+ }
+ return Qt;
}
-DEFUN ("<", Flss, Slss, 2, 2, 0,
- doc: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
- (register Lisp_Object num1, Lisp_Object num2)
+DEFUN ("=", Feqlsign, Seqlsign, 1, MANY, 0,
+ doc: /* Return t if args, all numbers or markers, are equal.
+usage: (= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
+ (ptrdiff_t nargs, Lisp_Object *args)
{
- return arithcompare (num1, num2, less);
+ return arithcompare_driver (nargs, args, ARITH_EQUAL);
}
-DEFUN (">", Fgtr, Sgtr, 2, 2, 0,
- doc: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
- (register Lisp_Object num1, Lisp_Object num2)
+DEFUN ("<", Flss, Slss, 1, MANY, 0,
+ doc: /* Return t if each arg (a number or marker), is less than the next arg.
+usage: (< NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
+ (ptrdiff_t nargs, Lisp_Object *args)
{
- return arithcompare (num1, num2, grtr);
+ return arithcompare_driver (nargs, args, ARITH_LESS);
}
-DEFUN ("<=", Fleq, Sleq, 2, 2, 0,
- doc: /* Return t if first arg is less than or equal to second arg.
-Both must be numbers or markers. */)
- (register Lisp_Object num1, Lisp_Object num2)
+DEFUN (">", Fgtr, Sgtr, 1, MANY, 0,
+ doc: /* Return t if each arg (a number or marker) is greater than the next arg.
+usage: (> NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
+ (ptrdiff_t nargs, Lisp_Object *args)
{
- return arithcompare (num1, num2, less_or_equal);
+ return arithcompare_driver (nargs, args, ARITH_GRTR);
}
-DEFUN (">=", Fgeq, Sgeq, 2, 2, 0,
- doc: /* Return t if first arg is greater than or equal to second arg.
-Both must be numbers or markers. */)
- (register Lisp_Object num1, Lisp_Object num2)
+DEFUN ("<=", Fleq, Sleq, 1, MANY, 0,
+ doc: /* Return t if each arg (a number or marker) is less than or equal to the next.
+usage: (<= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
+ (ptrdiff_t nargs, Lisp_Object *args)
{
- return arithcompare (num1, num2, grtr_or_equal);
+ return arithcompare_driver (nargs, args, ARITH_LESS_OR_EQUAL);
}
-DEFUN ("/=", Fneq, Sneq, 2, 2, 0,
- doc: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
- (register Lisp_Object num1, Lisp_Object num2)
+DEFUN (">=", Fgeq, Sgeq, 1, MANY, 0,
+ doc: /* Return t if each arg (a number or marker) is greater than or equal to the next.
+usage: (>= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
+ (ptrdiff_t nargs, Lisp_Object *args)
{
- return arithcompare (num1, num2, notequal);
+ return arithcompare_driver (nargs, args, ARITH_GRTR_OR_EQUAL);
}
-DEFUN ("zerop", Fzerop, Szerop, 1, 1, 0,
- doc: /* Return t if NUMBER is zero. */)
- (register Lisp_Object number)
+DEFUN ("/=", Fneq, Sneq, 2, 2, 0,
+ doc: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
+ (register Lisp_Object num1, Lisp_Object num2)
{
- CHECK_NUMBER_OR_FLOAT (number);
-
- if (FLOATP (number))
- {
- if (XFLOAT_DATA (number) == 0.0)
- return Qt;
- return Qnil;
- }
-
- if (!XINT (number))
- return Qt;
- return Qnil;
+ return arithcompare (num1, num2, ARITH_NOTEQUAL);
}
/* Convert the cons-of-integers, integer, or float value C to an
@@ -2511,12 +2524,12 @@ NUMBER may be an integer or a floating point number. */)
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.
-It ignores leading spaces and tabs, and all trailing chars.
+Ignore leading spaces and tabs, and all trailing chars. Return 0 if
+STRING cannot be parsed as an integer or floating point number.
If BASE, interpret STRING as a number in that base. If BASE isn't
present, base 10 is used. BASE must be between 2 and 16 (inclusive).
-If the base used is not 10, STRING is always parsed as integer. */)
+If the base used is not 10, STRING is always parsed as an integer. */)
(register Lisp_Object string, Lisp_Object base)
{
register char *p;
@@ -2874,7 +2887,7 @@ In this case, the sign bit is duplicated. */)
if (XINT (count) >= BITS_PER_EMACS_INT)
XSETINT (val, 0);
else if (XINT (count) > 0)
- XSETINT (val, XINT (value) << XFASTINT (count));
+ XSETINT (val, XUINT (value) << XFASTINT (count));
else if (XINT (count) <= -BITS_PER_EMACS_INT)
XSETINT (val, XINT (value) < 0 ? -1 : 0);
else
@@ -2953,6 +2966,434 @@ lowercase l) for small endian machines. */)
return make_number (order);
}
+/* Because we round up the bool vector allocate size to word_size
+ units, we can safely read past the "end" of the vector in the
+ operations below. These extra bits are always zero. */
+
+static bits_word
+bool_vector_spare_mask (EMACS_INT nr_bits)
+{
+ return (((bits_word) 1) << (nr_bits % BITS_PER_BITS_WORD)) - 1;
+}
+
+/* Info about unsigned long long, falling back on unsigned long
+ if unsigned long long is not available. */
+
+#if HAVE_UNSIGNED_LONG_LONG_INT && defined ULLONG_MAX
+enum { BITS_PER_ULL = CHAR_BIT * sizeof (unsigned long long) };
+# define ULL_MAX ULLONG_MAX
+#else
+enum { BITS_PER_ULL = CHAR_BIT * sizeof (unsigned long) };
+# define ULL_MAX ULONG_MAX
+# define count_one_bits_ll count_one_bits_l
+# define count_trailing_zeros_ll count_trailing_zeros_l
+#endif
+
+/* Shift VAL right by the width of an unsigned long long.
+ BITS_PER_ULL must be less than BITS_PER_BITS_WORD. */
+
+static bits_word
+shift_right_ull (bits_word w)
+{
+ /* Pacify bogus GCC warning about shift count exceeding type width. */
+ int shift = BITS_PER_ULL - BITS_PER_BITS_WORD < 0 ? BITS_PER_ULL : 0;
+ return w >> shift;
+}
+
+/* Return the number of 1 bits in W. */
+
+static int
+count_one_bits_word (bits_word w)
+{
+ if (BITS_WORD_MAX <= UINT_MAX)
+ return count_one_bits (w);
+ else if (BITS_WORD_MAX <= ULONG_MAX)
+ return count_one_bits_l (w);
+ else
+ {
+ int i = 0, count = 0;
+ while (count += count_one_bits_ll (w),
+ (i += BITS_PER_ULL) < BITS_PER_BITS_WORD)
+ w = shift_right_ull (w);
+ return count;
+ }
+}
+
+enum bool_vector_op { bool_vector_exclusive_or,
+ bool_vector_union,
+ bool_vector_intersection,
+ bool_vector_set_difference,
+ bool_vector_subsetp };
+
+static Lisp_Object
+bool_vector_binop_driver (Lisp_Object a,
+ Lisp_Object b,
+ Lisp_Object dest,
+ enum bool_vector_op op)
+{
+ EMACS_INT nr_bits;
+ bits_word *adata, *bdata, *destdata;
+ ptrdiff_t i = 0;
+ ptrdiff_t nr_words;
+
+ CHECK_BOOL_VECTOR (a);
+ CHECK_BOOL_VECTOR (b);
+
+ nr_bits = bool_vector_size (a);
+ if (bool_vector_size (b) != nr_bits)
+ wrong_length_argument (a, b, dest);
+
+ nr_words = bool_vector_words (nr_bits);
+ adata = bool_vector_data (a);
+ bdata = bool_vector_data (b);
+
+ if (NILP (dest))
+ {
+ dest = make_uninit_bool_vector (nr_bits);
+ destdata = bool_vector_data (dest);
+ }
+ else
+ {
+ CHECK_BOOL_VECTOR (dest);
+ destdata = bool_vector_data (dest);
+ if (bool_vector_size (dest) != nr_bits)
+ wrong_length_argument (a, b, dest);
+
+ switch (op)
+ {
+ case bool_vector_exclusive_or:
+ for (; i < nr_words; i++)
+ if (destdata[i] != (adata[i] ^ bdata[i]))
+ goto set_dest;
+ break;
+
+ case bool_vector_subsetp:
+ for (; i < nr_words; i++)
+ if (adata[i] &~ bdata[i])
+ return Qnil;
+ return Qt;
+
+ case bool_vector_union:
+ for (; i < nr_words; i++)
+ if (destdata[i] != (adata[i] | bdata[i]))
+ goto set_dest;
+ break;
+
+ case bool_vector_intersection:
+ for (; i < nr_words; i++)
+ if (destdata[i] != (adata[i] & bdata[i]))
+ goto set_dest;
+ break;
+
+ case bool_vector_set_difference:
+ for (; i < nr_words; i++)
+ if (destdata[i] != (adata[i] &~ bdata[i]))
+ goto set_dest;
+ break;
+ }
+
+ return Qnil;
+ }
+
+ set_dest:
+ switch (op)
+ {
+ case bool_vector_exclusive_or:
+ for (; i < nr_words; i++)
+ destdata[i] = adata[i] ^ bdata[i];
+ break;
+
+ case bool_vector_union:
+ for (; i < nr_words; i++)
+ destdata[i] = adata[i] | bdata[i];
+ break;
+
+ case bool_vector_intersection:
+ for (; i < nr_words; i++)
+ destdata[i] = adata[i] & bdata[i];
+ break;
+
+ case bool_vector_set_difference:
+ for (; i < nr_words; i++)
+ destdata[i] = adata[i] &~ bdata[i];
+ break;
+
+ default:
+ eassume (0);
+ }
+
+ return dest;
+}
+
+/* PRECONDITION must be true. Return VALUE. This odd construction
+ works around a bogus GCC diagnostic "shift count >= width of type". */
+
+static int
+pre_value (bool precondition, int value)
+{
+ eassume (precondition);
+ return precondition ? value : 0;
+}
+
+/* Compute the number of trailing zero bits in val. If val is zero,
+ return the number of bits in val. */
+static int
+count_trailing_zero_bits (bits_word val)
+{
+ if (BITS_WORD_MAX == UINT_MAX)
+ return count_trailing_zeros (val);
+ if (BITS_WORD_MAX == ULONG_MAX)
+ return count_trailing_zeros_l (val);
+ if (BITS_WORD_MAX == ULL_MAX)
+ return count_trailing_zeros_ll (val);
+
+ /* The rest of this code is for the unlikely platform where bits_word differs
+ in width from unsigned int, unsigned long, and unsigned long long. */
+ val |= ~ BITS_WORD_MAX;
+ if (BITS_WORD_MAX <= UINT_MAX)
+ return count_trailing_zeros (val);
+ if (BITS_WORD_MAX <= ULONG_MAX)
+ return count_trailing_zeros_l (val);
+ else
+ {
+ int count;
+ for (count = 0;
+ count < BITS_PER_BITS_WORD - BITS_PER_ULL;
+ count += BITS_PER_ULL)
+ {
+ if (val & ULL_MAX)
+ return count + count_trailing_zeros_ll (val);
+ val = shift_right_ull (val);
+ }
+
+ if (BITS_PER_BITS_WORD % BITS_PER_ULL != 0
+ && BITS_WORD_MAX == (bits_word) -1)
+ val |= (bits_word) 1 << pre_value (ULONG_MAX < BITS_WORD_MAX,
+ BITS_PER_BITS_WORD % BITS_PER_ULL);
+ return count + count_trailing_zeros_ll (val);
+ }
+}
+
+static bits_word
+bits_word_to_host_endian (bits_word val)
+{
+#ifndef WORDS_BIGENDIAN
+ return val;
+#else
+ if (BITS_WORD_MAX >> 31 == 1)
+ return bswap_32 (val);
+# if HAVE_UNSIGNED_LONG_LONG
+ if (BITS_WORD_MAX >> 31 >> 31 >> 1 == 1)
+ return bswap_64 (val);
+# endif
+ {
+ int i;
+ bits_word r = 0;
+ for (i = 0; i < sizeof val; i++)
+ {
+ r = ((r << 1 << (CHAR_BIT - 1))
+ | (val & ((1u << 1 << (CHAR_BIT - 1)) - 1)));
+ val = val >> 1 >> (CHAR_BIT - 1);
+ }
+ return r;
+ }
+#endif
+}
+
+DEFUN ("bool-vector-exclusive-or", Fbool_vector_exclusive_or,
+ Sbool_vector_exclusive_or, 2, 3, 0,
+ doc: /* Return A ^ B, bitwise exclusive or.
+If optional third argument C is given, store result into C.
+A, B, and C must be bool vectors of the same length.
+Return the destination vector if it changed or nil otherwise. */)
+ (Lisp_Object a, Lisp_Object b, Lisp_Object c)
+{
+ return bool_vector_binop_driver (a, b, c, bool_vector_exclusive_or);
+}
+
+DEFUN ("bool-vector-union", Fbool_vector_union,
+ Sbool_vector_union, 2, 3, 0,
+ doc: /* Return A | B, bitwise or.
+If optional third argument C is given, store result into C.
+A, B, and C must be bool vectors of the same length.
+Return the destination vector if it changed or nil otherwise. */)
+ (Lisp_Object a, Lisp_Object b, Lisp_Object c)
+{
+ return bool_vector_binop_driver (a, b, c, bool_vector_union);
+}
+
+DEFUN ("bool-vector-intersection", Fbool_vector_intersection,
+ Sbool_vector_intersection, 2, 3, 0,
+ doc: /* Return A & B, bitwise and.
+If optional third argument C is given, store result into C.
+A, B, and C must be bool vectors of the same length.
+Return the destination vector if it changed or nil otherwise. */)
+ (Lisp_Object a, Lisp_Object b, Lisp_Object c)
+{
+ return bool_vector_binop_driver (a, b, c, bool_vector_intersection);
+}
+
+DEFUN ("bool-vector-set-difference", Fbool_vector_set_difference,
+ Sbool_vector_set_difference, 2, 3, 0,
+ doc: /* Return A &~ B, set difference.
+If optional third argument C is given, store result into C.
+A, B, and C must be bool vectors of the same length.
+Return the destination vector if it changed or nil otherwise. */)
+ (Lisp_Object a, Lisp_Object b, Lisp_Object c)
+{
+ return bool_vector_binop_driver (a, b, c, bool_vector_set_difference);
+}
+
+DEFUN ("bool-vector-subsetp", Fbool_vector_subsetp,
+ Sbool_vector_subsetp, 2, 2, 0,
+ doc: /* Return t if every t value in A is also t in B, nil otherwise.
+A and B must be bool vectors of the same length. */)
+ (Lisp_Object a, Lisp_Object b)
+{
+ return bool_vector_binop_driver (a, b, b, bool_vector_subsetp);
+}
+
+DEFUN ("bool-vector-not", Fbool_vector_not,
+ Sbool_vector_not, 1, 2, 0,
+ doc: /* Compute ~A, set complement.
+If optional second argument B is given, store result into B.
+A and B must be bool vectors of the same length.
+Return the destination vector. */)
+ (Lisp_Object a, Lisp_Object b)
+{
+ EMACS_INT nr_bits;
+ bits_word *bdata, *adata;
+ ptrdiff_t i;
+
+ CHECK_BOOL_VECTOR (a);
+ nr_bits = bool_vector_size (a);
+
+ if (NILP (b))
+ b = make_uninit_bool_vector (nr_bits);
+ else
+ {
+ CHECK_BOOL_VECTOR (b);
+ if (bool_vector_size (b) != nr_bits)
+ wrong_length_argument (a, b, Qnil);
+ }
+
+ bdata = bool_vector_data (b);
+ adata = bool_vector_data (a);
+
+ for (i = 0; i < nr_bits / BITS_PER_BITS_WORD; i++)
+ bdata[i] = BITS_WORD_MAX & ~adata[i];
+
+ if (nr_bits % BITS_PER_BITS_WORD)
+ {
+ bits_word mword = bits_word_to_host_endian (adata[i]);
+ mword = ~mword;
+ mword &= bool_vector_spare_mask (nr_bits);
+ bdata[i] = bits_word_to_host_endian (mword);
+ }
+
+ return b;
+}
+
+DEFUN ("bool-vector-count-population", Fbool_vector_count_population,
+ Sbool_vector_count_population, 1, 1, 0,
+ doc: /* Count how many elements in A are t.
+A is a bool vector. To count A's nil elements, subtract the return
+value from A's length. */)
+ (Lisp_Object a)
+{
+ EMACS_INT count;
+ EMACS_INT nr_bits;
+ bits_word *adata;
+ ptrdiff_t i, nwords;
+
+ CHECK_BOOL_VECTOR (a);
+
+ nr_bits = bool_vector_size (a);
+ nwords = bool_vector_words (nr_bits);
+ count = 0;
+ adata = bool_vector_data (a);
+
+ for (i = 0; i < nwords; i++)
+ count += count_one_bits_word (adata[i]);
+
+ return make_number (count);
+}
+
+DEFUN ("bool-vector-count-consecutive", Fbool_vector_count_consecutive,
+ Sbool_vector_count_consecutive, 3, 3, 0,
+ doc: /* Count how many consecutive elements in A equal B starting at I.
+A is a bool vector, B is t or nil, and I is an index into A. */)
+ (Lisp_Object a, Lisp_Object b, Lisp_Object i)
+{
+ EMACS_INT count;
+ EMACS_INT nr_bits;
+ int offset;
+ bits_word *adata;
+ bits_word twiddle;
+ bits_word mword; /* Machine word. */
+ ptrdiff_t pos, pos0;
+ ptrdiff_t nr_words;
+
+ CHECK_BOOL_VECTOR (a);
+ CHECK_NATNUM (i);
+
+ nr_bits = bool_vector_size (a);
+ if (XFASTINT (i) > nr_bits) /* Allow one past the end for convenience */
+ args_out_of_range (a, i);
+
+ adata = bool_vector_data (a);
+ nr_words = bool_vector_words (nr_bits);
+ pos = XFASTINT (i) / BITS_PER_BITS_WORD;
+ offset = XFASTINT (i) % BITS_PER_BITS_WORD;
+ count = 0;
+
+ /* By XORing with twiddle, we transform the problem of "count
+ consecutive equal values" into "count the zero bits". The latter
+ operation usually has hardware support. */
+ twiddle = NILP (b) ? 0 : BITS_WORD_MAX;
+
+ /* Scan the remainder of the mword at the current offset. */
+ if (pos < nr_words && offset != 0)
+ {
+ mword = bits_word_to_host_endian (adata[pos]);
+ mword ^= twiddle;
+ mword >>= offset;
+
+ /* Do not count the pad bits. */
+ mword |= (bits_word) 1 << (BITS_PER_BITS_WORD - offset);
+
+ count = count_trailing_zero_bits (mword);
+ pos++;
+ if (count + offset < BITS_PER_BITS_WORD)
+ return make_number (count);
+ }
+
+ /* Scan whole words until we either reach the end of the vector or
+ find an mword that doesn't completely match. twiddle is
+ endian-independent. */
+ pos0 = pos;
+ while (pos < nr_words && adata[pos] == twiddle)
+ pos++;
+ count += (pos - pos0) * BITS_PER_BITS_WORD;
+
+ if (pos < nr_words)
+ {
+ /* If we stopped because of a mismatch, see how many bits match
+ in the current mword. */
+ mword = bits_word_to_host_endian (adata[pos]);
+ mword ^= twiddle;
+ count += count_trailing_zero_bits (mword);
+ }
+ else if (nr_bits % BITS_PER_BITS_WORD != 0)
+ {
+ /* If we hit the end, we might have overshot our count. Reduce
+ the total by the number of spare bits at the end of the
+ vector. */
+ count -= BITS_PER_BITS_WORD - nr_bits % BITS_PER_BITS_WORD;
+ }
+
+ return make_number (count);
+}
void
@@ -2960,6 +3401,12 @@ syms_of_data (void)
{
Lisp_Object error_tail, arith_tail;
+ /* Used by defsubr. */
+ DEFSYM (Qspecial_operator, "special-operator");
+ DEFSYM (Qinteractive_form, "interactive-form");
+
+#include "data.x"
+
DEFSYM (Qquote, "quote");
DEFSYM (Qlambda, "lambda");
DEFSYM (Qsubr, "subr");
@@ -2970,6 +3417,7 @@ syms_of_data (void)
DEFSYM (Qerror, "error");
DEFSYM (Quser_error, "user-error");
DEFSYM (Qquit, "quit");
+ DEFSYM (Qwrong_length_argument, "wrong-length-argument");
DEFSYM (Qwrong_type_argument, "wrong-type-argument");
DEFSYM (Qargs_out_of_range, "args-out-of-range");
DEFSYM (Qvoid_function, "void-function");
@@ -3002,6 +3450,7 @@ syms_of_data (void)
DEFSYM (Qsequencep, "sequencep");
DEFSYM (Qbufferp, "bufferp");
DEFSYM (Qvectorp, "vectorp");
+ DEFSYM (Qbool_vector_p, "bool-vector-p");
DEFSYM (Qchar_or_string_p, "char-or-string-p");
DEFSYM (Qmarkerp, "markerp");
DEFSYM (Qbuffer_or_string_p, "buffer-or-string-p");
@@ -3043,6 +3492,7 @@ syms_of_data (void)
PUT_ERROR (Qquit, Qnil, "Quit");
PUT_ERROR (Quser_error, error_tail, "");
+ PUT_ERROR (Qwrong_length_argument, error_tail, "Wrong length argument");
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,
@@ -3121,113 +3571,17 @@ syms_of_data (void)
DEFSYM (Qfont_entity, "font-entity");
DEFSYM (Qfont_object, "font-object");
- DEFSYM (Qinteractive_form, "interactive-form");
DEFSYM (Qdefalias_fset_function, "defalias-fset-function");
- defsubr (&Sindirect_variable);
- defsubr (&Sinteractive_form);
- defsubr (&Seq);
- defsubr (&Snull);
- defsubr (&Stype_of);
- defsubr (&Slistp);
- defsubr (&Snlistp);
- defsubr (&Sconsp);
- defsubr (&Satom);
- defsubr (&Sintegerp);
- defsubr (&Sinteger_or_marker_p);
- defsubr (&Snumberp);
- defsubr (&Snumber_or_marker_p);
- defsubr (&Sfloatp);
- defsubr (&Snatnump);
- defsubr (&Ssymbolp);
- defsubr (&Skeywordp);
- defsubr (&Sstringp);
- defsubr (&Smultibyte_string_p);
- defsubr (&Svectorp);
- defsubr (&Schar_table_p);
- defsubr (&Svector_or_char_table_p);
- defsubr (&Sbool_vector_p);
- defsubr (&Sarrayp);
- defsubr (&Ssequencep);
- defsubr (&Sbufferp);
- defsubr (&Smarkerp);
- defsubr (&Ssubrp);
- defsubr (&Sbyte_code_function_p);
- defsubr (&Schar_or_string_p);
- defsubr (&Scar);
- defsubr (&Scdr);
- defsubr (&Scar_safe);
- defsubr (&Scdr_safe);
- defsubr (&Ssetcar);
- defsubr (&Ssetcdr);
- defsubr (&Ssymbol_function);
- defsubr (&Sindirect_function);
- defsubr (&Ssymbol_plist);
- defsubr (&Ssymbol_name);
- defsubr (&Smakunbound);
- defsubr (&Sfmakunbound);
- defsubr (&Sboundp);
- defsubr (&Sfboundp);
- defsubr (&Sfset);
- defsubr (&Sdefalias);
- defsubr (&Ssetplist);
- defsubr (&Ssymbol_value);
- defsubr (&Sset);
- defsubr (&Sdefault_boundp);
- defsubr (&Sdefault_value);
- defsubr (&Sset_default);
- defsubr (&Ssetq_default);
- defsubr (&Smake_variable_buffer_local);
- defsubr (&Smake_local_variable);
- defsubr (&Skill_local_variable);
- defsubr (&Smake_variable_frame_local);
- defsubr (&Slocal_variable_p);
- defsubr (&Slocal_variable_if_set_p);
- defsubr (&Svariable_binding_locus);
-#if 0 /* XXX Remove this. --lorentey */
- defsubr (&Sterminal_local_value);
- defsubr (&Sset_terminal_local_value);
-#endif
- defsubr (&Saref);
- defsubr (&Saset);
- defsubr (&Snumber_to_string);
- defsubr (&Sstring_to_number);
- defsubr (&Seqlsign);
- defsubr (&Slss);
- defsubr (&Sgtr);
- defsubr (&Sleq);
- defsubr (&Sgeq);
- defsubr (&Sneq);
- defsubr (&Szerop);
- defsubr (&Splus);
- defsubr (&Sminus);
- defsubr (&Stimes);
- defsubr (&Squo);
- defsubr (&Srem);
- defsubr (&Smod);
- defsubr (&Smax);
- defsubr (&Smin);
- defsubr (&Slogand);
- defsubr (&Slogior);
- defsubr (&Slogxor);
- defsubr (&Slsh);
- defsubr (&Sash);
- defsubr (&Sadd1);
- defsubr (&Ssub1);
- defsubr (&Slognot);
- defsubr (&Sbyteorder);
- defsubr (&Ssubr_arity);
- defsubr (&Ssubr_name);
-
- set_symbol_function (Qwholenump, XSYMBOL (Qnatnump)->function);
+ set_symbol_function (Qwholenump, SYMBOL_FUNCTION (Qnatnump));
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;
+ SET_SYMBOL_CONSTANT (XSYMBOL (intern_c_string ("most-positive-fixnum")), 1);
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;
+ SET_SYMBOL_CONSTANT (XSYMBOL (intern_c_string ("most-negative-fixnum")), 1);
}