X-Git-Url: https://git.hcoop.net/bpt/emacs.git/blobdiff_plain/b9ff995e4c091ca99c8752bb996e155ce7147a00..b06bf4dc3ceea6aa39aae5ed64c2b9345eb1920f:/src/data.c diff --git a/src/data.c b/src/data.c index b4257243fb..9fb276cc89 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. @@ -38,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; @@ -85,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) @@ -139,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 @@ -179,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) { @@ -192,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) { @@ -237,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: @@ -262,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)) @@ -291,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, @@ -346,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, @@ -458,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; } @@ -606,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; @@ -639,53 +653,17 @@ global value outside of any lexical scope. */) return (EQ (valcontents, Qunbound) ? Qnil : Qt); } -/* FIXME: Make it an alias for function-symbol! */ -DEFUN ("fboundp", Ffboundp, Sfboundp, 1, 1, 0, - doc: /* Return t if SYMBOL's function definition is not void. */) - (register Lisp_Object symbol) -{ - CHECK_SYMBOL (symbol); - return NILP (XSYMBOL (symbol)->function) ? Qnil : Qt; -} - -DEFUN ("makunbound", Fmakunbound, Smakunbound, 1, 1, 0, - doc: /* Make SYMBOL's value be void. -Return SYMBOL. */) - (register Lisp_Object symbol) -{ - CHECK_SYMBOL (symbol); - if (SYMBOL_CONSTANT_P (symbol)) - xsignal1 (Qsetting_constant, symbol); - Fset (symbol, Qunbound); - return symbol; -} - -DEFUN ("fmakunbound", Ffmakunbound, Sfmakunbound, 1, 1, 0, - doc: /* Make SYMBOL's function definition be nil. -Return SYMBOL. */) - (register Lisp_Object symbol) -{ - CHECK_SYMBOL (symbol); - if (NILP (symbol) || EQ (symbol, Qt)) - xsignal1 (Qsetting_constant, symbol); - set_symbol_function (symbol, Qnil); - return symbol; -} - -DEFUN ("symbol-function", Fsymbol_function, Ssymbol_function, 1, 1, 0, - doc: /* Return SYMBOL's function definition. Error if that is void. */) - (register Lisp_Object symbol) -{ - CHECK_SYMBOL (symbol); - return XSYMBOL (symbol)->function; -} +WRAP1 (Ffboundp, "fboundp") +WRAP1 (Fmakunbound, "makunbound") +WRAP1 (Ffmakunbound, "fmakunbound") +WRAP1 (Fsymbol_function, "symbol-function") DEFUN ("symbol-plist", Fsymbol_plist, Ssymbol_plist, 1, 1, 0, doc: /* Return SYMBOL's property list. */) (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, @@ -699,25 +677,7 @@ DEFUN ("symbol-name", Fsymbol_name, Ssymbol_name, 1, 1, 0, return name; } -DEFUN ("fset", Ffset, Sfset, 2, 2, 0, - doc: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */) - (register Lisp_Object symbol, Lisp_Object definition) -{ - register Lisp_Object function; - CHECK_SYMBOL (symbol); - - function = XSYMBOL (symbol)->function; - - if (!NILP (Vautoload_queue) && !NILP (function)) - Vautoload_queue = Fcons (Fcons (symbol, function), Vautoload_queue); - - if (AUTOLOADP (function)) - Fput (symbol, Qautoload, XCDR (function)); - - set_symbol_function (symbol, definition); - - return definition; -} +WRAP2 (Ffset, "fset") DEFUN ("defalias", Fdefalias, Sdefalias, 2, 3, 0, doc: /* Set SYMBOL's function definition to DEFINITION. @@ -725,6 +685,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) { @@ -740,7 +704,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)); @@ -780,14 +744,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, @@ -795,10 +772,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, @@ -824,19 +801,18 @@ Value, if non-nil, is a list \(interactive SPEC). */) fun = Fsymbol_function (fun); } - if (SUBRP (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))); - } - else if (COMPILEDP (fun)) + if (COMPILEDP (fun)) { if ((ASIZE (fun) & PSEUDOVECTOR_SIZE_MASK) > COMPILED_INTERACTIVE) return list2 (Qinteractive, AREF (fun, COMPILED_INTERACTIVE)); } + else if (scm_is_true (scm_procedure_p (fun))) + { + Lisp_Object tem = scm_assq (Qinteractive_form, + scm_procedure_properties (fun)); + if (scm_is_pair (tem)) + return list2 (Qinteractive, scm_cdr (tem)); + } else if (AUTOLOADP (fun)) return Finteractive_form (Fautoload_do_load (fun, cmd, Qnil)); else if (CONSP (fun)) @@ -859,17 +835,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); @@ -899,7 +875,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; @@ -1034,7 +1010,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); @@ -1060,7 +1036,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; @@ -1112,13 +1088,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); @@ -1171,7 +1147,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. */ @@ -1192,7 +1168,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; @@ -1302,7 +1278,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 @@ -1322,13 +1298,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); @@ -1396,7 +1372,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)) @@ -1411,7 +1387,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); @@ -1459,39 +1435,6 @@ for this variable. */) default: emacs_abort (); } } - -DEFUN ("setq-default", Fsetq_default, Ssetq_default, 0, UNEVALLED, 0, - doc: /* Set the default value of variable VAR to VALUE. -VAR, the variable name, is literal (not evaluated); -VALUE is an expression: it is evaluated and its value returned. -The default value of a variable is seen in buffers -that do not have their own values for the variable. - -More generally, you can use multiple variables and values, as in - (setq-default VAR VALUE VAR VALUE...) -This sets each VAR's default value to the corresponding VALUE. -The VALUE for the Nth VAR can refer to the new default values -of previous VARs. -usage: (setq-default [VAR VALUE]...) */) - (Lisp_Object args) -{ - Lisp_Object args_left, symbol, val; - struct gcpro gcpro1; - - args_left = val = args; - GCPRO1 (args); - - while (CONSP (args_left)) - { - val = eval_sub (Fcar (XCDR (args_left))); - symbol = XCAR (args_left); - Fset_default (symbol, val); - args_left = Fcdr (XCDR (args_left)); - } - - UNGCPRO; - return val; -} /* Lisp functions for creating and removing buffer-local variables. */ @@ -1502,7 +1445,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); @@ -1538,13 +1481,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); @@ -1553,7 +1500,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: @@ -1578,13 +1525,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; @@ -1624,14 +1571,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: @@ -1651,7 +1598,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))); @@ -1667,7 +1614,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; @@ -1723,13 +1670,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; @@ -1810,14 +1757,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: @@ -1840,12 +1787,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; @@ -1864,7 +1811,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; @@ -1878,7 +1825,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; @@ -1929,13 +1876,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; @@ -1962,7 +1909,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); @@ -1971,7 +1918,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; @@ -1989,7 +1936,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 @@ -2060,12 +2007,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); @@ -2089,7 +2036,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; @@ -2128,13 +2075,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)) { @@ -2178,18 +2121,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)) { @@ -2224,7 +2158,7 @@ bool-vector. IDX starts at 0. */) unsigned char *str = SAFE_ALLOCA (nbytes); memcpy (str, SDATA (array), nbytes); - allocate_string_data (XSTRING (array), nchars, + allocate_string_data (array, nchars, nbytes + new_bytes - prev_bytes); memcpy (SDATA (array), str, idxval_byte); p1 = SDATA (array) + idxval_byte; @@ -2316,9 +2250,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 +2268,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 +2276,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 +2284,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 +2292,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 +2305,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 +2433,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 +2796,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 @@ -2962,27 +2877,57 @@ lowercase l) for small endian machines. */) /* 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 bits_word of storage so - that we don't have to special-case empty bit vectors. */ + operations below. These extra bits are always zero. */ static bits_word -bool_vector_spare_mask (ptrdiff_t nr_bits) +bool_vector_spare_mask (EMACS_INT nr_bits) { - eassume (nr_bits > 0); return (((bits_word) 1) << (nr_bits % BITS_PER_BITS_WORD)) - 1; } -#if BITS_WORD_MAX <= UINT_MAX -# define popcount_bits_word count_one_bits -#elif BITS_WORD_MAX <= ULONG_MAX -# define popcount_bits_word count_one_bits_l -#elif BITS_WORD_MAX <= ULLONG_MAX -# define popcount_bits_word count_one_bits_ll +/* 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 -# error "bits_word wider than long long? Please file a bug report." +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, @@ -2990,65 +2935,113 @@ 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; - ptrdiff_t i; - bits_word changed = 0; - bits_word mword; + 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 (a); + if (bool_vector_size (b) != nr_bits) + wrong_length_argument (a, b, dest); - nr_bits = min (XBOOL_VECTOR (op1)->size, - XBOOL_VECTOR (op2)->size); + nr_words = bool_vector_words (nr_bits); + adata = bool_vector_data (a); + bdata = bool_vector_data (b); if (NILP (dest)) { - dest = Fmake_bool_vector (make_number (nr_bits), Qnil); - changed = 1; + dest = make_uninit_bool_vector (nr_bits); + destdata = bool_vector_data (dest); } else { CHECK_BOOL_VECTOR (dest); - nr_bits = min (nr_bits, XBOOL_VECTOR (dest)->size); - } + 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; - eassume (nr_bits >= 0); - nr_words = ROUNDUP (nr_bits, BITS_PER_BITS_WORD) / BITS_PER_BITS_WORD; + 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; + } - adata = (bits_word *) XBOOL_VECTOR (dest)->data; - bdata = (bits_word *) XBOOL_VECTOR (op1)->data; - cdata = (bits_word *) XBOOL_VECTOR (op2)->data; - i = 0; - do + return Qnil; + } + + set_dest: + switch (op) { - 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 (); + case bool_vector_exclusive_or: + for (; i < nr_words; i++) + destdata[i] = adata[i] ^ bdata[i]; + break; - changed |= adata[i] ^ mword; + case bool_vector_union: + for (; i < nr_words; i++) + destdata[i] = adata[i] | bdata[i]; + break; - if (op != bool_vector_subsetp) - adata[i] = mword; + 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; - i++; + default: + eassume (0); } - while (i < nr_words); - return changed ? dest : Qnil; + 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, @@ -3060,27 +3053,34 @@ 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 HAVE_UNSIGNED_LONG_LONG_INT - if (BITS_WORD_MAX == ULLONG_MAX) + if (BITS_WORD_MAX == ULL_MAX) return count_trailing_zeros_ll (val); -# endif /* 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. */ - if (val == 0) - return CHAR_BIT * sizeof (val); + 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); - { -# if HAVE_UNSIGNED_LONG_LONG_INT - verify (BITS_WORD_MAX <= ULLONG_MAX); - return count_trailing_zeros_ll (val); -# else - verify (BITS_WORD_MAX <= ULONG_MAX); -# endif - } + 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 @@ -3088,29 +3088,33 @@ bits_word_to_host_endian (bits_word val) { #ifndef WORDS_BIGENDIAN return val; -#elif BITS_WORD_MAX >> 31 == 1 - return bswap_32 (val); -#elif BITS_WORD_MAX >> 31 >> 31 >> 1 == 1 - return bswap_64 (val); #else - int i; - bits_word r = 0; - for (i = 0; i < sizeof val; i++) - { - r = (r << CHAR_BIT) | (val & ((1u << CHAR_BIT) - 1)); - val >>= CHAR_BIT; - } - return r; + 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: /* 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. */ - ) + 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); @@ -3118,10 +3122,10 @@ it changed or nil otherwise. */ 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. */) + 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); @@ -3129,10 +3133,10 @@ it changed or nil otherwise. */) 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. */) + 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); @@ -3140,10 +3144,10 @@ it changed or nil otherwise. */) 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. */) + 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); @@ -3151,48 +3155,46 @@ 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, 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. + 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; - bits_word mword; CHECK_BOOL_VECTOR (a); - nr_bits = XBOOL_VECTOR (a)->size; + nr_bits = bool_vector_size (a); if (NILP (b)) - b = Fmake_bool_vector (make_number (nr_bits), Qnil); + b = make_uninit_bool_vector (nr_bits); else { CHECK_BOOL_VECTOR (b); - nr_bits = min (nr_bits, XBOOL_VECTOR (b)->size); + if (bool_vector_size (b) != nr_bits) + wrong_length_argument (a, b, Qnil); } - bdata = (bits_word *) XBOOL_VECTOR (b)->data; - adata = (bits_word *) XBOOL_VECTOR (a)->data; - - eassume (nr_bits >= 0); + bdata = bool_vector_data (b); + adata = bool_vector_data (a); for (i = 0; i < nr_bits / BITS_PER_BITS_WORD; i++) - bdata[i] = ~adata[i]; + bdata[i] = BITS_WORD_MAX & ~adata[i]; if (nr_bits % BITS_PER_BITS_WORD) { - mword = bits_word_to_host_endian (adata[i]); + 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); @@ -3201,70 +3203,55 @@ 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) { - ptrdiff_t count; + EMACS_INT count; EMACS_INT nr_bits; bits_word *adata; - bits_word match; - ptrdiff_t i; + ptrdiff_t i, nwords; CHECK_BOOL_VECTOR (a); - nr_bits = XBOOL_VECTOR (a)->size; + nr_bits = bool_vector_size (a); + nwords = bool_vector_words (nr_bits); count = 0; - match = NILP (b) ? -1 : 0; - adata = (bits_word *) XBOOL_VECTOR (a)->data; - - eassume (nr_bits >= 0); + adata = bool_vector_data (a); - for (i = 0; i < nr_bits / BITS_PER_BITS_WORD; ++i) - count += popcount_bits_word (adata[i] ^ match); - - /* Mask out trailing parts of final mword. */ - if (nr_bits % BITS_PER_BITS_WORD) - { - bits_word mword = adata[i] ^ match; - mword = bits_word_to_host_endian (mword); - count += popcount_bits_word (mword & bool_vector_spare_mask (nr_bits)); - } + for (i = 0; i < nwords; i++) + count += count_one_bits_word (adata[i]); 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) { - ptrdiff_t count; + EMACS_INT count; EMACS_INT nr_bits; - ptrdiff_t offset; + int offset; bits_word *adata; bits_word twiddle; bits_word mword; /* Machine word. */ - ptrdiff_t pos; + ptrdiff_t pos, pos0; ptrdiff_t nr_words; CHECK_BOOL_VECTOR (a); CHECK_NATNUM (i); - nr_bits = XBOOL_VECTOR (a)->size; + 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 = (bits_word *) XBOOL_VECTOR (a)->data; - - eassume (nr_bits >= 0); - nr_words = ROUNDUP (nr_bits, BITS_PER_BITS_WORD) / BITS_PER_BITS_WORD; - + 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; @@ -3272,7 +3259,7 @@ index into the vector. */) /* 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 : -1; + twiddle = NILP (b) ? 0 : BITS_WORD_MAX; /* Scan the remainder of the mword at the current offset. */ if (pos < nr_words && offset != 0) @@ -3280,8 +3267,11 @@ index into the vector. */) 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); - count = min (count, BITS_PER_BITS_WORD - offset); pos++; if (count + offset < BITS_PER_BITS_WORD) return make_number (count); @@ -3290,11 +3280,10 @@ index into the vector. */) /* 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) - { - count += BITS_PER_BITS_WORD; - ++pos; - } + pos++; + count += (pos - pos0) * BITS_PER_BITS_WORD; if (pos < nr_words) { @@ -3316,11 +3305,29 @@ index into the vector. */) } +DEFUN ("bind-symbol", Fbind_symbol, Sbind_symbol, 3, 3, 0, + doc: /* Bind symbol. */) + (Lisp_Object symbol, Lisp_Object value, Lisp_Object thunk) +{ + Lisp_Object val; + dynwind_begin (); + specbind (symbol, value); + val = call0 (thunk); + dynwind_end (); + return val; +} + void 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"); @@ -3331,6 +3338,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"); @@ -3405,6 +3413,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, @@ -3483,122 +3492,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); - - 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); + 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); }