diff options
Diffstat (limited to 'src/data.c')
| -rw-r--r-- | src/data.c | 2047 |
1 files changed, 1281 insertions, 766 deletions
diff --git a/src/data.c b/src/data.c index 2e7f3e017be..221a6f58835 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-2017 Free Software + Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2022 Free Software Foundation, Inc. This file is part of GNU Emacs. @@ -29,6 +29,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include <intprops.h> #include "lisp.h" +#include "bignum.h" #include "puresize.h" #include "character.h" #include "buffer.h" @@ -41,55 +42,49 @@ static void swap_in_symval_forwarding (struct Lisp_Symbol *, struct Lisp_Buffer_Local_Value *); static bool -BOOLFWDP (union Lisp_Fwd *a) +BOOLFWDP (lispfwd a) { return XFWDTYPE (a) == Lisp_Fwd_Bool; } static bool -INTFWDP (union Lisp_Fwd *a) +INTFWDP (lispfwd a) { return XFWDTYPE (a) == Lisp_Fwd_Int; } static bool -KBOARD_OBJFWDP (union Lisp_Fwd *a) +KBOARD_OBJFWDP (lispfwd a) { return XFWDTYPE (a) == Lisp_Fwd_Kboard_Obj; } static bool -OBJFWDP (union Lisp_Fwd *a) +OBJFWDP (lispfwd a) { return XFWDTYPE (a) == Lisp_Fwd_Obj; } -static struct Lisp_Boolfwd * -XBOOLFWD (union Lisp_Fwd *a) +static struct Lisp_Boolfwd const * +XBOOLFWD (lispfwd a) { eassert (BOOLFWDP (a)); - return &a->u_boolfwd; + return a.fwdptr; } -static struct Lisp_Kboard_Objfwd * -XKBOARD_OBJFWD (union Lisp_Fwd *a) +static struct Lisp_Kboard_Objfwd const * +XKBOARD_OBJFWD (lispfwd a) { eassert (KBOARD_OBJFWDP (a)); - return &a->u_kboard_objfwd; + return a.fwdptr; } -static struct Lisp_Intfwd * -XINTFWD (union Lisp_Fwd *a) +static struct Lisp_Intfwd const * +XFIXNUMFWD (lispfwd a) { eassert (INTFWDP (a)); - return &a->u_intfwd; + return a.fwdptr; } -static struct Lisp_Objfwd * -XOBJFWD (union Lisp_Fwd *a) +static struct Lisp_Objfwd const * +XOBJFWD (lispfwd a) { eassert (OBJFWDP (a)); - return &a->u_objfwd; -} - -static void -CHECK_SUBR (Lisp_Object x) -{ - CHECK_TYPE (SUBRP (x), Qsubrp, x); + return a.fwdptr; } static void @@ -129,28 +124,22 @@ set_blv_valcell (struct Lisp_Buffer_Local_Value *blv, Lisp_Object val) blv->valcell = val; } -static _Noreturn void +static AVOID 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)); + Lisp_Object size1 = make_fixnum (bool_vector_size (a1)); + Lisp_Object size2 = make_fixnum (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))); + make_fixnum (bool_vector_size (a3))); } -_Noreturn void -wrong_type_argument (register Lisp_Object predicate, register Lisp_Object value) +AVOID +wrong_type_argument (Lisp_Object predicate, Lisp_Object value) { - /* If VALUE is not even a valid Lisp object, we'd want to abort here - where we can get a backtrace showing where it came from. We used - to try and do that by checking the tagbits, but nowadays all - tagbits are potentially valid. */ - /* if ((unsigned int) XTYPE (value) >= Lisp_Type_Limit) - * emacs_abort (); */ - + eassert (!TAGGEDP (value, Lisp_Type_Unused0)); xsignal2 (Qwrong_type_argument, predicate, value); } @@ -221,27 +210,17 @@ for example, (type-of 1) returns `integer'. */) case Lisp_Cons: return Qcons; - case Lisp_Misc: - switch (XMISCTYPE (object)) - { - case Lisp_Misc_Marker: - return Qmarker; - case Lisp_Misc_Overlay: - return Qoverlay; - case Lisp_Misc_Finalizer: - return Qfinalizer; -#ifdef HAVE_MODULES - case Lisp_Misc_User_Ptr: - return Quser_ptr; -#endif - default: - emacs_abort (); - } - case Lisp_Vectorlike: + /* WARNING!! Keep 'cl--typeof-types' in sync with this code!! */ switch (PSEUDOVECTOR_TYPE (XVECTOR (object))) { case PVEC_NORMAL_VECTOR: return Qvector; + case PVEC_BIGNUM: return Qinteger; + case PVEC_MARKER: return Qmarker; + case PVEC_SYMBOL_WITH_POS: return Qsymbol_with_pos; + case PVEC_OVERLAY: return Qoverlay; + case PVEC_FINALIZER: return Qfinalizer; + case PVEC_USER_PTR: return Quser_ptr; case PVEC_WINDOW_CONFIGURATION: return Qwindow_configuration; case PVEC_PROCESS: return Qprocess; case PVEC_WINDOW: return Qwindow; @@ -276,10 +255,17 @@ for example, (type-of 1) returns `integer'. */) } case PVEC_MODULE_FUNCTION: return Qmodule_function; - /* "Impossible" cases. */ + case PVEC_NATIVE_COMP_UNIT: + return Qnative_comp_unit; case PVEC_XWIDGET: - case PVEC_OTHER: + return Qxwidget; case PVEC_XWIDGET_VIEW: + return Qxwidget_view; + case PVEC_SQLITE: + return Qsqlite; + /* "Impossible" cases. */ + case PVEC_MISC_PTR: + case PVEC_OTHER: case PVEC_SUB_CHAR_TABLE: case PVEC_FREE: ; } @@ -334,6 +320,26 @@ DEFUN ("nlistp", Fnlistp, Snlistp, 1, 1, 0, return Qt; } +DEFUN ("bare-symbol-p", Fbare_symbol_p, Sbare_symbol_p, 1, 1, 0, + doc: /* Return t if OBJECT is a symbol, but not a symbol together with position. */ + attributes: const) + (Lisp_Object object) +{ + if (BARE_SYMBOL_P (object)) + return Qt; + return Qnil; +} + +DEFUN ("symbol-with-pos-p", Fsymbol_with_pos_p, Ssymbol_with_pos_p, 1, 1, 0, + doc: /* Return t if OBJECT is a symbol together with position. */ + attributes: const) + (Lisp_Object object) +{ + if (SYMBOL_WITH_POS_P (object)) + return Qt; + return Qnil; +} + DEFUN ("symbolp", Fsymbolp, Ssymbolp, 1, 1, 0, doc: /* Return t if OBJECT is a symbol. */ attributes: const) @@ -344,8 +350,6 @@ DEFUN ("symbolp", Fsymbolp, Ssymbolp, 1, 1, 0, return Qnil; } -/* Define this in C to avoid unnecessarily consing up the symbol - name. */ DEFUN ("keywordp", Fkeywordp, Skeywordp, 1, 1, 0, doc: /* Return t if OBJECT is a keyword. This means that it is a symbol with a print name beginning with `:' @@ -534,9 +538,9 @@ DEFUN ("natnump", Fnatnump, Snatnump, 1, 1, 0, attributes: const) (Lisp_Object object) { - if (NATNUMP (object)) - return Qt; - return Qnil; + return ((FIXNUMP (object) ? 0 <= XFIXNUM (object) + : BIGNUMP (object) && 0 <= mpz_sgn (*xbignum_val (object))) + ? Qt : Qnil); } DEFUN ("numberp", Fnumberp, Snumberp, 1, 1, 0, @@ -601,8 +605,8 @@ DEFUN ("condition-variable-p", Fcondition_variable_p, Scondition_variable_p, /* Extract and set components of lists. */ DEFUN ("car", Fcar, Scar, 1, 1, 0, - doc: /* Return the car of LIST. If arg is nil, return nil. -Error if arg is not nil and not a cons cell. See also `car-safe'. + doc: /* Return the car of LIST. If LIST is nil, return nil. +Error if LIST is not nil and not a cons cell. See also `car-safe'. See Info node `(elisp)Cons Cells' for a discussion of related basic Lisp concepts such as car, cdr, cons cell and list. */) @@ -619,8 +623,8 @@ DEFUN ("car-safe", Fcar_safe, Scar_safe, 1, 1, 0, } DEFUN ("cdr", Fcdr, Scdr, 1, 1, 0, - doc: /* Return the cdr of LIST. If arg is nil, return nil. -Error if arg is not nil and not a cons cell. See also `cdr-safe'. + doc: /* Return the cdr of LIST. If LIST is nil, return nil. +Error if LIST is not nil and not a cons cell. See also `cdr-safe'. See Info node `(elisp)Cons Cells' for a discussion of related basic Lisp concepts such as cdr, car, cons cell and list. */) @@ -670,14 +674,14 @@ global value outside of any lexical scope. */) sym = XSYMBOL (symbol); start: - switch (sym->redirect) + switch (sym->u.s.redirect) { case SYMBOL_PLAINVAL: valcontents = SYMBOL_VAL (sym); break; case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start; case SYMBOL_LOCALIZED: { struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym); - if (blv->fwd) + if (blv->fwd.fwdptr) /* In set_internal, we un-forward vars when their value is set to Qunbound. */ return Qt; @@ -695,24 +699,30 @@ global value outside of any lexical scope. */) default: emacs_abort (); } - return (EQ (valcontents, Qunbound) ? Qnil : Qt); + return (BASE_EQ (valcontents, Qunbound) ? Qnil : Qt); } /* It has been previously suggested to make this function an alias for symbol-function, but upon discussion at Bug#23957, there is a risk breaking backward compatibility, as some users of fboundp may - expect `t' in particular, rather than any true value. */ + expect t in particular, rather than any true value. */ DEFUN ("fboundp", Ffboundp, Sfboundp, 1, 1, 0, doc: /* Return t if SYMBOL's function definition is not void. */) - (register Lisp_Object symbol) + (Lisp_Object symbol) { CHECK_SYMBOL (symbol); - return NILP (XSYMBOL (symbol)->function) ? Qnil : Qt; + return NILP (XSYMBOL (symbol)->u.s.function) ? Qnil : Qt; } DEFUN ("makunbound", Fmakunbound, Smakunbound, 1, 1, 0, - doc: /* Make SYMBOL's value be void. -Return SYMBOL. */) + doc: /* Empty out the value cell of SYMBOL, making it void as a variable. +Return SYMBOL. + +If a variable is void, trying to evaluate the variable signals a +`void-variable' error, instead of returning a value. For more +details, see Info node `(elisp) Void Variables'. + +See also `fmakunbound'. */) (register Lisp_Object symbol) { CHECK_SYMBOL (symbol); @@ -723,8 +733,14 @@ Return SYMBOL. */) } DEFUN ("fmakunbound", Ffmakunbound, Sfmakunbound, 1, 1, 0, - doc: /* Make SYMBOL's function definition be nil. -Return SYMBOL. */) + doc: /* Make SYMBOL's function definition be void. +Return SYMBOL. + +If a function definition is void, trying to call a function by that +name will cause a `void-function' error. For more details, see Info +node `(elisp) Function Cells'. + +See also `makunbound'. */) (register Lisp_Object symbol) { CHECK_SYMBOL (symbol); @@ -736,18 +752,18 @@ Return SYMBOL. */) DEFUN ("symbol-function", Fsymbol_function, Ssymbol_function, 1, 1, 0, doc: /* Return SYMBOL's function definition, or nil if that is void. */) - (register Lisp_Object symbol) + (Lisp_Object symbol) { CHECK_SYMBOL (symbol); - return XSYMBOL (symbol)->function; + return XSYMBOL (symbol)->u.s.function; } DEFUN ("symbol-plist", Fsymbol_plist, Ssymbol_plist, 1, 1, 0, doc: /* Return SYMBOL's property list. */) - (register Lisp_Object symbol) + (Lisp_Object symbol) { CHECK_SYMBOL (symbol); - return XSYMBOL (symbol)->plist; + return XSYMBOL (symbol)->u.s.plist; } DEFUN ("symbol-name", Fsymbol_name, Ssymbol_name, 1, 1, 0, @@ -761,34 +777,158 @@ DEFUN ("symbol-name", Fsymbol_name, Ssymbol_name, 1, 1, 0, return name; } +DEFUN ("bare-symbol", Fbare_symbol, Sbare_symbol, 1, 1, 0, + doc: /* Extract, if need be, the bare symbol from SYM, a symbol. */) + (register Lisp_Object sym) +{ + if (BARE_SYMBOL_P (sym)) + return sym; + /* Type checking is done in the following macro. */ + return SYMBOL_WITH_POS_SYM (sym); +} + +DEFUN ("symbol-with-pos-pos", Fsymbol_with_pos_pos, Ssymbol_with_pos_pos, 1, 1, 0, + doc: /* Extract the position from a symbol with position. */) + (register Lisp_Object ls) +{ + /* Type checking is done in the following macro. */ + return SYMBOL_WITH_POS_POS (ls); +} + +DEFUN ("remove-pos-from-symbol", Fremove_pos_from_symbol, + Sremove_pos_from_symbol, 1, 1, 0, + doc: /* If ARG is a symbol with position, return it without the position. +Otherwise, return ARG unchanged. Compare with `bare-symbol'. */) + (register Lisp_Object arg) +{ + if (SYMBOL_WITH_POS_P (arg)) + return (SYMBOL_WITH_POS_SYM (arg)); + return arg; +} + +DEFUN ("position-symbol", Fposition_symbol, Sposition_symbol, 2, 2, 0, + doc: /* Create a new symbol with position. +SYM is a symbol, with or without position, the symbol to position. +POS, the position, is either a fixnum or a symbol with position from which +the position will be taken. */) + (register Lisp_Object sym, register Lisp_Object pos) +{ + Lisp_Object bare; + Lisp_Object position; + + if (BARE_SYMBOL_P (sym)) + bare = sym; + else if (SYMBOL_WITH_POS_P (sym)) + bare = XSYMBOL_WITH_POS (sym)->sym; + else + wrong_type_argument (Qsymbolp, sym); + + if (FIXNUMP (pos)) + position = pos; + else if (SYMBOL_WITH_POS_P (pos)) + position = XSYMBOL_WITH_POS (pos)->pos; + else + wrong_type_argument (Qfixnum_or_symbol_with_pos_p, pos); + + return build_symbol_with_pos (bare, position); +} + 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); /* Perhaps not quite the right error signal, but seems good enough. */ - if (NILP (symbol)) + if (NILP (symbol) && !NILP (definition)) + /* There are so many other ways to shoot oneself in the foot, I don't + think this one little sanity check is worth its cost, but anyway. */ xsignal1 (Qsetting_constant, symbol); - function = XSYMBOL (symbol)->function; - - if (!NILP (Vautoload_queue) && !NILP (function)) - Vautoload_queue = Fcons (Fcons (symbol, function), Vautoload_queue); + eassert (valid_lisp_object_p (definition)); - if (AUTOLOADP (function)) - Fput (symbol, Qautoload, XCDR (function)); +#ifdef HAVE_NATIVE_COMP + register Lisp_Object function = XSYMBOL (symbol)->u.s.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 (); + if (comp_enable_subr_trampolines + && SUBRP (function) + && !SUBR_NATIVE_COMPILEDP (function)) + CALLN (Ffuncall, Qcomp_subr_trampoline_install, symbol); +#endif set_symbol_function (symbol, definition); return definition; } +static void +add_to_function_history (Lisp_Object symbol, Lisp_Object olddef) +{ + eassert (!NILP (olddef)); + + Lisp_Object past = Fget (symbol, Qfunction_history); + Lisp_Object file = Qnil; + /* FIXME: Sadly, `Vload_file_name` gives less precise information + (it's sometimes non-nil when it shoujld be nil). */ + Lisp_Object tail = Vcurrent_load_list; + FOR_EACH_TAIL_SAFE (tail) + if (NILP (XCDR (tail)) && STRINGP (XCAR (tail))) + file = XCAR (tail); + + Lisp_Object tem = plist_member (past, file); + if (!NILP (tem)) + { /* New def from a file used before. + Overwrite the previous record associated with this file. */ + if (EQ (tem, past)) + /* The new def is from the same file as the last change, so + there's nothing to do: unloading the file should revert to + the status before the last change rather than before this load. */ + return; + Lisp_Object pastlen = Flength (past); + Lisp_Object temlen = Flength (tem); + EMACS_INT tempos = XFIXNUM (pastlen) - XFIXNUM (temlen); + eassert (tempos > 1); + Lisp_Object prev = Fnthcdr (make_fixnum (tempos - 2), past); + /* Remove the previous info for this file. + E.g. change `hist` from (... OTHERFILE DEF3 THISFILE DEF2 ...) + to (... OTHERFILE DEF2). */ + XSETCDR (prev, XCDR (tem)); + } + /* Push new def from new file. */ + Fput (symbol, Qfunction_history, Fcons (file, Fcons (olddef, past))); +} + +void +defalias (Lisp_Object symbol, Lisp_Object definition) +{ + { + bool autoload = AUTOLOADP (definition); + if (!will_dump_p () || !autoload) + { /* Only add autoload entries after dumping, because the ones before are + not useful and else we get loads of them from the loaddefs.el. + That saves us about 110KB in the pdmp file (Jan 2022). */ + LOADHIST_ATTACH (Fcons (Qdefun, symbol)); + } + } + + { + Lisp_Object olddef = XSYMBOL (symbol)->u.s.function; + if (!NILP (olddef)) + { + if (!NILP (Vautoload_queue)) + Vautoload_queue = Fcons (symbol, Vautoload_queue); + add_to_function_history (symbol, olddef); + } + } + + { /* Handle automatic advice activation. */ + Lisp_Object hook = Fget (symbol, Qdefalias_fset_function); + if (!NILP (hook)) + call2 (hook, symbol, definition); + else + Ffset (symbol, definition); + } +} + DEFUN ("defalias", Fdefalias, Sdefalias, 2, 3, 0, doc: /* Set SYMBOL's function definition to DEFINITION. Associates the function with the current load file, if any. @@ -808,26 +948,9 @@ The return value is undefined. */) && !KEYMAPP (definition)) definition = Fpurecopy (definition); - { - bool autoload = AUTOLOADP (definition); - if (NILP (Vpurify_flag) || !autoload) - { /* 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)) - /* Remember that the function was already an autoload. */ - LOADHIST_ATTACH (Fcons (Qt, symbol)); - LOADHIST_ATTACH (Fcons (autoload ? Qautoload : Qdefun, symbol)); - } - } + defalias (symbol, definition); - { /* Handle automatic advice activation. */ - Lisp_Object hook = Fget (symbol, Qdefalias_fset_function); - if (!NILP (hook)) - call2 (hook, symbol, definition); - else - Ffset (symbol, definition); - } + maybe_defer_native_compilation (symbol, definition); if (!NILP (docstring)) Fput (symbol, Qfunction_documentation, docstring); @@ -858,10 +981,10 @@ function with `&rest' args, or `unevalled' for a special form. */) CHECK_SUBR (subr); minargs = XSUBR (subr)->min_args; maxargs = XSUBR (subr)->max_args; - return Fcons (make_number (minargs), + return Fcons (make_fixnum (minargs), maxargs == MANY ? Qmany : maxargs == UNEVALLED ? Qunevalled - : make_number (maxargs)); + : make_fixnum (maxargs)); } DEFUN ("subr-name", Fsubr_name, Ssubr_name, 1, 1, 0, @@ -875,6 +998,74 @@ SUBR must be a built-in function. */) return build_string (name); } +DEFUN ("subr-native-elisp-p", Fsubr_native_elisp_p, Ssubr_native_elisp_p, 1, 1, + 0, doc: /* Return t if the object is native compiled lisp +function, nil otherwise. */) + (Lisp_Object object) +{ + return SUBR_NATIVE_COMPILEDP (object) ? Qt : Qnil; +} + +DEFUN ("subr-native-lambda-list", Fsubr_native_lambda_list, + Ssubr_native_lambda_list, 1, 1, 0, + doc: /* Return the lambda list for a native compiled lisp/d +function or t otherwise. */) + (Lisp_Object subr) +{ + CHECK_SUBR (subr); + +#ifdef HAVE_NATIVE_COMP + if (SUBR_NATIVE_COMPILED_DYNP (subr)) + return XSUBR (subr)->lambda_list; +#endif + return Qt; +} + +DEFUN ("subr-type", Fsubr_type, + Ssubr_type, 1, 1, 0, + doc: /* Return the type of SUBR. */) + (Lisp_Object subr) +{ + CHECK_SUBR (subr); +#ifdef HAVE_NATIVE_COMP + return SUBR_TYPE (subr); +#else + return Qnil; +#endif +} + +#ifdef HAVE_NATIVE_COMP + +DEFUN ("subr-native-comp-unit", Fsubr_native_comp_unit, + Ssubr_native_comp_unit, 1, 1, 0, + doc: /* Return the native compilation unit. */) + (Lisp_Object subr) +{ + CHECK_SUBR (subr); + return XSUBR (subr)->native_comp_u; +} + +DEFUN ("native-comp-unit-file", Fnative_comp_unit_file, + Snative_comp_unit_file, 1, 1, 0, + doc: /* Return the file of the native compilation unit. */) + (Lisp_Object comp_unit) +{ + CHECK_TYPE (NATIVE_COMP_UNITP (comp_unit), Qnative_comp_unit, comp_unit); + return XNATIVE_COMP_UNIT (comp_unit)->file; +} + +DEFUN ("native-comp-unit-set-file", Fnative_comp_unit_set_file, + Snative_comp_unit_set_file, 2, 2, 0, + doc: /* Return the file of the native compilation unit. */) + (Lisp_Object comp_unit, Lisp_Object new_file) +{ + CHECK_TYPE (NATIVE_COMP_UNITP (comp_unit), Qnative_comp_unit, comp_unit); + XNATIVE_COMP_UNIT (comp_unit)->file = new_file; + return comp_unit; +} + +#endif + DEFUN ("interactive-form", Finteractive_form, Sinteractive_form, 1, 1, 0, doc: /* Return the interactive form of CMD or nil if none. If CMD is not a command, the return value is nil. @@ -882,6 +1073,7 @@ Value, if non-nil, is a list (interactive SPEC). */) (Lisp_Object cmd) { Lisp_Object fun = indirect_function (cmd); /* Check cycles. */ + bool genfun = false; if (NILP (fun)) return Qnil; @@ -900,7 +1092,10 @@ Value, if non-nil, is a list (interactive SPEC). */) if (SUBRP (fun)) { - const char *spec = XSUBR (fun)->intspec; + if (SUBR_NATIVE_COMPILEDP (fun) && !NILP (XSUBR (fun)->intspec.native)) + return XSUBR (fun)->intspec.native; + + const char *spec = XSUBR (fun)->intspec.string; if (spec) return list2 (Qinteractive, (*spec != '(') ? build_string (spec) : @@ -909,17 +1104,125 @@ Value, if non-nil, is a list (interactive SPEC). */) else if (COMPILEDP (fun)) { if (PVSIZE (fun) > COMPILED_INTERACTIVE) - return list2 (Qinteractive, AREF (fun, COMPILED_INTERACTIVE)); + { + Lisp_Object form = AREF (fun, COMPILED_INTERACTIVE); + /* The vector form is the new form, where the first + element is the interactive spec, and the second is the + command modes. */ + return list2 (Qinteractive, VECTORP (form) ? AREF (form, 0) : form); + } + else if (PVSIZE (fun) > COMPILED_DOC_STRING) + { + Lisp_Object doc = AREF (fun, COMPILED_DOC_STRING); + /* An invalid "docstring" is a sign that we have an OClosure. */ + genfun = !(NILP (doc) || VALID_DOCSTRING_P (doc)); + } + } +#ifdef HAVE_MODULES + else if (MODULE_FUNCTIONP (fun)) + { + Lisp_Object form + = module_function_interactive_form (XMODULE_FUNCTION (fun)); + if (! NILP (form)) + return form; } +#endif else if (AUTOLOADP (fun)) return Finteractive_form (Fautoload_do_load (fun, cmd, Qnil)); else if (CONSP (fun)) { Lisp_Object funcar = XCAR (fun); - if (EQ (funcar, Qclosure)) - return Fassq (Qinteractive, Fcdr (Fcdr (XCDR (fun)))); - else if (EQ (funcar, Qlambda)) - return Fassq (Qinteractive, Fcdr (XCDR (fun))); + if (EQ (funcar, Qclosure) + || EQ (funcar, Qlambda)) + { + Lisp_Object form = Fcdr (XCDR (fun)); + if (EQ (funcar, Qclosure)) + form = Fcdr (form); + Lisp_Object spec = Fassq (Qinteractive, form); + if (NILP (spec) && VALID_DOCSTRING_P (CAR_SAFE (form))) + /* A "docstring" is a sign that we may have an OClosure. */ + genfun = true; + else if (NILP (Fcdr (Fcdr (spec)))) + return spec; + else + return list2 (Qinteractive, Fcar (Fcdr (spec))); + } + } + if (genfun + /* Avoid burping during bootstrap. */ + && !NILP (Fsymbol_function (Qoclosure_interactive_form))) + return call1 (Qoclosure_interactive_form, fun); + else + return Qnil; +} + +DEFUN ("command-modes", Fcommand_modes, Scommand_modes, 1, 1, 0, + doc: /* Return the modes COMMAND is defined for. +If COMMAND is not a command, the return value is nil. +The value, if non-nil, is a list of mode name symbols. */) + (Lisp_Object command) +{ + Lisp_Object fun = indirect_function (command); /* Check cycles. */ + + if (NILP (fun)) + return Qnil; + + /* Use a `command-modes' property if present, analogous to the + function-documentation property. */ + fun = command; + while (SYMBOLP (fun)) + { + Lisp_Object modes = Fget (fun, Qcommand_modes); + if (!NILP (modes)) + return modes; + else + fun = Fsymbol_function (fun); + } + + if (SUBRP (fun)) + { + return XSUBR (fun)->command_modes; + } + else if (COMPILEDP (fun)) + { + if (PVSIZE (fun) <= COMPILED_INTERACTIVE) + return Qnil; + Lisp_Object form = AREF (fun, COMPILED_INTERACTIVE); + if (VECTORP (form)) + /* New form -- the second element is the command modes. */ + return AREF (form, 1); + else + /* Old .elc file -- no command modes. */ + return Qnil; + } +#ifdef HAVE_MODULES + else if (MODULE_FUNCTIONP (fun)) + { + Lisp_Object form + = module_function_command_modes (XMODULE_FUNCTION (fun)); + if (! NILP (form)) + return form; + } +#endif + else if (AUTOLOADP (fun)) + { + Lisp_Object modes = Fnth (make_int (3), fun); + if (CONSP (modes)) + return modes; + else + return Qnil; + } + else if (CONSP (fun)) + { + Lisp_Object funcar = XCAR (fun); + if (EQ (funcar, Qclosure) + || EQ (funcar, Qlambda)) + { + Lisp_Object form = Fcdr (XCDR (fun)); + if (EQ (funcar, Qclosure)) + form = Fcdr (form); + return Fcdr (Fcdr (Fassq (Qinteractive, form))); + } } return Qnil; } @@ -940,10 +1243,10 @@ indirect_variable (struct Lisp_Symbol *symbol) hare = tortoise = symbol; - while (hare->redirect == SYMBOL_VARALIAS) + while (hare->u.s.redirect == SYMBOL_VARALIAS) { hare = SYMBOL_ALIAS (hare); - if (hare->redirect != SYMBOL_VARALIAS) + if (hare->u.s.redirect != SYMBOL_VARALIAS) break; hare = SYMBOL_ALIAS (hare); @@ -986,14 +1289,12 @@ chain of aliases, signal a `cyclic-variable-indirection' error. */) swap_in_symval_forwarding for that. */ Lisp_Object -do_symval_forwarding (register union Lisp_Fwd *valcontents) +do_symval_forwarding (lispfwd valcontents) { - register Lisp_Object val; switch (XFWDTYPE (valcontents)) { case Lisp_Fwd_Int: - XSETINT (val, *XINTFWD (valcontents)->intvar); - return val; + return make_int (*XFIXNUMFWD (valcontents)->intvar); case Lisp_Fwd_Bool: return (*XBOOLFWD (valcontents)->boolvar ? Qt : Qnil); @@ -1029,7 +1330,7 @@ do_symval_forwarding (register union Lisp_Fwd *valcontents) void wrong_choice (Lisp_Object choice, Lisp_Object wrong) { - ptrdiff_t i = 0, len = XINT (Flength (choice)); + ptrdiff_t i = 0, len = list_length (choice); Lisp_Object obj, *args; AUTO_STRING (one_of, "One of "); AUTO_STRING (comma, ", "); @@ -1049,7 +1350,10 @@ wrong_choice (Lisp_Object choice, Lisp_Object wrong) } obj = Fconcat (i, args); - SAFE_FREE (); + + /* No need to call SAFE_FREE, since signaling does that for us. */ + (void) sa_count; + xsignal2 (Qerror, obj, wrong); } @@ -1076,13 +1380,19 @@ wrong_range (Lisp_Object min, Lisp_Object max, Lisp_Object wrong) current buffer. This only plays a role for per-buffer variables. */ static void -store_symval_forwarding (union Lisp_Fwd *valcontents, register Lisp_Object newval, struct buffer *buf) +store_symval_forwarding (lispfwd valcontents, Lisp_Object newval, + struct buffer *buf) { switch (XFWDTYPE (valcontents)) { case Lisp_Fwd_Int: - CHECK_NUMBER (newval); - *XINTFWD (valcontents)->intvar = XINT (newval); + { + intmax_t i; + CHECK_INTEGER (newval); + if (! integer_to_intmax (newval, &i)) + xsignal1 (Qoverflow_error, newval); + *XFIXNUMFWD (valcontents)->intvar = i; + } break; case Lisp_Fwd_Bool: @@ -1123,20 +1433,21 @@ 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 (newval)) + if (!NILP (newval) && !NILP (predicate)) { - if (SYMBOLP (predicate)) + eassert (SYMBOLP (predicate)); + Lisp_Object choiceprop = Fget (predicate, Qchoice); + if (!NILP (choiceprop)) { - 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))) + if (NILP (Fmemq (newval, choiceprop))) + wrong_choice (choiceprop, newval); + } + else + { + Lisp_Object rangeprop = Fget (predicate, Qrange); + if (CONSP (rangeprop)) { - Lisp_Object min = XCAR (prop), max = XCDR (prop); + Lisp_Object min = XCAR (rangeprop), max = XCDR (rangeprop); if (! NUMBERP (newval) || NILP (CALLN (Fleq, min, newval, max))) wrong_range (min, max, newval); @@ -1178,17 +1489,17 @@ swap_in_global_binding (struct Lisp_Symbol *symbol) struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (symbol); /* Unload the previously loaded binding. */ - if (blv->fwd) + if (blv->fwd.fwdptr) set_blv_value (blv, do_symval_forwarding (blv->fwd)); /* Select the global binding in the symbol. */ set_blv_valcell (blv, blv->defcell); - if (blv->fwd) + if (blv->fwd.fwdptr) store_symval_forwarding (blv->fwd, XCDR (blv->defcell), NULL); /* Indicate that the global binding is set up now. */ set_blv_where (blv, Qnil); - set_blv_found (blv, 0); + set_blv_found (blv, false); } /* Set up the buffer-local symbol SYMBOL for validity in the current buffer. @@ -1213,7 +1524,7 @@ swap_in_symval_forwarding (struct Lisp_Symbol *symbol, struct Lisp_Buffer_Local_ /* Unload the previously loaded binding. */ tem1 = blv->valcell; - if (blv->fwd) + if (blv->fwd.fwdptr) set_blv_value (blv, do_symval_forwarding (blv->fwd)); /* Choose the new binding. */ { @@ -1227,7 +1538,7 @@ swap_in_symval_forwarding (struct Lisp_Symbol *symbol, struct Lisp_Buffer_Local_ /* Load the new binding. */ set_blv_valcell (blv, tem1); - if (blv->fwd) + if (blv->fwd.fwdptr) store_symval_forwarding (blv->fwd, blv_value (blv), NULL); } } @@ -1235,8 +1546,13 @@ swap_in_symval_forwarding (struct Lisp_Symbol *symbol, struct Lisp_Buffer_Local_ /* Find the value of a symbol, returning Qunbound if it's not bound. This is helpful for code which just wants to get a variable's value if it has one, without signaling an error. - Note that it must not be possible to quit - within this function. Great care is required for this. */ + + This function is very similar to buffer_local_value, but we have + two separate code paths here since find_symbol_value has to be very + efficient, while buffer_local_value doesn't have to be. + + Note that it must not be possible to quit within this function. + Great care is required for this. */ Lisp_Object find_symbol_value (Lisp_Object symbol) @@ -1247,7 +1563,7 @@ find_symbol_value (Lisp_Object symbol) sym = XSYMBOL (symbol); start: - switch (sym->redirect) + switch (sym->u.s.redirect) { case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start; case SYMBOL_PLAINVAL: return SYMBOL_VAL (sym); @@ -1255,9 +1571,10 @@ find_symbol_value (Lisp_Object symbol) { struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym); swap_in_symval_forwarding (sym, blv); - return blv->fwd ? do_symval_forwarding (blv->fwd) : blv_value (blv); + return (blv->fwd.fwdptr + ? do_symval_forwarding (blv->fwd) + : blv_value (blv)); } - /* FALLTHROUGH */ case SYMBOL_FORWARDED: return do_symval_forwarding (SYMBOL_FWD (sym)); default: emacs_abort (); @@ -1273,7 +1590,7 @@ global value outside of any lexical scope. */) Lisp_Object val; val = find_symbol_value (symbol); - if (!EQ (val, Qunbound)) + if (!BASE_EQ (val, Qunbound)) return val; xsignal1 (Qvoid_variable, symbol); @@ -1300,17 +1617,15 @@ void set_internal (Lisp_Object symbol, Lisp_Object newval, Lisp_Object where, enum Set_Internal_Bind bindflag) { - bool voide = EQ (newval, Qunbound); - struct Lisp_Symbol *sym; - Lisp_Object tem1; + bool voide = BASE_EQ (newval, Qunbound); /* If restoring in a dead buffer, do nothing. */ /* if (BUFFERP (where) && NILP (XBUFFER (where)->name)) return; */ CHECK_SYMBOL (symbol); - sym = XSYMBOL (symbol); - switch (sym->trapped_write) + struct Lisp_Symbol *sym = XSYMBOL (symbol); + switch (sym->u.s.trapped_write) { case SYMBOL_NOWRITE: if (NILP (Fkeywordp (symbol)) @@ -1328,15 +1643,16 @@ set_internal (Lisp_Object symbol, Lisp_Object newval, Lisp_Object where, bindflag == SET_INTERNAL_UNBIND? Qunlet : voide? Qmakunbound : Qset), where); - /* FALLTHROUGH! */ + break; + case SYMBOL_UNTRAPPED_WRITE: - break; + break; default: emacs_abort (); } start: - switch (sym->redirect) + switch (sym->u.s.redirect) { case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start; case SYMBOL_PLAINVAL: SET_SYMBOL_VAL (sym , newval); return; @@ -1358,15 +1674,16 @@ set_internal (Lisp_Object symbol, Lisp_Object newval, Lisp_Object where, We need to unload it, and choose a new binding. */ /* Write out `realvalue' to the old loaded binding. */ - if (blv->fwd) + if (blv->fwd.fwdptr) set_blv_value (blv, do_symval_forwarding (blv->fwd)); /* Find the new binding. */ XSETSYMBOL (symbol, sym); /* May have changed via aliasing. */ - tem1 = assq_no_quit (symbol, - BVAR (XBUFFER (where), local_var_alist)); + Lisp_Object tem1 + = assq_no_quit (symbol, + BVAR (XBUFFER (where), local_var_alist)); set_blv_where (blv, where); - blv->found = 1; + blv->found = true; if (NILP (tem1)) { @@ -1381,7 +1698,7 @@ set_internal (Lisp_Object symbol, Lisp_Object newval, Lisp_Object where, if (bindflag || !blv->local_if_set || let_shadows_buffer_binding_p (sym)) { - blv->found = 0; + blv->found = false; tem1 = blv->defcell; } /* If it's a local_if_set, being set not bound, @@ -1405,12 +1722,12 @@ set_internal (Lisp_Object symbol, Lisp_Object newval, Lisp_Object where, /* Store the new value in the cons cell. */ set_blv_value (blv, newval); - if (blv->fwd) + if (blv->fwd.fwdptr) { if (voide) /* If storing void (making the symbol void), forward only through buffer-local indicator, not through Lisp_Objfwd, etc. */ - blv->fwd = NULL; + blv->fwd.fwdptr = NULL; else store_symval_forwarding (blv->fwd, newval, BUFFERP (where) @@ -1422,21 +1739,25 @@ set_internal (Lisp_Object symbol, Lisp_Object newval, Lisp_Object where, { struct buffer *buf = BUFFERP (where) ? XBUFFER (where) : current_buffer; - union Lisp_Fwd *innercontents = SYMBOL_FWD (sym); + lispfwd innercontents = SYMBOL_FWD (sym); if (BUFFER_OBJFWDP (innercontents)) { int offset = XBUFFER_OBJFWD (innercontents)->offset; int idx = PER_BUFFER_IDX (offset); - if (idx > 0 - && bindflag == SET_INTERNAL_SET - && !let_shadows_buffer_binding_p (sym)) - SET_PER_BUFFER_VALUE_P (buf, idx, 1); + if (idx > 0 && bindflag == SET_INTERNAL_SET + && !PER_BUFFER_VALUE_P (buf, idx)) + { + if (let_shadows_buffer_binding_p (sym)) + set_default_internal (symbol, newval, bindflag); + else + SET_PER_BUFFER_VALUE_P (buf, idx, 1); + } } if (voide) { /* If storing void (making the symbol void), forward only through buffer-local indicator, not through Lisp_Objfwd, etc. */ - sym->redirect = SYMBOL_PLAINVAL; + sym->u.s.redirect = SYMBOL_PLAINVAL; SET_SYMBOL_VAL (sym, newval); } else @@ -1452,9 +1773,9 @@ static void set_symbol_trapped_write (Lisp_Object symbol, enum symbol_trapped_write trap) { struct Lisp_Symbol *sym = XSYMBOL (symbol); - if (sym->trapped_write == SYMBOL_NOWRITE) + if (sym->u.s.trapped_write == SYMBOL_NOWRITE) xsignal1 (Qtrapping_constant, symbol); - sym->trapped_write = trap; + sym->u.s.trapped_write = trap; } static void @@ -1469,25 +1790,27 @@ harmonize_variable_watchers (Lisp_Object alias, Lisp_Object base_variable) if (!EQ (base_variable, alias) && EQ (base_variable, Findirect_variable (alias))) set_symbol_trapped_write - (alias, XSYMBOL (base_variable)->trapped_write); + (alias, XSYMBOL (base_variable)->u.s.trapped_write); } DEFUN ("add-variable-watcher", Fadd_variable_watcher, Sadd_variable_watcher, 2, 2, 0, - doc: /* Cause WATCH-FUNCTION to be called when SYMBOL is set. + doc: /* Cause WATCH-FUNCTION to be called when SYMBOL is about to be set. It will be called with 4 arguments: (SYMBOL NEWVAL OPERATION WHERE). SYMBOL is the variable being changed. -NEWVAL is the value it will be changed to. +NEWVAL is the value it will be changed to. (The variable still has +the old value when WATCH-FUNCTION is called.) OPERATION is a symbol representing the kind of change, one of: `set', `let', `unlet', `makunbound', and `defvaralias'. -WHERE is a buffer if the buffer-local value of the variable being +WHERE is a buffer if the buffer-local value of the variable is being changed, nil otherwise. All writes to aliases of SYMBOL will call WATCH-FUNCTION too. */) (Lisp_Object symbol, Lisp_Object watch_function) { symbol = Findirect_variable (symbol); + CHECK_SYMBOL (symbol); set_symbol_trapped_write (symbol, SYMBOL_TRAPPED_WRITE); map_obarray (Vobarray, harmonize_variable_watchers, symbol); @@ -1535,7 +1858,7 @@ notify_variable_watchers (Lisp_Object symbol, { symbol = Findirect_variable (symbol); - ptrdiff_t count = SPECPDL_INDEX (); + specpdl_ref count = SPECPDL_INDEX (); record_unwind_protect (restore_symbol_trapped_write, symbol); /* Avoid recursion. */ set_symbol_trapped_write (symbol, SYMBOL_UNTRAPPED_WRITE); @@ -1574,7 +1897,7 @@ notify_variable_watchers (Lisp_Object symbol, /* Return the default value of SYMBOL, but don't check for voidness. Return Qunbound if it is void. */ -static Lisp_Object +Lisp_Object default_value (Lisp_Object symbol) { struct Lisp_Symbol *sym; @@ -1583,7 +1906,7 @@ default_value (Lisp_Object symbol) sym = XSYMBOL (symbol); start: - switch (sym->redirect) + switch (sym->u.s.redirect) { case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start; case SYMBOL_PLAINVAL: return SYMBOL_VAL (sym); @@ -1594,14 +1917,14 @@ default_value (Lisp_Object symbol) But the `realvalue' slot may be more up to date, since ordinary setq stores just that slot. So use that. */ struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym); - if (blv->fwd && EQ (blv->valcell, blv->defcell)) + if (blv->fwd.fwdptr && EQ (blv->valcell, blv->defcell)) return do_symval_forwarding (blv->fwd); else return XCDR (blv->defcell); } case SYMBOL_FORWARDED: { - union Lisp_Fwd *valcontents = SYMBOL_FWD (sym); + lispfwd valcontents = SYMBOL_FWD (sym); /* For a built-in buffer-local variable, get the default value rather than letting do_symval_forwarding get the current value. */ @@ -1621,14 +1944,15 @@ default_value (Lisp_Object symbol) DEFUN ("default-boundp", Fdefault_boundp, Sdefault_boundp, 1, 1, 0, doc: /* Return t if SYMBOL has a non-void default value. -This is the value that is seen in buffers that do not have their own values -for this variable. */) +A variable may have a buffer-local value. This function says whether +the variable has a non-void value outside of the current buffer +context. Also see `default-value'. */) (Lisp_Object symbol) { register Lisp_Object value; value = default_value (symbol); - return (EQ (value, Qunbound) ? Qnil : Qt); + return (BASE_EQ (value, Qunbound) ? Qnil : Qt); } DEFUN ("default-value", Fdefault_value, Sdefault_value, 1, 1, 0, @@ -1639,7 +1963,7 @@ local bindings in certain buffers. */) (Lisp_Object symbol) { Lisp_Object value = default_value (symbol); - if (!EQ (value, Qunbound)) + if (!BASE_EQ (value, Qunbound)) return value; xsignal1 (Qvoid_variable, symbol); @@ -1649,11 +1973,9 @@ void set_default_internal (Lisp_Object symbol, Lisp_Object value, enum Set_Internal_Bind bindflag) { - struct Lisp_Symbol *sym; - CHECK_SYMBOL (symbol); - sym = XSYMBOL (symbol); - switch (sym->trapped_write) + struct Lisp_Symbol *sym = XSYMBOL (symbol); + switch (sym->u.s.trapped_write) { case SYMBOL_NOWRITE: if (NILP (Fkeywordp (symbol)) @@ -1665,19 +1987,20 @@ set_default_internal (Lisp_Object symbol, Lisp_Object value, case SYMBOL_TRAPPED_WRITE: /* Don't notify here if we're going to call Fset anyway. */ - if (sym->redirect != SYMBOL_PLAINVAL + if (sym->u.s.redirect != SYMBOL_PLAINVAL /* Setting due to thread switching doesn't count. */ && bindflag != SET_INTERNAL_THREAD_SWITCH) notify_variable_watchers (symbol, value, Qset_default, Qnil); - /* FALLTHROUGH! */ + break; + case SYMBOL_UNTRAPPED_WRITE: - break; + break; default: emacs_abort (); } start: - switch (sym->redirect) + switch (sym->u.s.redirect) { case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start; case SYMBOL_PLAINVAL: set_internal (symbol, value, Qnil, bindflag); return; @@ -1689,13 +2012,13 @@ set_default_internal (Lisp_Object symbol, Lisp_Object value, XSETCDR (blv->defcell, value); /* If the default binding is now loaded, set the REALVALUE slot too. */ - if (blv->fwd && EQ (blv->defcell, blv->valcell)) + if (blv->fwd.fwdptr && EQ (blv->defcell, blv->valcell)) store_symval_forwarding (blv->fwd, value, NULL); return; } case SYMBOL_FORWARDED: { - union Lisp_Fwd *valcontents = SYMBOL_FWD (sym); + lispfwd valcontents = SYMBOL_FWD (sym); /* Handle variables like case-fold-search that have special slots in the buffer. @@ -1711,11 +2034,21 @@ set_default_internal (Lisp_Object symbol, Lisp_Object value, set it in the buffers that don't nominally have a local value. */ if (idx > 0) { - struct buffer *b; + Lisp_Object buf, tail; + + /* Do this only in live buffers, so that if there are + a lot of buffers which are dead, that doesn't slow + down let-binding of variables that are + automatically local when set, like + case-fold-search. This is for Lisp programs that + let-bind such variables in their inner loops. */ + FOR_EACH_LIVE_BUFFER (tail, buf) + { + struct buffer *b = XBUFFER (buf); - FOR_EACH_BUFFER (b) - if (!PER_BUFFER_VALUE_P (b, idx)) - set_per_buffer_value (b, offset, value); + if (!PER_BUFFER_VALUE_P (b, idx)) + set_per_buffer_value (b, offset, value); + } } } else @@ -1735,43 +2068,13 @@ for this variable. */) set_default_internal (symbol, value, SET_INTERNAL_SET); return value; } - -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; - - args_left = val = 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)); - } - - return val; -} /* Lisp functions for creating and removing buffer-local variables. */ union Lisp_Val_Fwd { Lisp_Object value; - union Lisp_Fwd *fwd; + lispfwd fwd; }; static struct Lisp_Buffer_Local_Value * @@ -1791,12 +2094,16 @@ make_blv (struct Lisp_Symbol *sym, bool forwarded, or keyboard-local forwarding. */ eassert (!(forwarded && BUFFER_OBJFWDP (valcontents.fwd))); eassert (!(forwarded && KBOARD_OBJFWDP (valcontents.fwd))); - blv->fwd = forwarded ? valcontents.fwd : NULL; + if (forwarded) + blv->fwd = valcontents.fwd; + else + blv->fwd.fwdptr = NULL; set_blv_where (blv, Qnil); blv->local_if_set = 0; set_blv_defcell (blv, tem); set_blv_valcell (blv, tem); - set_blv_found (blv, 0); + set_blv_found (blv, false); + __lsan_ignore_object (blv); return blv; } @@ -1817,24 +2124,26 @@ a variable local to the current buffer for one particular use, use 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. */) +The function `default-value' gets the default value and `set-default' sets it. + +See also `defvar-local'. */) (register Lisp_Object variable) { struct Lisp_Symbol *sym; struct Lisp_Buffer_Local_Value *blv = NULL; - union Lisp_Val_Fwd valcontents; + union Lisp_Val_Fwd valcontents UNINIT; bool forwarded UNINIT; CHECK_SYMBOL (variable); sym = XSYMBOL (variable); start: - switch (sym->redirect) + switch (sym->u.s.redirect) { case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start; case SYMBOL_PLAINVAL: forwarded = 0; valcontents.value = SYMBOL_VAL (sym); - if (EQ (valcontents.value, Qunbound)) + if (BASE_EQ (valcontents.value, Qunbound)) valcontents.value = Qnil; break; case SYMBOL_LOCALIZED: @@ -1852,12 +2161,12 @@ The function `default-value' gets the default value and `set-default' sets it. } if (SYMBOL_CONSTANT_P (variable)) - error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable))); + xsignal1 (Qsetting_constant, variable); if (!blv) { blv = make_blv (sym, forwarded, valcontents); - sym->redirect = SYMBOL_LOCALIZED; + sym->u.s.redirect = SYMBOL_LOCALIZED; SET_SYMBOL_BLV (sym, blv); } @@ -1888,8 +2197,8 @@ Instead, use `add-hook' and specify t for the LOCAL argument. */) (Lisp_Object variable) { Lisp_Object tem; - bool forwarded; - union Lisp_Val_Fwd valcontents; + bool forwarded UNINIT; + union Lisp_Val_Fwd valcontents UNINIT; struct Lisp_Symbol *sym; struct Lisp_Buffer_Local_Value *blv = NULL; @@ -1897,7 +2206,7 @@ Instead, use `add-hook' and specify t for the LOCAL argument. */) sym = XSYMBOL (variable); start: - switch (sym->redirect) + switch (sym->u.s.redirect) { case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start; case SYMBOL_PLAINVAL: @@ -1914,9 +2223,8 @@ Instead, use `add-hook' and specify t for the LOCAL argument. */) default: emacs_abort (); } - if (sym->trapped_write == SYMBOL_NOWRITE) - error ("Symbol %s may not be buffer-local", - SDATA (SYMBOL_NAME (variable))); + if (sym->u.s.trapped_write == SYMBOL_NOWRITE) + xsignal1 (Qsetting_constant, variable); if (blv ? blv->local_if_set : (forwarded && BUFFER_OBJFWDP (valcontents.fwd))) @@ -1930,13 +2238,13 @@ Instead, use `add-hook' and specify t for the LOCAL argument. */) if (!blv) { blv = make_blv (sym, forwarded, valcontents); - sym->redirect = SYMBOL_LOCALIZED; + sym->u.s.redirect = SYMBOL_LOCALIZED; SET_SYMBOL_BLV (sym, blv); } /* Make sure this buffer has its own value of symbol. */ XSETSYMBOL (variable, sym); /* Update in case of aliasing. */ - tem = Fassq (variable, BVAR (current_buffer, local_var_alist)); + tem = assq_no_quit (variable, BVAR (current_buffer, local_var_alist)); if (NILP (tem)) { if (let_shadows_buffer_binding_p (sym)) @@ -1946,30 +2254,27 @@ Instead, use `add-hook' and specify t for the LOCAL argument. */) CALLN (Fmessage, format, SYMBOL_NAME (variable)); } - /* Swap out any local binding for some other buffer, and make - sure the current value is permanently recorded, if it's the - default value. */ - find_symbol_value (variable); + if (BUFFERP (blv->where) && current_buffer == XBUFFER (blv->where)) + /* Make sure the current value is permanently recorded, if it's the + default value. */ + swap_in_global_binding (sym); bset_local_var_alist (current_buffer, Fcons (Fcons (variable, XCDR (blv->defcell)), BVAR (current_buffer, local_var_alist))); - /* Make sure symbol does not think it is set up for this buffer; - force it to look once again for this buffer's value. */ - if (current_buffer == XBUFFER (blv->where)) - set_blv_where (blv, Qnil); - set_blv_found (blv, 0); + /* If the symbol forwards into a C variable, then load the binding + for this buffer now, to preserve the invariant that forwarded + variables must always hold the value corresponding to the + current buffer (they are swapped eagerly). + Otherwise, if C code modifies the variable before we load the + binding in, then that new value would clobber the default binding + the next time we unload it. See bug#34318. */ + if (blv->fwd.fwdptr) + swap_in_symval_forwarding (sym, blv); } - /* If the symbol forwards into a C variable, then load the binding - for this buffer now. If C code modifies the variable before we - load the binding in, then that new value will clobber the default - binding the next time we unload it. */ - if (blv->fwd) - swap_in_symval_forwarding (sym, blv); - return variable; } @@ -1987,13 +2292,13 @@ From now on the default value will apply in this buffer. Return VARIABLE. */) sym = XSYMBOL (variable); start: - switch (sym->redirect) + switch (sym->u.s.redirect) { case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start; case SYMBOL_PLAINVAL: return variable; case SYMBOL_FORWARDED: { - union Lisp_Fwd *valcontents = SYMBOL_FWD (sym); + lispfwd valcontents = SYMBOL_FWD (sym); if (BUFFER_OBJFWDP (valcontents)) { int offset = XBUFFER_OBJFWD (valcontents)->offset; @@ -2014,12 +2319,12 @@ From now on the default value will apply in this buffer. Return VARIABLE. */) default: emacs_abort (); } - if (sym->trapped_write == SYMBOL_TRAPPED_WRITE) + if (sym->u.s.trapped_write == SYMBOL_TRAPPED_WRITE) notify_variable_watchers (variable, Qnil, Qmakunbound, Fcurrent_buffer ()); /* Get rid of this buffer's alist element, if any. */ XSETSYMBOL (variable, sym); /* Propagate variable indirection. */ - tem = Fassq (variable, BVAR (current_buffer, local_var_alist)); + tem = assq_no_quit (variable, BVAR (current_buffer, local_var_alist)); if (!NILP (tem)) bset_local_var_alist (current_buffer, @@ -2030,12 +2335,8 @@ From now on the default value will apply in this buffer. Return VARIABLE. */) forwarded objects won't work right. */ { Lisp_Object buf; XSETBUFFER (buf, current_buffer); - if (EQ (buf, blv->where)) - { - set_blv_where (blv, Qnil); - blv->found = 0; - find_symbol_value (variable); - } + if (BASE_EQ (buf, blv->where)) + swap_in_global_binding (sym); } return variable; @@ -2046,7 +2347,9 @@ From now on the default value will apply in this buffer. Return VARIABLE. */) 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. */) +BUFFER defaults to the current buffer. + +Also see `buffer-local-boundp'.*/) (Lisp_Object variable, Lisp_Object buffer) { struct buffer *buf = decode_buffer (buffer); @@ -2056,13 +2359,13 @@ BUFFER defaults to the current buffer. */) sym = XSYMBOL (variable); start: - switch (sym->redirect) + switch (sym->u.s.redirect) { case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start; case SYMBOL_PLAINVAL: return Qnil; case SYMBOL_LOCALIZED: { - Lisp_Object tail, elt, tmp; + Lisp_Object tmp; struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym); XSETBUFFER (tmp, buf); XSETSYMBOL (variable, sym); /* Update in case of aliasing. */ @@ -2070,17 +2373,13 @@ BUFFER defaults to the current buffer. */) 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))) - return Qt; - } - return Qnil; + return NILP (assq_no_quit (variable, BVAR (buf, local_var_alist))) + ? Qnil + : Qt; } case SYMBOL_FORWARDED: { - union Lisp_Fwd *valcontents = SYMBOL_FWD (sym); + lispfwd valcontents = SYMBOL_FWD (sym); if (BUFFER_OBJFWDP (valcontents)) { int offset = XBUFFER_OBJFWD (valcontents)->offset; @@ -2110,7 +2409,7 @@ value in BUFFER, or if VARIABLE is automatically buffer-local (see sym = XSYMBOL (variable); start: - switch (sym->redirect) + switch (sym->u.s.redirect) { case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start; case SYMBOL_PLAINVAL: return Qnil; @@ -2145,13 +2444,13 @@ If the current binding is global (the default), the value is nil. */) find_symbol_value (variable); start: - switch (sym->redirect) + switch (sym->u.s.redirect) { case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start; case SYMBOL_PLAINVAL: return Qnil; case SYMBOL_FORWARDED: { - union Lisp_Fwd *valcontents = SYMBOL_FWD (sym); + lispfwd valcontents = SYMBOL_FWD (sym); if (KBOARD_OBJFWDP (valcontents)) return Fframe_terminal (selected_frame); else if (!BUFFER_OBJFWDP (valcontents)) @@ -2163,7 +2462,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 (sym->u.s.redirect == SYMBOL_LOCALIZED && blv_found (SYMBOL_BLV (sym))) return SYMBOL_BLV (sym)->where; else @@ -2172,47 +2471,6 @@ If the current binding is global (the default), the value is nil. */) } } -/* This code is disabled now that we use the selected frame to return - keyboard-local-values. */ -#if 0 -extern struct terminal *get_terminal (Lisp_Object display, int); - -DEFUN ("terminal-local-value", Fterminal_local_value, - Sterminal_local_value, 2, 2, 0, - doc: /* Return the terminal-local value of SYMBOL on TERMINAL. -If SYMBOL is not a terminal-local variable, then return its normal -value, like `symbol-value'. - -TERMINAL may be a terminal object, a frame, or nil (meaning the -selected frame's terminal device). */) - (Lisp_Object symbol, Lisp_Object terminal) -{ - Lisp_Object result; - struct terminal *t = get_terminal (terminal, 1); - push_kboard (t->kboard); - result = Fsymbol_value (symbol); - pop_kboard (); - return result; -} - -DEFUN ("set-terminal-local-value", Fset_terminal_local_value, - Sset_terminal_local_value, 3, 3, 0, - doc: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE. -If VARIABLE is not a terminal-local variable, then set its normal -binding, like `set'. - -TERMINAL may be a terminal object, a frame, or nil (meaning the -selected frame's terminal device). */) - (Lisp_Object symbol, Lisp_Object terminal, Lisp_Object value) -{ - Lisp_Object result; - struct terminal *t = get_terminal (terminal, 1); - push_kboard (d->kboard); - result = Fset (symbol, value); - pop_kboard (); - return result; -} -#endif /* Find the function at the end of a chain of symbol function indirections. */ @@ -2234,12 +2492,12 @@ indirect_function (register Lisp_Object object) { if (!SYMBOLP (hare) || NILP (hare)) break; - hare = XSYMBOL (hare)->function; + hare = XSYMBOL (hare)->u.s.function; if (!SYMBOLP (hare) || NILP (hare)) break; - hare = XSYMBOL (hare)->function; + hare = XSYMBOL (hare)->u.s.function; - tortoise = XSYMBOL (tortoise)->function; + tortoise = XSYMBOL (tortoise)->u.s.function; if (EQ (hare, tortoise)) xsignal1 (Qcyclic_function_indirection, object); @@ -2261,7 +2519,7 @@ function chain of symbols. */) /* Optimize for no indirection. */ result = object; if (SYMBOLP (result) && !NILP (result) - && (result = XSYMBOL (result)->function, SYMBOLP (result))) + && (result = XSYMBOL (result)->u.s.function, SYMBOLP (result))) result = indirect_function (result); if (!NILP (result)) return result; @@ -2272,15 +2530,15 @@ function chain of symbols. */) /* Extract and set vector and string elements. */ DEFUN ("aref", Faref, Saref, 2, 2, 0, - doc: /* Return the element of ARG at index IDX. -ARG may be a vector, a string, a char-table, a bool-vector, a record, + doc: /* Return the element of ARRAY at index IDX. +ARRAY may be a vector, a string, a char-table, a bool-vector, a record, or a byte-code object. IDX starts at 0. */) (register Lisp_Object array, Lisp_Object idx) { register EMACS_INT idxval; - CHECK_NUMBER (idx); - idxval = XINT (idx); + CHECK_FIXNUM (idx); + idxval = XFIXNUM (idx); if (STRINGP (array)) { int c; @@ -2289,11 +2547,11 @@ or a byte-code object. IDX starts at 0. */) if (idxval < 0 || idxval >= SCHARS (array)) args_out_of_range (array, idx); if (! STRING_MULTIBYTE (array)) - return make_number ((unsigned char) SREF (array, idxval)); + return make_fixnum ((unsigned char) SREF (array, idxval)); idxval_byte = string_char_to_byte (array, idxval); c = STRING_CHAR (SDATA (array) + idxval_byte); - return make_number (c); + return make_fixnum (c); } else if (BOOL_VECTOR_P (array)) { @@ -2330,8 +2588,8 @@ bool-vector. IDX starts at 0. */) { register EMACS_INT idxval; - CHECK_NUMBER (idx); - idxval = XINT (idx); + CHECK_FIXNUM (idx); + idxval = XFIXNUM (idx); if (! RECORDP (array)) CHECK_ARRAY (array, Qarrayp); @@ -2361,61 +2619,45 @@ bool-vector. IDX starts at 0. */) } else /* STRINGP */ { - int c; - CHECK_IMPURE (array, XSTRING (array)); if (idxval < 0 || idxval >= SCHARS (array)) args_out_of_range (array, idx); CHECK_CHARACTER (newelt); - c = XFASTINT (newelt); + int c = XFIXNAT (newelt); + ptrdiff_t idxval_byte; + int prev_bytes; + unsigned char workbuf[MAX_MULTIBYTE_LENGTH], *p0 = workbuf, *p1; if (STRING_MULTIBYTE (array)) { - ptrdiff_t idxval_byte, nbytes; - int prev_bytes, new_bytes; - unsigned char workbuf[MAX_MULTIBYTE_LENGTH], *p0 = workbuf, *p1; - - nbytes = SBYTES (array); idxval_byte = string_char_to_byte (array, idxval); p1 = SDATA (array) + idxval_byte; prev_bytes = BYTES_BY_CHAR_HEAD (*p1); - new_bytes = CHAR_STRING (c, p0); - if (prev_bytes != new_bytes) - { - /* We must relocate the string data. */ - ptrdiff_t nchars = SCHARS (array); - USE_SAFE_ALLOCA; - unsigned char *str = SAFE_ALLOCA (nbytes); - - memcpy (str, SDATA (array), nbytes); - allocate_string_data (XSTRING (array), nchars, - nbytes + new_bytes - prev_bytes); - memcpy (SDATA (array), str, idxval_byte); - p1 = SDATA (array) + idxval_byte; - memcpy (p1 + new_bytes, str + idxval_byte + prev_bytes, - nbytes - (idxval_byte + prev_bytes)); - SAFE_FREE (); - clear_string_char_byte_cache (); - } - while (new_bytes--) - *p1++ = *p0++; } - else + else if (SINGLE_BYTE_CHAR_P (c)) { - if (! SINGLE_BYTE_CHAR_P (c)) - { - ptrdiff_t i; - - for (i = SBYTES (array) - 1; i >= 0; i--) - if (SREF (array, i) >= 0x80) - args_out_of_range (array, newelt); - /* ARRAY is an ASCII string. Convert it to a multibyte - string, and try `aset' again. */ - STRING_SET_MULTIBYTE (array); - return Faset (array, idx, newelt); - } SSET (array, idxval, c); + return newelt; + } + else + { + for (ptrdiff_t i = SBYTES (array) - 1; i >= 0; i--) + if (!ASCII_CHAR_P (SREF (array, i))) + args_out_of_range (array, newelt); + /* ARRAY is an ASCII string. Convert it to a multibyte string. */ + STRING_SET_MULTIBYTE (array); + idxval_byte = idxval; + p1 = SDATA (array) + idxval_byte; + prev_bytes = 1; } + + int new_bytes = CHAR_STRING (c, p0); + if (prev_bytes != new_bytes) + p1 = resize_string_data (array, idxval_byte, prev_bytes, new_bytes); + + do + *p1++ = *p0++; + while (--new_bytes != 0); } return newelt; @@ -2423,34 +2665,55 @@ bool-vector. IDX starts at 0. */) /* Arithmetic functions */ +static Lisp_Object +check_integer_coerce_marker (Lisp_Object x) +{ + if (MARKERP (x)) + return make_fixnum (marker_position (x)); + CHECK_TYPE (INTEGERP (x), Qinteger_or_marker_p, x); + return x; +} + +static Lisp_Object +check_number_coerce_marker (Lisp_Object x) +{ + if (MARKERP (x)) + return make_fixnum (marker_position (x)); + CHECK_TYPE (NUMBERP (x), Qnumber_or_marker_p, x); + return x; +} + Lisp_Object arithcompare (Lisp_Object num1, Lisp_Object num2, enum Arith_Comparison comparison) { - double f1, f2; - EMACS_INT i1, i2; - bool fneq; + EMACS_INT i1 = 0, i2 = 0; + bool lt, eq = true, gt; bool test; - CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1); - CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2); + num1 = check_number_coerce_marker (num1); + num2 = check_number_coerce_marker (num2); - /* If either arg is floating point, set F1 and F2 to the 'double' - approximations of the two arguments, and set FNEQ if floating-point - comparison reports that F1 is not equal to F2, possibly because F1 - or F2 is a NaN. Regardless, set I1 and I2 to integers that break - ties if the floating-point comparison is either not done or reports + /* If the comparison is mostly done by comparing two doubles, + set LT, EQ, and GT to the <, ==, > results of that comparison, + respectively, taking care to avoid problems if either is a NaN, + and trying to avoid problems on platforms where variables (in + violation of the C standard) can contain excess precision. + Regardless, set I1 and I2 to integers that break ties if the + two-double comparison is either not done or reports equality. */ if (FLOATP (num1)) { - f1 = XFLOAT_DATA (num1); + double f1 = XFLOAT_DATA (num1); if (FLOATP (num2)) { - i1 = i2 = 0; - f2 = XFLOAT_DATA (num2); + double f2 = XFLOAT_DATA (num2); + lt = f1 < f2; + eq = f1 == f2; + gt = f1 > f2; } - else + else if (FIXNUMP (num2)) { /* Compare a float NUM1 to an integer NUM2 by converting the integer I2 (i.e., NUM2) to the double F2 (a conversion that @@ -2460,52 +2723,85 @@ arithcompare (Lisp_Object num1, Lisp_Object num2, floating-point comparison reports a tie, NUM1 = F1 = F2 = I1 (exactly) so I1 - I2 = NUM1 - NUM2 (exactly), so comparing I1 to I2 will break the tie correctly. */ - i1 = f2 = i2 = XINT (num2); + double f2 = XFIXNUM (num2); + lt = f1 < f2; + eq = f1 == f2; + gt = f1 > f2; + i1 = f2; + i2 = XFIXNUM (num2); } - fneq = f1 != f2; + else if (isnan (f1)) + lt = eq = gt = false; + else + i2 = mpz_cmp_d (*xbignum_val (num2), f1); } - else + else if (FIXNUMP (num1)) { - i1 = XINT (num1); if (FLOATP (num2)) { /* Compare an integer NUM1 to a float NUM2. This is the converse of comparing float to integer (see above). */ - i2 = f1 = i1; - f2 = XFLOAT_DATA (num2); - fneq = f1 != f2; + double f1 = XFIXNUM (num1), f2 = XFLOAT_DATA (num2); + lt = f1 < f2; + eq = f1 == f2; + gt = f1 > f2; + i1 = XFIXNUM (num1); + i2 = f1; } - else + else if (FIXNUMP (num2)) { - i2 = XINT (num2); - fneq = false; + i1 = XFIXNUM (num1); + i2 = XFIXNUM (num2); } + else + i2 = mpz_sgn (*xbignum_val (num2)); + } + else if (FLOATP (num2)) + { + double f2 = XFLOAT_DATA (num2); + if (isnan (f2)) + lt = eq = gt = false; + else + i1 = mpz_cmp_d (*xbignum_val (num1), f2); + } + else if (FIXNUMP (num2)) + i1 = mpz_sgn (*xbignum_val (num1)); + else + i1 = mpz_cmp (*xbignum_val (num1), *xbignum_val (num2)); + + if (eq) + { + /* The two-double comparison either reported equality, or was not done. + Break the tie by comparing the integers. */ + lt = i1 < i2; + eq = i1 == i2; + gt = i1 > i2; } switch (comparison) { case ARITH_EQUAL: - test = !fneq && i1 == i2; + test = eq; break; case ARITH_NOTEQUAL: - test = fneq || i1 != i2; + test = !eq; break; case ARITH_LESS: - test = fneq ? f1 < f2 : i1 < i2; + test = lt; break; case ARITH_LESS_OR_EQUAL: - test = fneq ? f1 <= f2 : i1 <= i2; + test = lt | eq; break; case ARITH_GRTR: - test = fneq ? f1 > f2 : i1 > i2; + test = gt; break; case ARITH_GRTR_OR_EQUAL: - test = fneq ? f1 >= f2 : i1 >= i2; + test = gt | eq; break; default: @@ -2538,6 +2834,9 @@ DEFUN ("<", Flss, Slss, 1, MANY, 0, usage: (< NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */) (ptrdiff_t nargs, Lisp_Object *args) { + if (nargs == 2 && FIXNUMP (args[0]) && FIXNUMP (args[1])) + return XFIXNUM (args[0]) < XFIXNUM (args[1]) ? Qt : Qnil; + return arithcompare_driver (nargs, args, ARITH_LESS); } @@ -2546,6 +2845,9 @@ DEFUN (">", Fgtr, Sgtr, 1, MANY, 0, usage: (> NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */) (ptrdiff_t nargs, Lisp_Object *args) { + if (nargs == 2 && FIXNUMP (args[0]) && FIXNUMP (args[1])) + return XFIXNUM (args[0]) > XFIXNUM (args[1]) ? Qt : Qnil; + return arithcompare_driver (nargs, args, ARITH_GRTR); } @@ -2554,6 +2856,9 @@ DEFUN ("<=", Fleq, Sleq, 1, MANY, 0, usage: (<= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */) (ptrdiff_t nargs, Lisp_Object *args) { + if (nargs == 2 && FIXNUMP (args[0]) && FIXNUMP (args[1])) + return XFIXNUM (args[0]) <= XFIXNUM (args[1]) ? Qt : Qnil; + return arithcompare_driver (nargs, args, ARITH_LESS_OR_EQUAL); } @@ -2562,6 +2867,9 @@ DEFUN (">=", Fgeq, Sgeq, 1, MANY, 0, usage: (>= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */) (ptrdiff_t nargs, Lisp_Object *args) { + if (nargs == 2 && FIXNUMP (args[0]) && FIXNUMP (args[1])) + return XFIXNUM (args[0]) >= XFIXNUM (args[1]) ? Qt : Qnil; + return arithcompare_driver (nargs, args, ARITH_GRTR_OR_EQUAL); } @@ -2572,48 +2880,21 @@ DEFUN ("/=", Fneq, Sneq, 2, 2, 0, return arithcompare (num1, num2, ARITH_NOTEQUAL); } -/* Convert the integer I to a cons-of-integers, where I is not in - fixnum range. */ - -#define INTBIG_TO_LISP(i, extremum) \ - (eassert (FIXNUM_OVERFLOW_P (i)), \ - (! (FIXNUM_OVERFLOW_P ((extremum) >> 16) \ - && FIXNUM_OVERFLOW_P ((i) >> 16)) \ - ? Fcons (make_number ((i) >> 16), make_number ((i) & 0xffff)) \ - : ! (FIXNUM_OVERFLOW_P ((extremum) >> 16 >> 24) \ - && FIXNUM_OVERFLOW_P ((i) >> 16 >> 24)) \ - ? Fcons (make_number ((i) >> 16 >> 24), \ - Fcons (make_number ((i) >> 16 & 0xffffff), \ - make_number ((i) & 0xffff))) \ - : make_float (i))) - -Lisp_Object -intbig_to_lisp (intmax_t i) -{ - return INTBIG_TO_LISP (i, INTMAX_MIN); -} - -Lisp_Object -uintbig_to_lisp (uintmax_t i) -{ - return INTBIG_TO_LISP (i, UINTMAX_MAX); -} - /* Convert the cons-of-integers, integer, or float value C to an unsigned value with maximum value MAX, where MAX is one less than a power of 2. Signal an error if C does not have a valid format or - is out of range. */ + is out of range. + + Although Emacs represents large integers with bignums instead of + cons-of-integers or floats, for now this function still accepts the + obsolete forms in case some old Lisp code still generates them. */ uintmax_t cons_to_unsigned (Lisp_Object c, uintmax_t max) { bool valid = false; uintmax_t val UNINIT; - if (INTEGERP (c)) - { - valid = XINT (c) >= 0; - val = XINT (c); - } - else if (FLOATP (c)) + + if (FLOATP (c)) { double d = XFLOAT_DATA (c); if (d >= 0 && d < 1.0 + max) @@ -2622,27 +2903,34 @@ cons_to_unsigned (Lisp_Object c, uintmax_t max) valid = val == d; } } - else if (CONSP (c) && NATNUMP (XCAR (c))) + else { - uintmax_t top = XFASTINT (XCAR (c)); - Lisp_Object rest = XCDR (c); - if (top <= UINTMAX_MAX >> 24 >> 16 - && CONSP (rest) - && NATNUMP (XCAR (rest)) && XFASTINT (XCAR (rest)) < 1 << 24 - && NATNUMP (XCDR (rest)) && XFASTINT (XCDR (rest)) < 1 << 16) - { - uintmax_t mid = XFASTINT (XCAR (rest)); - val = top << 24 << 16 | mid << 16 | XFASTINT (XCDR (rest)); - valid = true; - } - else if (top <= UINTMAX_MAX >> 16) + Lisp_Object hi = CONSP (c) ? XCAR (c) : c; + valid = INTEGERP (hi) && integer_to_uintmax (hi, &val); + + if (valid && CONSP (c)) { - if (CONSP (rest)) - rest = XCAR (rest); - if (NATNUMP (rest) && XFASTINT (rest) < 1 << 16) + uintmax_t top = val; + Lisp_Object rest = XCDR (c); + if (top <= UINTMAX_MAX >> 24 >> 16 + && CONSP (rest) + && FIXNATP (XCAR (rest)) && XFIXNAT (XCAR (rest)) < 1 << 24 + && FIXNATP (XCDR (rest)) && XFIXNAT (XCDR (rest)) < 1 << 16) + { + uintmax_t mid = XFIXNAT (XCAR (rest)); + val = top << 24 << 16 | mid << 16 | XFIXNAT (XCDR (rest)); + } + else { - val = top << 16 | XFASTINT (rest); - valid = true; + valid = top <= UINTMAX_MAX >> 16; + if (valid) + { + if (CONSP (rest)) + rest = XCAR (rest); + valid = FIXNATP (rest) && XFIXNAT (rest) < 1 << 16; + if (valid) + val = top << 16 | XFIXNAT (rest); + } } } } @@ -2656,18 +2944,18 @@ cons_to_unsigned (Lisp_Object c, uintmax_t max) value with extrema MIN and MAX. MAX should be one less than a power of 2, and MIN should be zero or the negative of a power of 2. Signal an error if C does not have a valid format or is out of - range. */ + range. + + Although Emacs represents large integers with bignums instead of + cons-of-integers or floats, for now this function still accepts the + obsolete forms in case some old Lisp code still generates them. */ intmax_t cons_to_signed (Lisp_Object c, intmax_t min, intmax_t max) { bool valid = false; intmax_t val UNINIT; - if (INTEGERP (c)) - { - val = XINT (c); - valid = true; - } - else if (FLOATP (c)) + + if (FLOATP (c)) { double d = XFLOAT_DATA (c); if (d >= min && d < 1.0 + max) @@ -2676,27 +2964,34 @@ cons_to_signed (Lisp_Object c, intmax_t min, intmax_t max) valid = val == d; } } - else if (CONSP (c) && INTEGERP (XCAR (c))) + else { - intmax_t top = XINT (XCAR (c)); - Lisp_Object rest = XCDR (c); - if (top >= INTMAX_MIN >> 24 >> 16 && top <= INTMAX_MAX >> 24 >> 16 - && CONSP (rest) - && NATNUMP (XCAR (rest)) && XFASTINT (XCAR (rest)) < 1 << 24 - && NATNUMP (XCDR (rest)) && XFASTINT (XCDR (rest)) < 1 << 16) - { - intmax_t mid = XFASTINT (XCAR (rest)); - val = top << 24 << 16 | mid << 16 | XFASTINT (XCDR (rest)); - valid = true; - } - else if (top >= INTMAX_MIN >> 16 && top <= INTMAX_MAX >> 16) + Lisp_Object hi = CONSP (c) ? XCAR (c) : c; + valid = INTEGERP (hi) && integer_to_intmax (hi, &val); + + if (valid && CONSP (c)) { - if (CONSP (rest)) - rest = XCAR (rest); - if (NATNUMP (rest) && XFASTINT (rest) < 1 << 16) + intmax_t top = val; + Lisp_Object rest = XCDR (c); + if (top >= INTMAX_MIN >> 24 >> 16 && top <= INTMAX_MAX >> 24 >> 16 + && CONSP (rest) + && FIXNATP (XCAR (rest)) && XFIXNAT (XCAR (rest)) < 1 << 24 + && FIXNATP (XCDR (rest)) && XFIXNAT (XCDR (rest)) < 1 << 16) { - val = top << 16 | XFASTINT (rest); - valid = true; + intmax_t mid = XFIXNAT (XCAR (rest)); + val = top << 24 << 16 | mid << 16 | XFIXNAT (XCDR (rest)); + } + else + { + valid = INTMAX_MIN >> 16 <= top && top <= INTMAX_MAX >> 16; + if (valid) + { + if (CONSP (rest)) + rest = XCAR (rest); + valid = FIXNATP (rest) && XFIXNAT (rest) < 1 << 16; + if (valid) + val = top << 16 | XFIXNAT (rest); + } } } } @@ -2706,6 +3001,29 @@ cons_to_signed (Lisp_Object c, intmax_t min, intmax_t max) return val; } +/* Render NUMBER in decimal into BUFFER which ends right before END. + Return the start of the string; the end is always at END. + The string is not null-terminated. */ +char * +fixnum_to_string (EMACS_INT number, char *buffer, char *end) +{ + EMACS_INT x = number; + bool negative = x < 0; + if (negative) + x = -x; + char *p = end; + do + { + eassume (p > buffer && p - 1 < end); + *--p = '0' + x % 10; + x /= 10; + } + while (x); + if (negative) + *--p = '-'; + return p; +} + DEFUN ("number-to-string", Fnumber_to_string, Snumber_to_string, 1, 1, 0, doc: /* Return the decimal representation of NUMBER as a string. Uses a minus sign if negative. @@ -2713,16 +3031,22 @@ NUMBER may be an integer or a floating point number. */) (Lisp_Object number) { char buffer[max (FLOAT_TO_STRING_BUFSIZE, INT_BUFSIZE_BOUND (EMACS_INT))]; - int len; - CHECK_NUMBER_OR_FLOAT (number); + if (FIXNUMP (number)) + { + char *end = buffer + sizeof buffer; + char *p = fixnum_to_string (XFIXNUM (number), buffer, end); + return make_unibyte_string (p, end - p); + } + + if (BIGNUMP (number)) + return bignum_to_string (number, 10); if (FLOATP (number)) - len = float_to_string (buffer, XFLOAT_DATA (number)); - else - len = sprintf (buffer, "%"pI"d", XINT (number)); + return make_unibyte_string (buffer, + float_to_string (buffer, XFLOAT_DATA (number))); - return make_unibyte_string (buffer, len); + wrong_type_argument (Qnumberp, number); } DEFUN ("string-to-number", Fstring_to_number, Sstring_to_number, 1, 2, 0, @@ -2735,9 +3059,7 @@ 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 an integer. */) (register Lisp_Object string, Lisp_Object base) { - register char *p; - register int b; - Lisp_Object val; + int b; CHECK_STRING (string); @@ -2745,18 +3067,18 @@ If the base used is not 10, STRING is always parsed as an integer. */) b = 10; else { - CHECK_NUMBER (base); - if (! (XINT (base) >= 2 && XINT (base) <= 16)) + CHECK_FIXNUM (base); + if (! (XFIXNUM (base) >= 2 && XFIXNUM (base) <= 16)) xsignal1 (Qargs_out_of_range, base); - b = XINT (base); + b = XFIXNUM (base); } - p = SSDATA (string); + char *p = SSDATA (string); while (*p == ' ' || *p == '\t') p++; - val = string_to_number (p, b, 1); - return NILP (val) ? make_number (0) : val; + Lisp_Object val = string_to_number (p, b, 0); + return NILP (val) ? make_fixnum (0) : val; } enum arithop @@ -2769,151 +3091,175 @@ enum arithop Alogior, Alogxor }; +static bool +floating_point_op (enum arithop code) +{ + return code <= Adiv; +} + +/* Return the result of applying the floating-point operation CODE to + the NARGS arguments starting at ARGS. If ARGNUM is positive, + ARGNUM of the arguments were already consumed, yielding ACCUM. + 0 <= ARGNUM < NARGS, 2 <= NARGS, and NEXT is the value of + ARGS[ARGSNUM], converted to double. */ -static Lisp_Object float_arith_driver (double, ptrdiff_t, enum arithop, - ptrdiff_t, Lisp_Object *); static Lisp_Object -arith_driver (enum arithop code, ptrdiff_t nargs, Lisp_Object *args) +floatop_arith_driver (enum arithop code, ptrdiff_t nargs, Lisp_Object *args, + ptrdiff_t argnum, double accum, double next) { - Lisp_Object val; - ptrdiff_t argnum, ok_args; - EMACS_INT accum = 0; - EMACS_INT next, ok_accum; - bool overflow = 0; - - switch (code) - { - case Alogior: - case Alogxor: - case Aadd: - case Asub: - accum = 0; - break; - case Amult: - case Adiv: - accum = 1; - break; - case Alogand: - accum = -1; - break; - default: - break; + if (argnum == 0) + { + accum = next; + goto next_arg; } - for (argnum = 0; argnum < nargs; argnum++) + while (true) { - if (! overflow) - { - ok_args = argnum; - ok_accum = accum; - } - - /* Using args[argnum] as argument to CHECK_NUMBER_... */ - val = args[argnum]; - CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val); - - if (FLOATP (val)) - return float_arith_driver (ok_accum, ok_args, code, - nargs, args); - args[argnum] = val; - next = XINT (args[argnum]); switch (code) { - case Aadd: - overflow |= INT_ADD_WRAPV (accum, next, &accum); - break; - case Asub: - if (! argnum) - accum = nargs == 1 ? - next : next; - else - overflow |= INT_SUBTRACT_WRAPV (accum, next, &accum); - break; - case Amult: - overflow |= INT_MULTIPLY_WRAPV (accum, next, &accum); - break; + case Aadd : accum += next; break; + case Asub : accum -= next; break; + case Amult: accum *= next; break; case Adiv: - if (! (argnum || nargs == 1)) - accum = next; - else - { - if (next == 0) - xsignal0 (Qarith_error); - if (INT_DIVIDE_OVERFLOW (accum, next)) - overflow = true; - else - accum /= next; - } - break; - case Alogand: - accum &= next; - break; - case Alogior: - accum |= next; - break; - case Alogxor: - accum ^= next; + if (! IEEE_FLOATING_POINT && next == 0) + xsignal0 (Qarith_error); + accum /= next; break; + default: eassume (false); } + + next_arg: + argnum++; + if (argnum == nargs) + return make_float (accum); + next = XFLOATINT (check_number_coerce_marker (args[argnum])); } +} - XSETINT (val, accum); - return val; +/* Like floatop_arith_driver, except CODE might not be a floating-point + operation, and NEXT is a Lisp float rather than a C double. */ + +static Lisp_Object +float_arith_driver (enum arithop code, ptrdiff_t nargs, Lisp_Object *args, + ptrdiff_t argnum, double accum, Lisp_Object next) +{ + if (! floating_point_op (code)) + wrong_type_argument (Qinteger_or_marker_p, next); + return floatop_arith_driver (code, nargs, args, argnum, accum, + XFLOAT_DATA (next)); } -#ifndef isnan -# define isnan(x) ((x) != (x)) -#endif +/* Return the result of applying the arithmetic operation CODE to the + NARGS arguments starting at ARGS. If ARGNUM is positive, ARGNUM of + the arguments were already consumed, yielding IACCUM. 0 <= ARGNUM + < NARGS, 2 <= NARGS, and VAL is the value of ARGS[ARGSNUM], + converted to integer. */ static Lisp_Object -float_arith_driver (double accum, ptrdiff_t argnum, enum arithop code, - ptrdiff_t nargs, Lisp_Object *args) +bignum_arith_driver (enum arithop code, ptrdiff_t nargs, Lisp_Object *args, + ptrdiff_t argnum, intmax_t iaccum, Lisp_Object val) { - register Lisp_Object val; - double next; + mpz_t const *accum; + if (argnum == 0) + { + accum = bignum_integer (&mpz[0], val); + goto next_arg; + } + mpz_set_intmax (mpz[0], iaccum); + accum = &mpz[0]; - for (; argnum < nargs; argnum++) + while (true) { - val = args[argnum]; /* using args[argnum] as argument to CHECK_NUMBER_... */ - CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val); + mpz_t const *next = bignum_integer (&mpz[1], val); - if (FLOATP (val)) - { - next = XFLOAT_DATA (val); - } - else - { - args[argnum] = val; /* runs into a compiler bug. */ - next = XINT (args[argnum]); - } switch (code) { - case Aadd: - accum += next; - break; - case Asub: - accum = argnum ? accum - next : nargs == 1 ? - next : next; - break; - case Amult: - accum *= next; - break; + case Aadd : mpz_add (mpz[0], *accum, *next); break; + case Asub : mpz_sub (mpz[0], *accum, *next); break; + case Amult : emacs_mpz_mul (mpz[0], *accum, *next); break; + case Alogand: mpz_and (mpz[0], *accum, *next); break; + case Alogior: mpz_ior (mpz[0], *accum, *next); break; + case Alogxor: mpz_xor (mpz[0], *accum, *next); break; case Adiv: - if (! (argnum || nargs == 1)) - accum = next; - else - { - if (! IEEE_FLOATING_POINT && next == 0) - xsignal0 (Qarith_error); - accum /= next; - } + if (mpz_sgn (*next) == 0) + xsignal0 (Qarith_error); + mpz_tdiv_q (mpz[0], *accum, *next); break; - case Alogand: - case Alogior: - case Alogxor: - wrong_type_argument (Qinteger_or_marker_p, val); + default: + eassume (false); } + accum = &mpz[0]; + + next_arg: + argnum++; + if (argnum == nargs) + return make_integer_mpz (); + val = check_number_coerce_marker (args[argnum]); + if (FLOATP (val)) + return float_arith_driver (code, nargs, args, argnum, + mpz_get_d_rounded (*accum), val); } +} + +/* Return the result of applying the arithmetic operation CODE to the + NARGS arguments starting at ARGS, with the first argument being the + number VAL. 2 <= NARGS. Check that the remaining arguments are + numbers or markers. */ - return make_float (accum); +static Lisp_Object +arith_driver (enum arithop code, ptrdiff_t nargs, Lisp_Object *args, + Lisp_Object val) +{ + eassume (2 <= nargs); + + ptrdiff_t argnum = 0; + /* Set ACCUM to VAL's value if it is a fixnum, otherwise to some + ignored value to avoid using an uninitialized variable later. */ + intmax_t accum = XFIXNUM_RAW (val); + + if (FIXNUMP (val)) + while (true) + { + argnum++; + if (argnum == nargs) + return make_int (accum); + val = check_number_coerce_marker (args[argnum]); + + /* Set NEXT to the next value if it fits, else exit the loop. */ + intmax_t next; + if (! (INTEGERP (val) && integer_to_intmax (val, &next))) + break; + + /* Set ACCUM to the next operation's result if it fits, + else exit the loop. */ + bool overflow; + intmax_t a; + switch (code) + { + case Aadd : overflow = INT_ADD_WRAPV (accum, next, &a); break; + case Amult: overflow = INT_MULTIPLY_WRAPV (accum, next, &a); break; + case Asub : overflow = INT_SUBTRACT_WRAPV (accum, next, &a); break; + case Adiv: + if (next == 0) + xsignal0 (Qarith_error); + /* This cannot overflow, as integer overflow can + occur only if the dividend is INTMAX_MIN, but + INTMAX_MIN < MOST_NEGATIVE_FIXNUM <= accum. */ + accum /= next; + continue; + case Alogand: accum &= next; continue; + case Alogior: accum |= next; continue; + case Alogxor: accum ^= next; continue; + default: eassume (false); + } + if (overflow) + break; + accum = a; + } + + return (FLOATP (val) + ? float_arith_driver (code, nargs, args, argnum, accum, val) + : bignum_arith_driver (code, nargs, args, argnum, accum, val)); } @@ -2922,7 +3268,10 @@ DEFUN ("+", Fplus, Splus, 0, MANY, 0, usage: (+ &rest NUMBERS-OR-MARKERS) */) (ptrdiff_t nargs, Lisp_Object *args) { - return arith_driver (Aadd, nargs, args); + if (nargs == 0) + return make_fixnum (0); + Lisp_Object a = check_number_coerce_marker (args[0]); + return nargs == 1 ? a : arith_driver (Aadd, nargs, args, a); } DEFUN ("-", Fminus, Sminus, 0, MANY, 0, @@ -2932,7 +3281,19 @@ subtracts all but the first from the first. usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */) (ptrdiff_t nargs, Lisp_Object *args) { - return arith_driver (Asub, nargs, args); + if (nargs == 0) + return make_fixnum (0); + Lisp_Object a = check_number_coerce_marker (args[0]); + if (nargs == 1) + { + if (FIXNUMP (a)) + return make_int (-XFIXNUM (a)); + if (FLOATP (a)) + return make_float (-XFLOAT_DATA (a)); + mpz_neg (mpz[0], *xbignum_val (a)); + return make_integer_mpz (); + } + return arith_driver (Asub, nargs, args, a); } DEFUN ("*", Ftimes, Stimes, 0, MANY, 0, @@ -2940,7 +3301,10 @@ DEFUN ("*", Ftimes, Stimes, 0, MANY, 0, usage: (* &rest NUMBERS-OR-MARKERS) */) (ptrdiff_t nargs, Lisp_Object *args) { - return arith_driver (Amult, nargs, args); + if (nargs == 0) + return make_fixnum (1); + Lisp_Object a = check_number_coerce_marker (args[0]); + return nargs == 1 ? a : arith_driver (Amult, nargs, args, a); } DEFUN ("/", Fquo, Squo, 1, MANY, 0, @@ -2951,71 +3315,116 @@ The arguments must be numbers or markers. usage: (/ NUMBER &rest DIVISORS) */) (ptrdiff_t nargs, Lisp_Object *args) { - ptrdiff_t argnum; - for (argnum = 2; argnum < nargs; argnum++) + Lisp_Object a = check_number_coerce_marker (args[0]); + if (nargs == 1) + { + if (FIXNUMP (a)) + { + if (XFIXNUM (a) == 0) + xsignal0 (Qarith_error); + return make_fixnum (1 / XFIXNUM (a)); + } + if (FLOATP (a)) + { + if (! IEEE_FLOATING_POINT && XFLOAT_DATA (a) == 0) + xsignal0 (Qarith_error); + return make_float (1 / XFLOAT_DATA (a)); + } + /* Dividing 1 by any bignum yields 0. */ + return make_fixnum (0); + } + + /* Do all computation in floating-point if any arg is a float. */ + for (ptrdiff_t argnum = 2; argnum < nargs; argnum++) if (FLOATP (args[argnum])) - return float_arith_driver (0, 0, Adiv, nargs, args); - return arith_driver (Adiv, nargs, args); + return floatop_arith_driver (Adiv, nargs, args, 0, 0, XFLOATINT (a)); + return arith_driver (Adiv, nargs, args, a); } -DEFUN ("%", Frem, Srem, 2, 2, 0, - doc: /* Return remainder of X divided by Y. -Both must be integers or markers. */) - (register Lisp_Object x, Lisp_Object y) +/* Return NUM % DEN (or NUM mod DEN, if MODULO). NUM and DEN must be + integers. */ +static Lisp_Object +integer_remainder (Lisp_Object num, Lisp_Object den, bool modulo) { - Lisp_Object val; + if (FIXNUMP (den)) + { + EMACS_INT d = XFIXNUM (den); + if (d == 0) + xsignal0 (Qarith_error); - CHECK_NUMBER_COERCE_MARKER (x); - CHECK_NUMBER_COERCE_MARKER (y); + EMACS_INT r; + bool have_r = false; + if (FIXNUMP (num)) + { + r = XFIXNUM (num) % d; + have_r = true; + } + else if (eabs (d) <= ULONG_MAX) + { + mpz_t const *n = xbignum_val (num); + bool neg_n = mpz_sgn (*n) < 0; + r = mpz_tdiv_ui (*n, eabs (d)); + if (neg_n) + r = -r; + have_r = true; + } - if (XINT (y) == 0) - xsignal0 (Qarith_error); + if (have_r) + { + /* If MODULO and the remainder has the wrong sign, fix it. */ + if (modulo && (d < 0 ? r > 0 : r < 0)) + r += d; - XSETINT (val, XINT (x) % XINT (y)); - return val; + return make_fixnum (r); + } + } + + mpz_t const *d = bignum_integer (&mpz[1], den); + mpz_t *r = &mpz[0]; + mpz_tdiv_r (*r, *bignum_integer (&mpz[0], num), *d); + + if (modulo) + { + /* If the remainder has the wrong sign, fix it. */ + int sgn_r = mpz_sgn (*r); + if (mpz_sgn (*d) < 0 ? sgn_r > 0 : sgn_r < 0) + mpz_add (*r, *r, *d); + } + + return make_integer_mpz (); +} + +DEFUN ("%", Frem, Srem, 2, 2, 0, + doc: /* Return remainder of X divided by Y. +Both must be integers or markers. */) + (Lisp_Object x, Lisp_Object y) +{ + x = check_integer_coerce_marker (x); + y = check_integer_coerce_marker (y); + return integer_remainder (x, y, false); } DEFUN ("mod", Fmod, Smod, 2, 2, 0, doc: /* Return X modulo Y. The result falls between zero (inclusive) and Y (exclusive). Both X and Y must be numbers or markers. */) - (register Lisp_Object x, Lisp_Object y) + (Lisp_Object x, Lisp_Object y) { - Lisp_Object val; - EMACS_INT i1, i2; - - CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x); - CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y); - + x = check_number_coerce_marker (x); + y = check_number_coerce_marker (y); if (FLOATP (x) || FLOATP (y)) return fmod_float (x, y); - - i1 = XINT (x); - i2 = XINT (y); - - if (i2 == 0) - xsignal0 (Qarith_error); - - i1 %= i2; - - /* If the "remainder" comes out with the wrong sign, fix it. */ - if (i2 < 0 ? i1 > 0 : i1 < 0) - i1 += i2; - - XSETINT (val, i1); - return val; + return integer_remainder (x, y, true); } static Lisp_Object minmax_driver (ptrdiff_t nargs, Lisp_Object *args, enum Arith_Comparison comparison) { - Lisp_Object accum = args[0]; - CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (accum); + Lisp_Object accum = check_number_coerce_marker (args[0]); for (ptrdiff_t argnum = 1; argnum < nargs; argnum++) { - Lisp_Object val = args[argnum]; - CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val); + Lisp_Object val = check_number_coerce_marker (args[argnum]); if (!NILP (arithcompare (val, accum, comparison))) accum = val; else if (FLOATP (val) && isnan (XFLOAT_DATA (val))) @@ -3048,7 +3457,10 @@ Arguments may be integers, or markers converted to integers. usage: (logand &rest INTS-OR-MARKERS) */) (ptrdiff_t nargs, Lisp_Object *args) { - return arith_driver (Alogand, nargs, args); + if (nargs == 0) + return make_fixnum (-1); + Lisp_Object a = check_integer_coerce_marker (args[0]); + return nargs == 1 ? a : arith_driver (Alogand, nargs, args, a); } DEFUN ("logior", Flogior, Slogior, 0, MANY, 0, @@ -3057,7 +3469,10 @@ Arguments may be integers, or markers converted to integers. usage: (logior &rest INTS-OR-MARKERS) */) (ptrdiff_t nargs, Lisp_Object *args) { - return arith_driver (Alogior, nargs, args); + if (nargs == 0) + return make_fixnum (0); + Lisp_Object a = check_integer_coerce_marker (args[0]); + return nargs == 1 ? a : arith_driver (Alogior, nargs, args, a); } DEFUN ("logxor", Flogxor, Slogxor, 0, MANY, 0, @@ -3066,7 +3481,10 @@ Arguments may be integers, or markers converted to integers. usage: (logxor &rest INTS-OR-MARKERS) */) (ptrdiff_t nargs, Lisp_Object *args) { - return arith_driver (Alogxor, nargs, args); + if (nargs == 0) + return make_fixnum (0); + Lisp_Object a = check_integer_coerce_marker (args[0]); + return nargs == 1 ? a : arith_driver (Alogxor, nargs, args, a); } DEFUN ("logcount", Flogcount, Slogcount, 1, 1, 0, @@ -3076,91 +3494,157 @@ of VALUE. If VALUE is negative, return the number of zero bits in the representation. */) (Lisp_Object value) { - CHECK_NUMBER (value); - EMACS_INT v = XINT (value) < 0 ? -1 - XINT (value) : XINT (value); - return make_number (EMACS_UINT_WIDTH <= UINT_WIDTH + CHECK_INTEGER (value); + + if (BIGNUMP (value)) + { + mpz_t const *nonneg = xbignum_val (value); + if (mpz_sgn (*nonneg) < 0) + { + mpz_com (mpz[0], *nonneg); + nonneg = &mpz[0]; + } + return make_fixnum (mpz_popcount (*nonneg)); + } + + eassume (FIXNUMP (value)); + EMACS_INT v = XFIXNUM (value) < 0 ? -1 - XFIXNUM (value) : XFIXNUM (value); + return make_fixnum (EMACS_UINT_WIDTH <= UINT_WIDTH ? count_one_bits (v) : EMACS_UINT_WIDTH <= ULONG_WIDTH ? count_one_bits_l (v) : count_one_bits_ll (v)); } -static Lisp_Object -ash_lsh_impl (Lisp_Object value, Lisp_Object count, bool lsh) -{ - /* This code assumes that signed right shifts are arithmetic. */ - verify ((EMACS_INT) -1 >> 1 == -1); +DEFUN ("ash", Fash, Sash, 2, 2, 0, + doc: /* Return integer VALUE with its bits shifted left by COUNT bit positions. +If COUNT is negative, shift VALUE to the right instead. +VALUE and COUNT must be integers. +Mathematically, the return value is VALUE multiplied by 2 to the +power of COUNT, rounded down. If the result is non-zero, its sign +is the same as that of VALUE. +In terms of bits, when COUNT is positive, the function moves +the bits of VALUE to the left, adding zero bits on the right; when +COUNT is negative, it moves the bits of VALUE to the right, +discarding bits. */) + (Lisp_Object value, Lisp_Object count) +{ + CHECK_INTEGER (value); + CHECK_INTEGER (count); + + if (! FIXNUMP (count)) + { + if (BASE_EQ (value, make_fixnum (0))) + return value; + if (mpz_sgn (*xbignum_val (count)) < 0) + { + EMACS_INT v = (FIXNUMP (value) ? XFIXNUM (value) + : mpz_sgn (*xbignum_val (value))); + return make_fixnum (v < 0 ? -1 : 0); + } + overflow_error (); + } - Lisp_Object val; + if (XFIXNUM (count) <= 0) + { + if (XFIXNUM (count) == 0) + return value; - CHECK_NUMBER (value); - CHECK_NUMBER (count); + if ((EMACS_INT) -1 >> 1 == -1 && FIXNUMP (value)) + { + EMACS_INT shift = -XFIXNUM (count); + EMACS_INT result + = (shift < EMACS_INT_WIDTH ? XFIXNUM (value) >> shift + : XFIXNUM (value) < 0 ? -1 : 0); + return make_fixnum (result); + } + } - if (XINT (count) >= EMACS_INT_WIDTH) - XSETINT (val, 0); - else if (XINT (count) > 0) - XSETINT (val, XUINT (value) << XINT (count)); - else if (XINT (count) <= -EMACS_INT_WIDTH) - XSETINT (val, lsh ? 0 : XINT (value) < 0 ? -1 : 0); + mpz_t const *zval = bignum_integer (&mpz[0], value); + if (XFIXNUM (count) < 0) + { + if (TYPE_MAXIMUM (mp_bitcnt_t) < - XFIXNUM (count)) + return make_fixnum (mpz_sgn (*zval) < 0 ? -1 : 0); + mpz_fdiv_q_2exp (mpz[0], *zval, - XFIXNUM (count)); + } else - XSETINT (val, (lsh ? XUINT (value) >> -XINT (count) - : XINT (value) >> -XINT (count))); - return val; + emacs_mpz_mul_2exp (mpz[0], *zval, XFIXNUM (count)); + return make_integer_mpz (); } -DEFUN ("ash", Fash, Sash, 2, 2, 0, - doc: /* Return VALUE with its bits shifted left by COUNT. -If COUNT is negative, shifting is actually to the right. -In this case, the sign bit is duplicated. */) - (register Lisp_Object value, Lisp_Object count) -{ - return ash_lsh_impl (value, count, false); -} +/* Return X ** Y as an integer. X and Y must be integers, and Y must + be nonnegative. */ -DEFUN ("lsh", Flsh, Slsh, 2, 2, 0, - doc: /* Return VALUE with its bits shifted left by COUNT. -If COUNT is negative, shifting is actually to the right. -In this case, zeros are shifted in on the left. */) - (register Lisp_Object value, Lisp_Object count) -{ - return ash_lsh_impl (value, count, true); +Lisp_Object +expt_integer (Lisp_Object x, Lisp_Object y) +{ + /* Special cases for -1 <= x <= 1, which never overflow. */ + if (BASE_EQ (x, make_fixnum (1))) + return x; + if (BASE_EQ (x, make_fixnum (0))) + return BASE_EQ (x, y) ? make_fixnum (1) : x; + if (BASE_EQ (x, make_fixnum (-1))) + return ((FIXNUMP (y) ? XFIXNUM (y) & 1 : mpz_odd_p (*xbignum_val (y))) + ? x : make_fixnum (1)); + + unsigned long exp; + if (FIXNUMP (y)) + { + if (ULONG_MAX < XFIXNUM (y)) + overflow_error (); + exp = XFIXNUM (y); + } + else + { + if (ULONG_MAX <= MOST_POSITIVE_FIXNUM + || !mpz_fits_ulong_p (*xbignum_val (y))) + overflow_error (); + exp = mpz_get_ui (*xbignum_val (y)); + } + + emacs_mpz_pow_ui (mpz[0], *bignum_integer (&mpz[0], x), exp); + return make_integer_mpz (); } DEFUN ("1+", Fadd1, Sadd1, 1, 1, 0, doc: /* Return NUMBER plus one. NUMBER may be a number or a marker. Markers are converted to integers. */) - (register Lisp_Object number) + (Lisp_Object number) { - CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number); + number = check_number_coerce_marker (number); + if (FIXNUMP (number)) + return make_int (XFIXNUM (number) + 1); if (FLOATP (number)) return (make_float (1.0 + XFLOAT_DATA (number))); - - XSETINT (number, XINT (number) + 1); - return number; + mpz_add_ui (mpz[0], *xbignum_val (number), 1); + return make_integer_mpz (); } DEFUN ("1-", Fsub1, Ssub1, 1, 1, 0, doc: /* Return NUMBER minus one. NUMBER may be a number or a marker. Markers are converted to integers. */) - (register Lisp_Object number) + (Lisp_Object number) { - CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number); + number = check_number_coerce_marker (number); + if (FIXNUMP (number)) + return make_int (XFIXNUM (number) - 1); if (FLOATP (number)) return (make_float (-1.0 + XFLOAT_DATA (number))); - - XSETINT (number, XINT (number) - 1); - return number; + mpz_sub_ui (mpz[0], *xbignum_val (number), 1); + return make_integer_mpz (); } DEFUN ("lognot", Flognot, Slognot, 1, 1, 0, doc: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */) (register Lisp_Object number) { - CHECK_NUMBER (number); - XSETINT (number, ~XINT (number)); - return number; + CHECK_INTEGER (number); + if (FIXNUMP (number)) + return make_fixnum (~XFIXNUM (number)); + mpz_com (mpz[0], *xbignum_val (number)); + return make_integer_mpz (); } DEFUN ("byteorder", Fbyteorder, Sbyteorder, 0, 0, 0, @@ -3173,7 +3657,7 @@ lowercase l) for small endian machines. */ unsigned i = 0x04030201; int order = *(char *)&i == 1 ? 108 : 66; - return make_number (order); + return make_fixnum (order); } /* Because we round up the bool vector allocate size to word_size @@ -3186,27 +3670,14 @@ bool_vector_spare_mask (EMACS_INT nr_bits) return (((bits_word) 1) << (nr_bits % BITS_PER_BITS_WORD)) - 1; } -/* Info about unsigned long long, falling back on unsigned long - if unsigned long long is not available. */ - -#if HAVE_UNSIGNED_LONG_LONG_INT && defined ULLONG_WIDTH -enum { ULL_WIDTH = ULLONG_WIDTH }; -# define ULL_MAX ULLONG_MAX -#else -enum { ULL_WIDTH = ULONG_WIDTH }; -# 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. - ULL_WIDTH must be less than BITS_PER_BITS_WORD. */ + ULLONG_WIDTH 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 = ULL_WIDTH - BITS_PER_BITS_WORD < 0 ? ULL_WIDTH : 0; + int shift = ULLONG_WIDTH - BITS_PER_BITS_WORD < 0 ? ULLONG_WIDTH : 0; return w >> shift; } @@ -3223,7 +3694,7 @@ count_one_bits_word (bits_word w) { int i = 0, count = 0; while (count += count_one_bits_ll (w), - (i += ULL_WIDTH) < BITS_PER_BITS_WORD) + (i += ULLONG_WIDTH) < BITS_PER_BITS_WORD) w = shift_right_ull (w); return count; } @@ -3354,7 +3825,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 == ULL_MAX) + if (BITS_WORD_MAX == ULLONG_MAX) return count_trailing_zeros_ll (val); /* The rest of this code is for the unlikely platform where bits_word differs @@ -3368,18 +3839,18 @@ count_trailing_zero_bits (bits_word val) { int count; for (count = 0; - count < BITS_PER_BITS_WORD - ULL_WIDTH; - count += ULL_WIDTH) + count < BITS_PER_BITS_WORD - ULLONG_WIDTH; + count += ULLONG_WIDTH) { - if (val & ULL_MAX) + if (val & ULLONG_MAX) return count + count_trailing_zeros_ll (val); val = shift_right_ull (val); } - if (BITS_PER_BITS_WORD % ULL_WIDTH != 0 + if (BITS_PER_BITS_WORD % ULLONG_WIDTH != 0 && BITS_WORD_MAX == (bits_word) -1) val |= (bits_word) 1 << pre_value (ULONG_MAX < BITS_WORD_MAX, - BITS_PER_BITS_WORD % ULL_WIDTH); + BITS_PER_BITS_WORD % ULLONG_WIDTH); return count + count_trailing_zeros_ll (val); } } @@ -3392,10 +3863,8 @@ bits_word_to_host_endian (bits_word val) #else if (BITS_WORD_MAX >> 31 == 1) return bswap_32 (val); -# if HAVE_UNSIGNED_LONG_LONG if (BITS_WORD_MAX >> 31 >> 31 >> 1 == 1) return bswap_64 (val); -# endif { int i; bits_word r = 0; @@ -3526,7 +3995,7 @@ value from A's length. */) for (i = 0; i < nwords; i++) count += count_one_bits_word (adata[i]); - return make_number (count); + return make_fixnum (count); } DEFUN ("bool-vector-count-consecutive", Fbool_vector_count_consecutive, @@ -3545,16 +4014,16 @@ A is a bool vector, B is t or nil, and I is an index into A. */) ptrdiff_t nr_words; CHECK_BOOL_VECTOR (a); - CHECK_NATNUM (i); + CHECK_FIXNAT (i); nr_bits = bool_vector_size (a); - if (XFASTINT (i) > nr_bits) /* Allow one past the end for convenience */ + if (XFIXNAT (i) > nr_bits) /* Allow one past the end for convenience */ args_out_of_range (a, i); adata = bool_vector_data (a); nr_words = bool_vector_words (nr_bits); - pos = XFASTINT (i) / BITS_PER_BITS_WORD; - offset = XFASTINT (i) % BITS_PER_BITS_WORD; + pos = XFIXNAT (i) / BITS_PER_BITS_WORD; + offset = XFIXNAT (i) % BITS_PER_BITS_WORD; count = 0; /* By XORing with twiddle, we transform the problem of "count @@ -3575,7 +4044,7 @@ A is a bool vector, B is t or nil, and I is an index into A. */) count = count_trailing_zero_bits (mword); pos++; if (count + offset < BITS_PER_BITS_WORD) - return make_number (count); + return make_fixnum (count); } /* Scan whole words until we either reach the end of the vector or @@ -3602,14 +4071,14 @@ A is a bool vector, B is t or nil, and I is an index into A. */) count -= BITS_PER_BITS_WORD - nr_bits % BITS_PER_BITS_WORD; } - return make_number (count); + return make_fixnum (count); } void syms_of_data (void) { - Lisp_Object error_tail, arith_tail; + Lisp_Object error_tail, arith_tail, recursion_tail; DEFSYM (Qquote, "quote"); DEFSYM (Qlambda, "lambda"); @@ -3620,6 +4089,7 @@ syms_of_data (void) DEFSYM (Qerror, "error"); DEFSYM (Quser_error, "user-error"); DEFSYM (Qquit, "quit"); + DEFSYM (Qminibuffer_quit, "minibuffer-quit"); DEFSYM (Qwrong_length_argument, "wrong-length-argument"); DEFSYM (Qwrong_type_argument, "wrong-type-argument"); DEFSYM (Qargs_out_of_range, "args-out-of-range"); @@ -3641,11 +4111,20 @@ syms_of_data (void) DEFSYM (Qbuffer_read_only, "buffer-read-only"); DEFSYM (Qtext_read_only, "text-read-only"); DEFSYM (Qmark_inactive, "mark-inactive"); + DEFSYM (Qinhibited_interaction, "inhibited-interaction"); + + DEFSYM (Qrecursion_error, "recursion-error"); + DEFSYM (Qexcessive_variable_binding, "excessive-variable-binding"); + DEFSYM (Qexcessive_lisp_nesting, "excessive-lisp-nesting"); DEFSYM (Qlistp, "listp"); DEFSYM (Qconsp, "consp"); + DEFSYM (Qbare_symbol_p, "bare-symbol-p"); + DEFSYM (Qsymbol_with_pos_p, "symbol-with-pos-p"); DEFSYM (Qsymbolp, "symbolp"); + DEFSYM (Qfixnump, "fixnump"); DEFSYM (Qintegerp, "integerp"); + DEFSYM (Qbooleanp, "booleanp"); DEFSYM (Qnatnump, "natnump"); DEFSYM (Qwholenump, "wholenump"); DEFSYM (Qstringp, "stringp"); @@ -3657,9 +4136,7 @@ syms_of_data (void) DEFSYM (Qbool_vector_p, "bool-vector-p"); DEFSYM (Qchar_or_string_p, "char-or-string-p"); DEFSYM (Qmarkerp, "markerp"); -#ifdef HAVE_MODULES DEFSYM (Quser_ptrp, "user-ptrp"); -#endif DEFSYM (Qbuffer_or_string_p, "buffer-or-string-p"); DEFSYM (Qinteger_or_marker_p, "integer-or-marker-p"); DEFSYM (Qfboundp, "fboundp"); @@ -3670,6 +4147,8 @@ syms_of_data (void) DEFSYM (Qchar_table_p, "char-table-p"); DEFSYM (Qvector_or_char_table_p, "vector-or-char-table-p"); + DEFSYM (Qfixnum_or_symbol_with_pos_p, "fixnum-or-symbol-with-pos-p"); + DEFSYM (Qoclosure_interactive_form, "oclosure-interactive-form"); DEFSYM (Qsubrp, "subrp"); DEFSYM (Qunevalled, "unevalled"); @@ -3692,6 +4171,7 @@ syms_of_data (void) Fput (sym, Qerror_message, build_pure_c_string (msg)) PUT_ERROR (Qquit, Qnil, "Quit"); + PUT_ERROR (Qminibuffer_quit, pure_cons (Qquit, Qnil), "Quit"); PUT_ERROR (Quser_error, error_tail, ""); PUT_ERROR (Qwrong_length_argument, error_tail, "Wrong length argument"); @@ -3726,6 +4206,8 @@ syms_of_data (void) PUT_ERROR (Qbuffer_read_only, error_tail, "Buffer is read-only"); PUT_ERROR (Qtext_read_only, pure_cons (Qbuffer_read_only, error_tail), "Text is read-only"); + PUT_ERROR (Qinhibited_interaction, error_tail, + "User interaction while inhibited"); DEFSYM (Qrange_error, "range-error"); DEFSYM (Qdomain_error, "domain-error"); @@ -3740,23 +4222,33 @@ syms_of_data (void) PUT_ERROR (Qsingularity_error, Fcons (Qdomain_error, arith_tail), "Arithmetic singularity error"); - PUT_ERROR (Qoverflow_error, Fcons (Qdomain_error, arith_tail), + PUT_ERROR (Qoverflow_error, Fcons (Qrange_error, arith_tail), "Arithmetic overflow error"); - PUT_ERROR (Qunderflow_error, Fcons (Qdomain_error, arith_tail), + PUT_ERROR (Qunderflow_error, Fcons (Qrange_error, arith_tail), "Arithmetic underflow error"); + recursion_tail = pure_cons (Qrecursion_error, error_tail); + Fput (Qrecursion_error, Qerror_conditions, recursion_tail); + Fput (Qrecursion_error, Qerror_message, build_pure_c_string + ("Excessive recursive calling error")); + + PUT_ERROR (Qexcessive_variable_binding, recursion_tail, + "Variable binding depth exceeds max-specpdl-size"); + PUT_ERROR (Qexcessive_lisp_nesting, recursion_tail, + "Lisp nesting exceeds `max-lisp-eval-depth'"); + /* Types that type-of returns. */ DEFSYM (Qinteger, "integer"); DEFSYM (Qsymbol, "symbol"); DEFSYM (Qstring, "string"); DEFSYM (Qcons, "cons"); DEFSYM (Qmarker, "marker"); + DEFSYM (Qsymbol_with_pos, "symbol-with-pos"); DEFSYM (Qoverlay, "overlay"); DEFSYM (Qfinalizer, "finalizer"); -#ifdef HAVE_MODULES DEFSYM (Qmodule_function, "module-function"); + DEFSYM (Qnative_comp_unit, "native-comp-unit"); DEFSYM (Quser_ptr, "user-ptr"); -#endif DEFSYM (Qfloat, "float"); DEFSYM (Qwindow_configuration, "window-configuration"); DEFSYM (Qprocess, "process"); @@ -3777,14 +4269,20 @@ syms_of_data (void) DEFSYM (Qfont_entity, "font-entity"); DEFSYM (Qfont_object, "font-object"); DEFSYM (Qterminal, "terminal"); + DEFSYM (Qxwidget, "xwidget"); + DEFSYM (Qxwidget_view, "xwidget-view"); DEFSYM (Qdefun, "defun"); DEFSYM (Qinteractive_form, "interactive-form"); DEFSYM (Qdefalias_fset_function, "defalias-fset-function"); + DEFSYM (Qfunction_history, "function-history"); + + DEFSYM (Qbyte_code_function_p, "byte-code-function-p"); defsubr (&Sindirect_variable); defsubr (&Sinteractive_form); + defsubr (&Scommand_modes); defsubr (&Seq); defsubr (&Snull); defsubr (&Stype_of); @@ -3798,6 +4296,8 @@ syms_of_data (void) defsubr (&Snumber_or_marker_p); defsubr (&Sfloatp); defsubr (&Snatnump); + defsubr (&Sbare_symbol_p); + defsubr (&Ssymbol_with_pos_p); defsubr (&Ssymbolp); defsubr (&Skeywordp); defsubr (&Sstringp); @@ -3828,6 +4328,10 @@ syms_of_data (void) defsubr (&Sindirect_function); defsubr (&Ssymbol_plist); defsubr (&Ssymbol_name); + defsubr (&Sbare_symbol); + defsubr (&Ssymbol_with_pos_pos); + defsubr (&Sremove_pos_from_symbol); + defsubr (&Sposition_symbol); defsubr (&Smakunbound); defsubr (&Sfmakunbound); defsubr (&Sboundp); @@ -3840,17 +4344,12 @@ syms_of_data (void) 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 (&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); @@ -3873,7 +4372,6 @@ syms_of_data (void) defsubr (&Slogior); defsubr (&Slogxor); defsubr (&Slogcount); - defsubr (&Slsh); defsubr (&Sash); defsubr (&Sadd1); defsubr (&Ssub1); @@ -3881,6 +4379,14 @@ syms_of_data (void) defsubr (&Sbyteorder); defsubr (&Ssubr_arity); defsubr (&Ssubr_name); + defsubr (&Ssubr_native_elisp_p); + defsubr (&Ssubr_native_lambda_list); + defsubr (&Ssubr_type); +#ifdef HAVE_NATIVE_COMP + defsubr (&Ssubr_native_comp_unit); + defsubr (&Snative_comp_unit_file); + defsubr (&Snative_comp_unit_set_file); +#endif #ifdef HAVE_MODULES defsubr (&Suser_ptrp); #endif @@ -3894,23 +4400,32 @@ syms_of_data (void) defsubr (&Sbool_vector_count_consecutive); defsubr (&Sbool_vector_count_population); - set_symbol_function (Qwholenump, XSYMBOL (Qnatnump)->function); + set_symbol_function (Qwholenump, XSYMBOL (Qnatnump)->u.s.function); 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); + doc: /* The greatest integer that is represented efficiently. +This variable cannot be set; trying to do so will signal an error. */); + Vmost_positive_fixnum = make_fixnum (MOST_POSITIVE_FIXNUM); make_symbol_constant (intern_c_string ("most-positive-fixnum")); 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); + doc: /* The least integer that is represented efficiently. +This variable cannot be set; trying to do so will signal an error. */); + Vmost_negative_fixnum = make_fixnum (MOST_NEGATIVE_FIXNUM); make_symbol_constant (intern_c_string ("most-negative-fixnum")); + DEFSYM (Qsymbols_with_pos_enabled, "symbols-with-pos-enabled"); + DEFVAR_BOOL ("symbols-with-pos-enabled", symbols_with_pos_enabled, + doc: /* Non-nil when "symbols with position" can be used as symbols. +Bind this to non-nil in applications such as the byte compiler. */); + symbols_with_pos_enabled = false; + DEFSYM (Qwatchers, "watchers"); DEFSYM (Qmakunbound, "makunbound"); DEFSYM (Qunlet, "unlet"); DEFSYM (Qset, "set"); DEFSYM (Qset_default, "set-default"); + DEFSYM (Qcommand_modes, "command-modes"); defsubr (&Sadd_variable_watcher); defsubr (&Sremove_variable_watcher); defsubr (&Sget_variable_watchers); |