/* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
- Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2012
- Free Software Foundation, Inc.
+ Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2013 Free Software
+ Foundation, Inc.
This file is part of GNU Emacs.
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;
static Lisp_Object Qcompiled_function, Qframe;
Lisp_Object Qbuffer;
static Lisp_Object Qchar_table, Qbool_vector, Qhash_table;
-static Lisp_Object Qsubrp, Qmany, Qunevalled;
+static Lisp_Object Qsubrp;
+static Lisp_Object Qmany, Qunevalled;
Lisp_Object Qfont_spec, Qfont_entity, Qfont_object;
static Lisp_Object Qdefun;
static void swap_in_symval_forwarding (struct Lisp_Symbol *, struct Lisp_Buffer_Local_Value *);
+static bool
+BOOLFWDP (union Lisp_Fwd *a)
+{
+ return XFWDTYPE (a) == Lisp_Fwd_Bool;
+}
+static bool
+INTFWDP (union Lisp_Fwd *a)
+{
+ return XFWDTYPE (a) == Lisp_Fwd_Int;
+}
+static bool
+KBOARD_OBJFWDP (union Lisp_Fwd *a)
+{
+ return XFWDTYPE (a) == Lisp_Fwd_Kboard_Obj;
+}
+static bool
+OBJFWDP (union Lisp_Fwd *a)
+{
+ return XFWDTYPE (a) == Lisp_Fwd_Obj;
+}
+
+static struct Lisp_Boolfwd *
+XBOOLFWD (union Lisp_Fwd *a)
+{
+ eassert (BOOLFWDP (a));
+ return &a->u_boolfwd;
+}
+static struct Lisp_Kboard_Objfwd *
+XKBOARD_OBJFWD (union Lisp_Fwd *a)
+{
+ eassert (KBOARD_OBJFWDP (a));
+ return &a->u_kboard_objfwd;
+}
+static struct Lisp_Intfwd *
+XINTFWD (union Lisp_Fwd *a)
+{
+ eassert (INTFWDP (a));
+ return &a->u_intfwd;
+}
+static struct Lisp_Objfwd *
+XOBJFWD (union Lisp_Fwd *a)
+{
+ eassert (OBJFWDP (a));
+ return &a->u_objfwd;
+}
+
+static void
+CHECK_SUBR (Lisp_Object x)
+{
+ CHECK_TYPE (SUBRP (x), Qsubrp, x);
+}
+
+static void
+set_blv_found (struct Lisp_Buffer_Local_Value *blv, int found)
+{
+ eassert (found == !EQ (blv->defcell, blv->valcell));
+ blv->found = found;
+}
+
+static Lisp_Object
+blv_value (struct Lisp_Buffer_Local_Value *blv)
+{
+ return XCDR (blv->valcell);
+}
+
+static void
+set_blv_value (struct Lisp_Buffer_Local_Value *blv, Lisp_Object val)
+{
+ XSETCDR (blv->valcell, val);
+}
+
+static void
+set_blv_where (struct Lisp_Buffer_Local_Value *blv, Lisp_Object val)
+{
+ blv->where = val;
+}
+
+static void
+set_blv_defcell (struct Lisp_Buffer_Local_Value *blv, Lisp_Object val)
+{
+ blv->defcell = val;
+}
+
+static void
+set_blv_valcell (struct Lisp_Buffer_Local_Value *blv, Lisp_Object val)
+{
+ blv->valcell = val;
+}
Lisp_Object
wrong_type_argument (register Lisp_Object predicate, register Lisp_Object value)
}
void
-pure_write_error (void)
+pure_write_error (Lisp_Object obj)
{
- error ("Attempt to modify read-only object");
+ xsignal2 (Qerror, build_string ("Attempt to modify read-only object"), obj);
}
void
DEFUN ("multibyte-string-p", Fmultibyte_string_p, Smultibyte_string_p,
1, 1, 0,
- doc: /* Return t if OBJECT is a multibyte string. */)
+ doc: /* Return t if OBJECT is a multibyte string.
+Return nil if OBJECT is either a unibyte string, or not a string. */)
(Lisp_Object object)
{
if (STRINGP (object) && STRING_MULTIBYTE (object))
/* Extract and set components of symbols. */
DEFUN ("boundp", Fboundp, Sboundp, 1, 1, 0,
- doc: /* Return t if SYMBOL's value is not void. */)
+ doc: /* Return t if SYMBOL's value is not void.
+Note that if `lexical-binding' is in effect, this refers to the
+global value outside of any lexical scope. */)
(register Lisp_Object symbol)
{
Lisp_Object valcontents;
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
{
}
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 ();
}
(register Lisp_Object symbol)
{
CHECK_SYMBOL (symbol);
- return XSYMBOL (symbol)->function;
+ return XSYMBOL (symbol)->function;
}
DEFUN ("symbol-plist", Fsymbol_plist, Ssymbol_plist, 1, 1, 0,
- (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);
case Lisp_Fwd_Buffer_Obj:
{
int offset = XBUFFER_OBJFWD (valcontents)->offset;
- Lisp_Object type = XBUFFER_OBJFWD (valcontents)->slottype;
+ Lisp_Object predicate = XBUFFER_OBJFWD (valcontents)->predicate;
- if (!(NILP (type) || NILP (newval)
- || (XINT (type) == Lisp_Int0
- ? INTEGERP (newval)
- : XTYPE (newval) == XINT (type))))
- buffer_slot_type_mismatch (newval, XINT (type));
+ if (!NILP (predicate) && !NILP (newval)
+ && NILP (call1 (predicate, newval)))
+ wrong_type_argument (predicate, newval);
if (buf == NULL)
buf = current_buffer;
}
DEFUN ("symbol-value", Fsymbol_value, Ssymbol_value, 1, 1, 0,
- doc: /* Return SYMBOL's value. Error if that is void. */)
+ doc: /* Return SYMBOL's value. Error if that is void.
+Note that if `lexical-binding' is in effect, this returns the
+global value outside of any lexical scope. */)
(Lisp_Object symbol)
{
Lisp_Object val;
return newval;
}
-/* Return true if SYMBOL currently has a let-binding
- which was made in the buffer that is now current. */
-
-static bool
-let_shadows_buffer_binding_p (struct Lisp_Symbol *symbol)
-{
- struct specbinding *p;
-
- 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)
- return 1;
- }
-
- return 0;
-}
-
-static bool
-let_shadows_global_binding_p (Lisp_Object symbol)
-{
- struct specbinding *p;
-
- for (p = specpdl_ptr; p > specpdl; )
- if ((--p)->func == NULL && EQ (p->symbol, symbol))
- return 1;
-
- 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).
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;
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;
XSETBUFFER (tmp, buf);
XSETSYMBOL (variable, sym); /* Update in case of aliasing. */
- for (tail = BVAR (buf, local_var_alist); CONSP (tail); tail = XCDR (tail))
- {
- elt = XCAR (tail);
- if (EQ (variable, XCAR (elt)))
- {
- eassert (!blv->frame_local);
- eassert (blv_found (blv) || !EQ (blv->where, tmp));
- return Qt;
- }
- }
- eassert (!blv_found (blv) || !EQ (blv->where, tmp));
+ if (EQ (blv->where, tmp)) /* The binding is already loaded. */
+ return blv_found (blv) ? Qt : Qnil;
+ else
+ for (tail = BVAR (buf, local_var_alist); CONSP (tail); tail = XCDR (tail))
+ {
+ elt = XCAR (tail);
+ if (EQ (variable, XCAR (elt)))
+ {
+ eassert (!blv->frame_local);
+ return Qt;
+ }
+ }
return Qnil;
}
case SYMBOL_FORWARDED:
{
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;
}
}
/* 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);
\f
/* 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;
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;
}
}
-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);
+ for (ptrdiff_t 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 is less than the next arg. All must be numbers or markers.
+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 is greater than the next arg. All must be numbers or markers.
+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 is less than or equal to the next arg.
+All must be numbers or markers.
+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 (">=", Fgeq, Sgeq, 1, MANY, 0,
+ doc: /* Return t if each arg is greater than or equal to the next arg.
+All must be numbers or markers.
+usage: (= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
+ (ptrdiff_t nargs, Lisp_Object *args)
+{
+ return arithcompare_driver (nargs, args, ARITH_GRTR_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)
{
- return arithcompare (num1, num2, notequal);
+ return arithcompare (num1, num2, ARITH_NOTEQUAL);
}
DEFUN ("zerop", Fzerop, Szerop, 1, 1, 0,
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. Also, we
+ always allocate bool vectors with at least one size_t of storage so
+ that we don't have to special-case empty bit vectors. */
+
+static size_t
+bool_vector_spare_mask (ptrdiff_t nr_bits)
+{
+ eassert (nr_bits > 0);
+ return (((size_t) 1) << (nr_bits % BITS_PER_SIZE_T)) - 1;
+}
+
+#if _MSC_VER >= 1500 && (defined _M_IX86 || defined _M_X64)
+# define USE_MSC_POPCOUNT
+# define POPCOUNT_STATIC_INLINE static inline
+#elif __GNUC__ > 3 || (__GNUC__ == 3 && __GNUC_MINOR__ >= 4)
+# define USE_GCC_POPCOUNT
+# if 199901L <= __STDC_VERSION__ || !__STRICT_ANSI__
+# define POPCOUNT_STATIC_INLINE static inline
+# endif
+#else
+# define NEED_GENERIC_POPCOUNT
+#endif
+#ifndef POPCOUNT_STATIC_INLINE
+# define POPCOUNT_STATIC_INLINE static
+#endif
+
+#ifdef USE_MSC_POPCOUNT
+# define NEED_GENERIC_POPCOUNT
+#endif
+
+#ifdef NEED_GENERIC_POPCOUNT
+POPCOUNT_STATIC_INLINE unsigned int
+popcount_size_t_generic (size_t val)
+{
+ unsigned short j;
+ unsigned int count = 0;
+
+ for (j = 0; j < BITS_PER_SIZE_T; ++j)
+ count += !!((((size_t) 1) << j) & val);
+
+ return count;
+}
+#endif
+
+#ifdef USE_MSC_POPCOUNT
+POPCOUNT_STATIC_INLINE unsigned int
+popcount_size_t_msc (size_t val)
+{
+ unsigned int count;
+
+#pragma intrinsic __cpuid
+ /* While gcc falls back to its own generic code if the machine on
+ which it's running doesn't support popcount, we need to perform the
+ detection and fallback ourselves when compiling with Microsoft's
+ compiler. */
+
+ static enum {
+ popcount_unknown_support,
+ popcount_use_generic,
+ popcount_use_intrinsic
+ } popcount_state;
+
+ if (popcount_state == popcount_unknown_support)
+ {
+ int cpu_info[4];
+ __cpuid (cpu_info, 1);
+ if (cpu_info[2] & (1<<23)) /* See MSDN. */
+ popcount_state = popcount_use_intrinsic;
+ else
+ popcount_state = popcount_use_generic;
+ }
+
+ if (popcount_state == popcount_use_intrinsic)
+ {
+# if BITS_PER_SIZE_T == 64
+# pragma intrinsic __popcnt64
+ count = __popcnt64 (val);
+# else
+# pragma intrinsic __popcnt
+ count = __popcnt (val);
+# endif
+ }
+ else
+ count = popcount_size_t_generic (val);
+
+ return count;
+}
+#endif /* USE_MSC_POPCOUNT */
+
+#ifdef USE_GCC_POPCOUNT
+POPCOUNT_STATIC_INLINE unsigned int
+popcount_size_t_gcc (size_t val)
+{
+# if BITS_PER_SIZE_T == 64
+ return __builtin_popcountll (val);
+# else
+ return __builtin_popcount (val);
+# endif
+}
+#endif /* USE_GCC_POPCOUNT */
+
+POPCOUNT_STATIC_INLINE unsigned int
+popcount_size_t (size_t val)
+{
+#if defined USE_MSC_POPCOUNT
+ return popcount_size_t_msc (val);
+#elif defined USE_GCC_POPCOUNT
+ return popcount_size_t_gcc (val);
+#else
+ return popcount_size_t_generic (val);
+#endif
+}
+
+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 op1,
+ Lisp_Object op2,
+ Lisp_Object dest,
+ enum bool_vector_op op)
+{
+ EMACS_INT nr_bits;
+ size_t *adata, *bdata, *cdata;
+ ptrdiff_t i;
+ size_t changed = 0;
+ size_t mword;
+ ptrdiff_t nr_words;
+
+ CHECK_BOOL_VECTOR (op1);
+ CHECK_BOOL_VECTOR (op2);
+
+ nr_bits = min (XBOOL_VECTOR (op1)->size,
+ XBOOL_VECTOR (op2)->size);
+
+ if (NILP (dest))
+ {
+ dest = Fmake_bool_vector (make_number (nr_bits), Qnil);
+ changed = 1;
+ }
+ else
+ {
+ CHECK_BOOL_VECTOR (dest);
+ nr_bits = min (nr_bits, XBOOL_VECTOR (dest)->size);
+ }
+
+ eassert (nr_bits >= 0);
+ nr_words = ROUNDUP (nr_bits, BITS_PER_SIZE_T) / BITS_PER_SIZE_T;
+
+ adata = (size_t *) XBOOL_VECTOR (dest)->data;
+ bdata = (size_t *) XBOOL_VECTOR (op1)->data;
+ cdata = (size_t *) XBOOL_VECTOR (op2)->data;
+ i = 0;
+ do
+ {
+ if (op == bool_vector_exclusive_or)
+ mword = bdata[i] ^ cdata[i];
+ else if (op == bool_vector_union || op == bool_vector_subsetp)
+ mword = bdata[i] | cdata[i];
+ else if (op == bool_vector_intersection)
+ mword = bdata[i] & cdata[i];
+ else if (op == bool_vector_set_difference)
+ mword = bdata[i] &~ cdata[i];
+ else
+ abort ();
+
+ changed |= adata[i] ^ mword;
+
+ if (op != bool_vector_subsetp)
+ adata[i] = mword;
+
+ i++;
+ }
+ while (i < nr_words);
+
+ return changed ? dest : Qnil;
+}
+
+/* Compute the number of trailing zero bits in val. If val is zero,
+ return the number of bits in val. */
+static unsigned int
+count_trailing_zero_bits (size_t val)
+{
+ if (val == 0)
+ return CHAR_BIT * sizeof (val);
+
+#if defined USE_GCC_POPCOUNT && BITS_PER_SIZE_T == 64
+ return __builtin_ctzll (val);
+#elif defined USE_GCC_POPCOUNT && BITS_PER_SIZE_T == 32
+ return __builtin_ctz (val);
+#elif _MSC_VER && BITS_PER_SIZE_T == 64
+# pragma intrinsic _BitScanForward64
+ {
+ /* No support test needed: support since 386. */
+ unsigned long result;
+ _BitScanForward64 (&result, val);
+ return (unsigned int) result;
+ }
+#elif _MSC_VER && BITS_PER_SIZE_T == 32
+# pragma intrinsic _BitScanForward
+ {
+ /* No support test needed: support since 386. */
+ unsigned long result;
+ _BitScanForward (&result, val);
+ return (unsigned int) result;
+ }
+#else
+ {
+ unsigned int count;
+ count = 0;
+ for (val = ~val; val & 1; val >>= 1)
+ ++count;
+
+ return count;
+ }
+#endif
+}
+
+static size_t
+size_t_to_host_endian (size_t val)
+{
+#ifdef WORDS_BIGENDIAN
+# if BITS_PER_SIZE_T == 64
+ return swap64 (val);
+# else
+ return swap32 (val);
+# endif
+#else
+ return val;
+#endif
+}
+
+DEFUN ("bool-vector-exclusive-or", Fbool_vector_exclusive_or,
+ Sbool_vector_exclusive_or, 2, 3, 0,
+ doc: /* Compute C = A ^ B, bitwise exclusive or.
+A, B, and C must be bool vectors. If C is nil, allocate a new bool
+vector in which to store the result. 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: /* Compute C = A | B, bitwise or.
+A, B, and C must be bool vectors. If C is nil, allocate a new bool
+vector in which to store the result. 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: /* Compute C = A & B, bitwise and.
+A, B, and C must be bool vectors. If C is nil, allocate a new bool
+vector in which to store the result. 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: /* Compute C = A &~ B, set difference.
+A, B, and C must be bool vectors. If C is nil, allocate a new bool
+vector in which to store the result. 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: )
+ (Lisp_Object a, Lisp_Object b)
+{
+ /* Like bool_vector_union, but doesn't modify b. */
+ return bool_vector_binop_driver (b, a, b, bool_vector_subsetp);
+}
+
+DEFUN ("bool-vector-not", Fbool_vector_not,
+ Sbool_vector_not, 1, 2, 0,
+ doc: /* Compute B = ~A.
+B must be a bool vector. A must be a bool vector or nil.
+If A is nil, allocate a new bool vector in which to store the result.
+Return the destination vector. */)
+ (Lisp_Object a, Lisp_Object b)
+{
+ EMACS_INT nr_bits;
+ size_t *bdata, *adata;
+ ptrdiff_t i;
+ size_t mword;
+
+ CHECK_BOOL_VECTOR (a);
+ nr_bits = XBOOL_VECTOR (a)->size;
+
+ if (NILP (b))
+ b = Fmake_bool_vector (make_number (nr_bits), Qnil);
+ else
+ {
+ CHECK_BOOL_VECTOR (b);
+ nr_bits = min (nr_bits, XBOOL_VECTOR (b)->size);
+ }
+
+ bdata = (size_t *) XBOOL_VECTOR (b)->data;
+ adata = (size_t *) XBOOL_VECTOR (a)->data;
+
+ eassert (nr_bits >= 0);
+
+ for (i = 0; i < nr_bits / BITS_PER_SIZE_T; i++)
+ bdata[i] = ~adata[i];
+
+ if (nr_bits % BITS_PER_SIZE_T)
+ {
+ mword = size_t_to_host_endian (adata[i]);
+ mword = ~mword;
+ mword &= bool_vector_spare_mask (nr_bits);
+ bdata[i] = size_t_to_host_endian (mword);
+ }
+
+ return b;
+}
+
+DEFUN ("bool-vector-count-matches", Fbool_vector_count_matches,
+ Sbool_vector_count_matches, 2, 2, 0,
+ doc: /* Count how many elements in A equal B.
+A must be a bool vector. B is a generalized bool. */)
+ (Lisp_Object a, Lisp_Object b)
+{
+ ptrdiff_t count;
+ EMACS_INT nr_bits;
+ size_t *adata;
+ size_t match;
+ ptrdiff_t i;
+
+ CHECK_BOOL_VECTOR (a);
+
+ nr_bits = XBOOL_VECTOR (a)->size;
+ count = 0;
+ match = NILP (b) ? (size_t) -1 : 0;
+ adata = (size_t *) XBOOL_VECTOR (a)->data;
+
+ eassert (nr_bits >= 0);
+
+ for (i = 0; i < nr_bits / BITS_PER_SIZE_T; ++i)
+ count += popcount_size_t (adata[i] ^ match);
+
+ /* Mask out trailing parts of final mword. */
+ if (nr_bits % BITS_PER_SIZE_T)
+ {
+ size_t mword = adata[i] ^ match;
+ mword = size_t_to_host_endian (mword);
+ count += popcount_size_t (mword & bool_vector_spare_mask (nr_bits));
+ }
+
+ return make_number (count);
+}
+
+DEFUN ("bool-vector-count-matches-at",
+ Fbool_vector_count_matches_at,
+ Sbool_vector_count_matches_at, 3, 3, 0,
+ doc: /* Count how many consecutive elements in A equal B at i.
+A must be a bool vector. B is a generalized boolean. i is an
+index into the vector. */)
+ (Lisp_Object a, Lisp_Object b, Lisp_Object i)
+{
+ ptrdiff_t count;
+ EMACS_INT nr_bits;
+ ptrdiff_t offset;
+ size_t *adata;
+ size_t twiddle;
+ size_t mword; /* Machine word. */
+ ptrdiff_t pos;
+ ptrdiff_t nr_words;
+
+ CHECK_BOOL_VECTOR (a);
+ CHECK_NATNUM (i);
+
+ nr_bits = XBOOL_VECTOR (a)->size;
+ if (XFASTINT (i) > nr_bits) /* Allow one past the end for convenience */
+ args_out_of_range (a, i);
+
+ adata = (size_t *) XBOOL_VECTOR (a)->data;
+
+ assume (nr_bits >= 0);
+ nr_words = ROUNDUP (nr_bits, BITS_PER_SIZE_T) / BITS_PER_SIZE_T;
+
+ pos = XFASTINT (i) / BITS_PER_SIZE_T;
+ offset = XFASTINT (i) % BITS_PER_SIZE_T;
+ 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 : (size_t) -1;
+
+ /* Scan the remainder of the mword at the current offset. */
+ if (pos < nr_words && offset != 0)
+ {
+ mword = size_t_to_host_endian (adata[pos]);
+ mword ^= twiddle;
+ mword >>= offset;
+ count = count_trailing_zero_bits (mword);
+ count = min (count, BITS_PER_SIZE_T - offset);
+ pos++;
+ if (count + offset < BITS_PER_SIZE_T)
+ 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. */
+ while (pos < nr_words && adata[pos] == twiddle)
+ {
+ count += BITS_PER_SIZE_T;
+ ++pos;
+ }
+
+ if (pos < nr_words)
+ {
+ /* If we stopped because of a mismatch, see how many bits match
+ in the current mword. */
+ mword = size_t_to_host_endian (adata[pos]);
+ mword ^= twiddle;
+ count += count_trailing_zero_bits (mword);
+ }
+ else if (nr_bits % BITS_PER_SIZE_T != 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_SIZE_T - nr_bits % BITS_PER_SIZE_T;
+ }
+
+ return make_number (count);
+}
\f
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");
defsubr (&Ssubr_arity);
defsubr (&Ssubr_name);
+ defsubr (&Sbool_vector_exclusive_or);
+ defsubr (&Sbool_vector_union);
+ defsubr (&Sbool_vector_intersection);
+ defsubr (&Sbool_vector_set_difference);
+ defsubr (&Sbool_vector_not);
+ defsubr (&Sbool_vector_subsetp);
+ defsubr (&Sbool_vector_count_matches);
+ defsubr (&Sbool_vector_count_matches_at);
+
set_symbol_function (Qwholenump, XSYMBOL (Qnatnump)->function);
DEFVAR_LISP ("most-positive-fixnum", Vmost_positive_fixnum,
HCoop / bpt / emacs.git / blobdiff