X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/87d86601022feb7a330fc6344cc85ec65563c1b6..8142fc97af742e083fb83e4d0470da59b123a467:/src/data.c diff --git a/src/data.c b/src/data.c index b8b0f248df..c96841aebb 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-2015 Free Software Foundation, Inc. This file is part of GNU Emacs. @@ -37,59 +37,8 @@ along with GNU Emacs. If not, see . */ #include "font.h" #include "keymap.h" -Lisp_Object Qnil, Qt, Qquote, Qlambda, Qunbound; -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; -static Lisp_Object Qcyclic_variable_indirection; -Lisp_Object Qcircular_list; -static Lisp_Object Qsetting_constant; -Lisp_Object Qinvalid_read_syntax; -Lisp_Object Qinvalid_function, Qwrong_number_of_arguments, Qno_catch; -Lisp_Object Qend_of_file, Qarith_error, Qmark_inactive; -Lisp_Object Qbeginning_of_buffer, Qend_of_buffer, Qbuffer_read_only; -Lisp_Object Qtext_read_only; - -Lisp_Object Qintegerp, 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; -Lisp_Object Qchar_table_p, Qvector_or_char_table_p; - -Lisp_Object Qcdr; -static Lisp_Object Qad_advice_info, Qad_activate_internal; - -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, Qsymbol; -static Lisp_Object Qcons, Qfloat, Qmisc, Qstring, Qvector; -Lisp_Object Qwindow; -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; -static Lisp_Object Qmany, Qunevalled; -Lisp_Object Qfont_spec, Qfont_entity, Qfont_object; -static Lisp_Object Qdefun; - -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 (struct Lisp_Symbol *, + struct Lisp_Buffer_Local_Value *); static bool BOOLFWDP (union Lisp_Fwd *a) @@ -227,7 +176,8 @@ args_out_of_range_3 (Lisp_Object a1, Lisp_Object a2, Lisp_Object a3) /* Data type predicates. */ DEFUN ("eq", Feq, Seq, 2, 2, 0, - doc: /* Return t if the two args are the same Lisp object. */) + doc: /* Return t if the two args are the same Lisp object. */ + attributes: const) (Lisp_Object obj1, Lisp_Object obj2) { if (EQ (obj1, obj2)) @@ -236,7 +186,8 @@ DEFUN ("eq", Feq, Seq, 2, 2, 0, } DEFUN ("null", Fnull, Snull, 1, 1, 0, - doc: /* Return t if OBJECT is nil. */) + doc: /* Return t if OBJECT is nil. */ + attributes: const) (Lisp_Object object) { if (NILP (object)) @@ -272,7 +223,9 @@ for example, (type-of 1) returns `integer'. */) case Lisp_Misc_Overlay: return Qoverlay; case Lisp_Misc_Float: - return Qfloat; + return Qfloat; + case Lisp_Misc_Finalizer: + return Qfinalizer; } emacs_abort (); @@ -314,7 +267,8 @@ for example, (type-of 1) returns `integer'. */) } DEFUN ("consp", Fconsp, Sconsp, 1, 1, 0, - doc: /* Return t if OBJECT is a cons cell. */) + doc: /* Return t if OBJECT is a cons cell. */ + attributes: const) (Lisp_Object object) { if (CONSP (object)) @@ -323,7 +277,8 @@ DEFUN ("consp", Fconsp, Sconsp, 1, 1, 0, } DEFUN ("atom", Fatom, Satom, 1, 1, 0, - doc: /* Return t if OBJECT is not a cons cell. This includes nil. */) + doc: /* Return t if OBJECT is not a cons cell. This includes nil. */ + attributes: const) (Lisp_Object object) { if (CONSP (object)) @@ -333,7 +288,8 @@ DEFUN ("atom", Fatom, Satom, 1, 1, 0, DEFUN ("listp", Flistp, Slistp, 1, 1, 0, doc: /* Return t if OBJECT is a list, that is, a cons cell or nil. -Otherwise, return nil. */) +Otherwise, return nil. */ + attributes: const) (Lisp_Object object) { if (CONSP (object) || NILP (object)) @@ -342,7 +298,8 @@ Otherwise, return nil. */) } DEFUN ("nlistp", Fnlistp, Snlistp, 1, 1, 0, - doc: /* Return t if OBJECT is not a list. Lists include nil. */) + doc: /* Return t if OBJECT is not a list. Lists include nil. */ + attributes: const) (Lisp_Object object) { if (CONSP (object) || NILP (object)) @@ -351,7 +308,8 @@ DEFUN ("nlistp", Fnlistp, Snlistp, 1, 1, 0, } DEFUN ("symbolp", Fsymbolp, Ssymbolp, 1, 1, 0, - doc: /* Return t if OBJECT is a symbol. */) + doc: /* Return t if OBJECT is a symbol. */ + attributes: const) (Lisp_Object object) { if (SYMBOLP (object)) @@ -384,7 +342,8 @@ DEFUN ("vectorp", Fvectorp, Svectorp, 1, 1, 0, } DEFUN ("stringp", Fstringp, Sstringp, 1, 1, 0, - doc: /* Return t if OBJECT is a string. */) + doc: /* Return t if OBJECT is a string. */ + attributes: const) (Lisp_Object object) { if (STRINGP (object)) @@ -487,7 +446,8 @@ DEFUN ("byte-code-function-p", Fbyte_code_function_p, Sbyte_code_function_p, } DEFUN ("char-or-string-p", Fchar_or_string_p, Schar_or_string_p, 1, 1, 0, - doc: /* Return t if OBJECT is a character or a string. */) + doc: /* Return t if OBJECT is a character or a string. */ + attributes: const) (register Lisp_Object object) { if (CHARACTERP (object) || STRINGP (object)) @@ -496,7 +456,8 @@ DEFUN ("char-or-string-p", Fchar_or_string_p, Schar_or_string_p, 1, 1, 0, } DEFUN ("integerp", Fintegerp, Sintegerp, 1, 1, 0, - doc: /* Return t if OBJECT is an integer. */) + doc: /* Return t if OBJECT is an integer. */ + attributes: const) (Lisp_Object object) { if (INTEGERP (object)) @@ -514,7 +475,8 @@ DEFUN ("integer-or-marker-p", Finteger_or_marker_p, Sinteger_or_marker_p, 1, 1, } DEFUN ("natnump", Fnatnump, Snatnump, 1, 1, 0, - doc: /* Return t if OBJECT is a nonnegative integer. */) + doc: /* Return t if OBJECT is a nonnegative integer. */ + attributes: const) (Lisp_Object object) { if (NATNUMP (object)) @@ -523,7 +485,8 @@ DEFUN ("natnump", Fnatnump, Snatnump, 1, 1, 0, } DEFUN ("numberp", Fnumberp, Snumberp, 1, 1, 0, - doc: /* Return t if OBJECT is a number (floating point or integer). */) + doc: /* Return t if OBJECT is a number (floating point or integer). */ + attributes: const) (Lisp_Object object) { if (NUMBERP (object)) @@ -543,7 +506,8 @@ DEFUN ("number-or-marker-p", Fnumber_or_marker_p, } DEFUN ("floatp", Ffloatp, Sfloatp, 1, 1, 0, - doc: /* Return t if OBJECT is a floating point number. */) + doc: /* Return t if OBJECT is a floating point number. */ + attributes: const) (Lisp_Object object) { if (FLOATP (object)) @@ -686,7 +650,7 @@ 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); @@ -727,6 +691,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)) + emacs_abort (); + set_symbol_function (symbol, definition); return definition; @@ -738,6 +707,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) { @@ -962,6 +935,50 @@ do_symval_forwarding (register union Lisp_Fwd *valcontents) } } +/* Used to signal a user-friendly error when symbol WRONG is + not a member of CHOICE, which should be a list of symbols. */ + +void +wrong_choice (Lisp_Object choice, Lisp_Object wrong) +{ + ptrdiff_t i = 0, len = XINT (Flength (choice)); + Lisp_Object obj, *args; + AUTO_STRING (one_of, "One of "); + AUTO_STRING (comma, ", "); + AUTO_STRING (or, " or "); + AUTO_STRING (should_be_specified, " should be specified"); + + USE_SAFE_ALLOCA; + SAFE_ALLOCA_LISP (args, len * 2 + 1); + + args[i++] = one_of; + + for (obj = choice; !NILP (obj); obj = XCDR (obj)) + { + args[i++] = SYMBOL_NAME (XCAR (obj)); + args[i++] = (NILP (XCDR (obj)) ? should_be_specified + : NILP (XCDR (XCDR (obj))) ? or : comma); + } + + obj = Fconcat (i, args); + SAFE_FREE (); + xsignal2 (Qerror, obj, wrong); +} + +/* Used to signal a user-friendly error if WRONG is not a number or + integer/floating-point number outsize of inclusive MIN..MAX range. */ + +static void +wrong_range (Lisp_Object min, Lisp_Object max, Lisp_Object wrong) +{ + AUTO_STRING (value_should_be_from, "Value should be from "); + AUTO_STRING (to, " to "); + xsignal2 (Qerror, + CALLN (Fconcat, value_should_be_from, Fnumber_to_string (min), + to, Fnumber_to_string (max)), + wrong); +} + /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the buffer-independent contents of the value cell: forwarded just one @@ -1018,10 +1035,33 @@ store_symval_forwarding (union Lisp_Fwd *valcontents, register Lisp_Object newva int offset = XBUFFER_OBJFWD (valcontents)->offset; Lisp_Object predicate = XBUFFER_OBJFWD (valcontents)->predicate; - if (!NILP (predicate) && !NILP (newval) - && NILP (call1 (predicate, newval))) - wrong_type_argument (predicate, newval); + if (!NILP (newval)) + { + if (SYMBOLP (predicate)) + { + Lisp_Object prop; + if ((prop = Fget (predicate, Qchoice), !NILP (prop))) + { + if (NILP (Fmemq (newval, prop))) + wrong_choice (prop, newval); + } + else if ((prop = Fget (predicate, Qrange), !NILP (prop))) + { + Lisp_Object min = XCAR (prop), max = XCDR (prop); + + if (!NUMBERP (newval) + || !NILP (arithcompare (newval, min, ARITH_LESS)) + || !NILP (arithcompare (newval, max, ARITH_GRTR))) + wrong_range (min, max, newval); + } + else if (FUNCTIONP (predicate)) + { + if (NILP (call1 (predicate, newval))) + wrong_type_argument (predicate, newval); + } + } + } if (buf == NULL) buf = current_buffer; set_per_buffer_value (buf, offset, newval); @@ -1237,10 +1277,10 @@ set_internal (Lisp_Object symbol, Lisp_Object newval, Lisp_Object where, /* Find the new binding. */ XSETSYMBOL (symbol, sym); /* May have changed via aliasing. */ - tem1 = Fassq (symbol, - (blv->frame_local - ? XFRAME (where)->param_alist - : BVAR (XBUFFER (where), local_var_alist))); + tem1 = assq_no_quit (symbol, + (blv->frame_local + ? XFRAME (where)->param_alist + : BVAR (XBUFFER (where), local_var_alist))); set_blv_where (blv, where); blv->found = 1; @@ -1551,8 +1591,12 @@ 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) @@ -1874,19 +1918,11 @@ DEFUN ("local-variable-p", Flocal_variable_p, Slocal_variable_p, 1, 2, 0, doc: /* Non-nil if VARIABLE has a local binding in buffer BUFFER. BUFFER defaults to the current buffer. */) - (register Lisp_Object variable, Lisp_Object buffer) + (Lisp_Object variable, Lisp_Object buffer) { - register struct buffer *buf; + struct buffer *buf = decode_buffer (buffer); struct Lisp_Symbol *sym; - if (NILP (buffer)) - buf = current_buffer; - else - { - CHECK_BUFFER (buffer); - buf = XBUFFER (buffer); - } - CHECK_SYMBOL (variable); sym = XSYMBOL (variable); @@ -2091,8 +2127,6 @@ DEFUN ("indirect-function", Findirect_function, Sindirect_function, 1, 2, 0, doc: /* Return the function at the end of OBJECT's function chain. If OBJECT is not a symbol, just return it. Otherwise, follow all function indirections to find the final function binding and return it. -If the final symbol in the chain is unbound, signal a void-function error. -Optional arg NOERROR non-nil means to return nil instead of signaling. Signal a cyclic-function-indirection error if there is a loop in the function chain of symbols. */) (register Lisp_Object object, Lisp_Object noerror) @@ -2107,9 +2141,6 @@ function chain of symbols. */) if (!NILP (result)) return result; - if (NILP (noerror)) - xsignal1 (Qvoid_function, object); - return Qnil; } @@ -2240,7 +2271,7 @@ bool-vector. IDX starts at 0. */) { if (! SINGLE_BYTE_CHAR_P (c)) { - int i; + ptrdiff_t i; for (i = SBYTES (array) - 1; i >= 0; i--) if (SREF (array, i) >= 0x80) @@ -2316,9 +2347,10 @@ static Lisp_Object arithcompare_driver (ptrdiff_t nargs, Lisp_Object *args, enum Arith_Comparison comparison) { - for (ptrdiff_t argnum = 1; argnum < nargs; ++argnum) + ptrdiff_t argnum; + for (argnum = 1; argnum < nargs; ++argnum) { - if (EQ (Qnil, arithcompare (args[argnum-1], args[argnum], comparison))) + if (EQ (Qnil, arithcompare (args[argnum - 1], args[argnum], comparison))) return Qnil; } return Qt; @@ -2333,7 +2365,7 @@ usage: (= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */) } DEFUN ("<", Flss, Slss, 1, MANY, 0, - doc: /* Return t if each arg is less than the next arg. All must be numbers or markers. + 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) { @@ -2341,7 +2373,7 @@ usage: (< NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */) } DEFUN (">", Fgtr, Sgtr, 1, MANY, 0, - doc: /* Return t if each arg is greater than the next arg. All must be numbers or markers. + 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) { @@ -2349,8 +2381,7 @@ usage: (> NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */) } 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. + 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) { @@ -2358,9 +2389,8 @@ usage: (<= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */) } 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) */) + 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_driver (nargs, args, ARITH_GRTR_OR_EQUAL); @@ -2372,24 +2402,6 @@ DEFUN ("/=", Fneq, Sneq, 2, 2, 0, { return arithcompare (num1, num2, ARITH_NOTEQUAL); } - -DEFUN ("zerop", Fzerop, Szerop, 1, 1, 0, - doc: /* Return t if NUMBER is zero. */) - (register Lisp_Object number) -{ - 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; -} /* Convert the cons-of-integers, integer, or float value C to an unsigned value with maximum value MAX. Signal an error if C does not @@ -2518,12 +2530,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; @@ -2881,7 +2893,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 @@ -2951,7 +2963,8 @@ DEFUN ("lognot", Flognot, Slognot, 1, 1, 0, DEFUN ("byteorder", Fbyteorder, Sbyteorder, 0, 0, 0, doc: /* Return the byteorder for the machine. Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII -lowercase l) for small endian machines. */) +lowercase l) for small endian machines. */ + attributes: const) (void) { unsigned i = 0x04030201; @@ -2973,12 +2986,14 @@ bool_vector_spare_mask (EMACS_INT nr_bits) /* Info about unsigned long long, falling back on unsigned long if unsigned long long is not available. */ -#if HAVE_UNSIGNED_LONG_LONG_INT +#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 ULLONG_MAX ULONG_MAX +# 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. @@ -3005,7 +3020,7 @@ count_one_bits_word (bits_word w) { int i = 0, count = 0; while (count += count_one_bits_ll (w), - BITS_PER_BITS_WORD <= (i += BITS_PER_ULL)) + (i += BITS_PER_ULL) < BITS_PER_BITS_WORD) w = shift_right_ull (w); return count; } @@ -3018,96 +3033,100 @@ enum bool_vector_op { bool_vector_exclusive_or, bool_vector_subsetp }; static Lisp_Object -bool_vector_binop_driver (Lisp_Object op1, - Lisp_Object op2, +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, *cdata; + bits_word *adata, *bdata, *destdata; ptrdiff_t i = 0; ptrdiff_t nr_words; - CHECK_BOOL_VECTOR (op1); - CHECK_BOOL_VECTOR (op2); + CHECK_BOOL_VECTOR (a); + CHECK_BOOL_VECTOR (b); - nr_bits = bool_vector_size (op1); - if (bool_vector_size (op2) != nr_bits) - wrong_length_argument (op1, op2, dest); + 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); - bdata = bool_vector_data (op1); - cdata = bool_vector_data (op2); + adata = bool_vector_data (a); + bdata = bool_vector_data (b); if (NILP (dest)) { dest = make_uninit_bool_vector (nr_bits); - adata = bool_vector_data (dest); + destdata = bool_vector_data (dest); } else { CHECK_BOOL_VECTOR (dest); - adata = bool_vector_data (dest); + destdata = bool_vector_data (dest); if (bool_vector_size (dest) != nr_bits) - wrong_length_argument (op1, op2, dest); + wrong_length_argument (a, b, dest); switch (op) { case bool_vector_exclusive_or: - while (adata[i] == (bdata[i] ^ cdata[i])) - if (! (++i < nr_words)) - return Qnil; + for (; i < nr_words; i++) + if (destdata[i] != (adata[i] ^ bdata[i])) + goto set_dest; break; case bool_vector_subsetp: - case bool_vector_union: - while (adata[i] == (bdata[i] | cdata[i])) - if (! (++i < nr_words)) + 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: - while (adata[i] == (bdata[i] & cdata[i])) - if (! (++i < nr_words)) - return Qnil; + for (; i < nr_words; i++) + if (destdata[i] != (adata[i] & bdata[i])) + goto set_dest; break; case bool_vector_set_difference: - while (adata[i] == (bdata[i] &~ cdata[i])) - if (! (++i < nr_words)) - return Qnil; + 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: - do - adata[i] = bdata[i] ^ cdata[i]; - while (++i < nr_words); - break; - - case bool_vector_subsetp: + for (; i < nr_words; i++) + destdata[i] = adata[i] ^ bdata[i]; break; case bool_vector_union: - do - adata[i] = bdata[i] | cdata[i]; - while (++i < nr_words); + for (; i < nr_words; i++) + destdata[i] = adata[i] | bdata[i]; break; case bool_vector_intersection: - do - adata[i] = bdata[i] & cdata[i]; - while (++i < nr_words); + for (; i < nr_words; i++) + destdata[i] = adata[i] & bdata[i]; break; case bool_vector_set_difference: - do - adata[i] = bdata[i] &~ cdata[i]; - while (++i < nr_words); + for (; i < nr_words; i++) + destdata[i] = adata[i] &~ bdata[i]; break; + + default: + eassume (0); } return dest; @@ -3132,7 +3151,7 @@ count_trailing_zero_bits (bits_word val) return count_trailing_zeros (val); if (BITS_WORD_MAX == ULONG_MAX) return count_trailing_zeros_l (val); - if (BITS_WORD_MAX == ULLONG_MAX) + 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 @@ -3149,7 +3168,7 @@ count_trailing_zero_bits (bits_word val) count < BITS_PER_BITS_WORD - BITS_PER_ULL; count += BITS_PER_ULL) { - if (val & ULLONG_MAX) + if (val & ULL_MAX) return count + count_trailing_zeros_ll (val); val = shift_right_ull (val); } @@ -3234,11 +3253,11 @@ Return the destination vector if it changed or nil otherwise. */) DEFUN ("bool-vector-subsetp", Fbool_vector_subsetp, Sbool_vector_subsetp, 2, 2, 0, - doc: ) + 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) { - /* Like bool_vector_union, but doesn't modify b. */ - return bool_vector_binop_driver (b, a, b, bool_vector_subsetp); + return bool_vector_binop_driver (a, b, b, bool_vector_subsetp); } DEFUN ("bool-vector-not", Fbool_vector_not, @@ -3282,11 +3301,12 @@ Return the destination vector. */) 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) +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; @@ -3303,17 +3323,13 @@ A must be a bool vector. B is a generalized bool. */) for (i = 0; i < nwords; i++) count += count_one_bits_word (adata[i]); - if (NILP (b)) - count = nr_bits - count; 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. */) +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; @@ -3526,10 +3542,6 @@ syms_of_data (void) PUT_ERROR (Qunderflow_error, Fcons (Qdomain_error, arith_tail), "Arithmetic underflow error"); - staticpro (&Qnil); - staticpro (&Qt); - staticpro (&Qunbound); - /* Types that type-of returns. */ DEFSYM (Qinteger, "integer"); DEFSYM (Qsymbol, "symbol"); @@ -3537,6 +3549,7 @@ syms_of_data (void) DEFSYM (Qcons, "cons"); DEFSYM (Qmarker, "marker"); DEFSYM (Qoverlay, "overlay"); + DEFSYM (Qfinalizer, "finalizer"); DEFSYM (Qfloat, "float"); DEFSYM (Qwindow_configuration, "window-configuration"); DEFSYM (Qprocess, "process"); @@ -3633,7 +3646,6 @@ syms_of_data (void) defsubr (&Sleq); defsubr (&Sgeq); defsubr (&Sneq); - defsubr (&Szerop); defsubr (&Splus); defsubr (&Sminus); defsubr (&Stimes); @@ -3660,8 +3672,8 @@ syms_of_data (void) defsubr (&Sbool_vector_set_difference); defsubr (&Sbool_vector_not); defsubr (&Sbool_vector_subsetp); - defsubr (&Sbool_vector_count_matches); - defsubr (&Sbool_vector_count_matches_at); + defsubr (&Sbool_vector_count_consecutive); + defsubr (&Sbool_vector_count_population); set_symbol_function (Qwholenump, XSYMBOL (Qnatnump)->function);