X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/4d0108a132788e0c3903eb4d5875321ed6e8eef1..de3fa655de8a1f9a1e23ed67ec70700ab8f5a591:/src/data.c diff --git a/src/data.c b/src/data.c index d06b9916b3..07f8724191 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-2015 Free Software + Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2016 Free Software Foundation, Inc. This file is part of GNU Emacs. @@ -32,9 +32,6 @@ along with GNU Emacs. If not, see . */ #include "buffer.h" #include "keyboard.h" #include "frame.h" -#include "syssignal.h" -#include "termhooks.h" /* For FRAME_KBOARD reference in y-or-n-p. */ -#include "font.h" #include "keymap.h" static void swap_in_symval_forwarding (struct Lisp_Symbol *, @@ -186,7 +183,7 @@ DEFUN ("eq", Feq, Seq, 2, 2, 0, } DEFUN ("null", Fnull, Snull, 1, 1, 0, - doc: /* Return t if OBJECT is nil. */ + doc: /* Return t if OBJECT is nil, and return nil otherwise. */ attributes: const) (Lisp_Object object) { @@ -223,9 +220,16 @@ for example, (type-of 1) returns `integer'. */) case Lisp_Misc_Overlay: return Qoverlay; case Lisp_Misc_Float: - return Qfloat; + return Qfloat; + case Lisp_Misc_Finalizer: + return Qfinalizer; +#ifdef HAVE_MODULES + case Lisp_Misc_User_Ptr: + return Quser_ptr; +#endif + default: + emacs_abort (); } - emacs_abort (); case Lisp_Vectorlike: if (WINDOW_CONFIGURATIONP (object)) @@ -424,6 +428,17 @@ DEFUN ("markerp", Fmarkerp, Smarkerp, 1, 1, 0, return Qnil; } +#ifdef HAVE_MODULES +DEFUN ("user-ptrp", Fuser_ptrp, Suser_ptrp, 1, 1, 0, + doc: /* Return t if OBJECT is a module user pointer. */) + (Lisp_Object object) +{ + if (USER_PTRP (object)) + return Qt; + return Qnil; +} +#endif + DEFUN ("subrp", Fsubrp, Ssubrp, 1, 1, 0, doc: /* Return t if OBJECT is a built-in function. */) (Lisp_Object object) @@ -557,7 +572,7 @@ DEFUN ("setcar", Fsetcar, Ssetcar, 2, 2, 0, (register Lisp_Object cell, Lisp_Object newcar) { CHECK_CONS (cell); - CHECK_IMPURE (cell); + CHECK_IMPURE (cell, XCONS (cell)); XSETCAR (cell, newcar); return newcar; } @@ -567,7 +582,7 @@ DEFUN ("setcdr", Fsetcdr, Ssetcdr, 2, 2, 0, (register Lisp_Object cell, Lisp_Object newcdr) { CHECK_CONS (cell); - CHECK_IMPURE (cell); + CHECK_IMPURE (cell, XCONS (cell)); XSETCDR (cell, newcdr); return newcdr; } @@ -788,7 +803,7 @@ SUBR must be a built-in function. */) 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. -Value, if non-nil, is a list \(interactive SPEC). */) +Value, if non-nil, is a list (interactive SPEC). */) (Lisp_Object cmd) { Lisp_Object fun = indirect_function (cmd); /* Check cycles. */ @@ -1240,6 +1255,7 @@ set_internal (Lisp_Object symbol, Lisp_Object newval, Lisp_Object where, return; } + maybe_set_redisplay (symbol); sym = XSYMBOL (symbol); start: @@ -1527,10 +1543,8 @@ usage: (setq-default [VAR VALUE]...) */) (Lisp_Object args) { Lisp_Object args_left, symbol, val; - struct gcpro gcpro1; args_left = val = args; - GCPRO1 (args); while (CONSP (args_left)) { @@ -1540,7 +1554,6 @@ usage: (setq-default [VAR VALUE]...) */) args_left = Fcdr (XCDR (args_left)); } - UNGCPRO; return val; } @@ -1645,8 +1658,10 @@ The function `default-value' gets the default value and `set-default' sets it. Lisp_Object symbol; XSETSYMBOL (symbol, sym); /* In case `variable' is aliased. */ if (let_shadows_global_binding_p (symbol)) - message ("Making %s buffer-local while let-bound!", - SDATA (SYMBOL_NAME (variable))); + { + AUTO_STRING (format, "Making %s buffer-local while let-bound!"); + CALLN (Fmessage, format, SYMBOL_NAME (variable)); + } } } @@ -1658,8 +1673,8 @@ DEFUN ("make-local-variable", Fmake_local_variable, Smake_local_variable, 1, 1, "vMake Local Variable: ", doc: /* Make VARIABLE have a separate value in the current buffer. Other buffers will continue to share a common default value. -\(The buffer-local value of VARIABLE starts out as the same value -VARIABLE previously had. If VARIABLE was void, it remains void.\) +(The buffer-local value of VARIABLE starts out as the same value +VARIABLE previously had. If VARIABLE was void, it remains void.) Return VARIABLE. If the variable is already arranged to become local when set, @@ -1667,7 +1682,7 @@ this function causes a local value to exist for this buffer, just as setting the variable would do. This function returns VARIABLE, and therefore - (set (make-local-variable 'VARIABLE) VALUE-EXP) + (set (make-local-variable \\='VARIABLE) VALUE-EXP) works. See also `make-variable-buffer-local'. @@ -1728,9 +1743,11 @@ Instead, use `add-hook' and specify t for the LOCAL argument. */) Lisp_Object symbol; XSETSYMBOL (symbol, sym); /* In case `variable' is aliased. */ if (let_shadows_global_binding_p (symbol)) - message ("Making %s local to %s while let-bound!", - SDATA (SYMBOL_NAME (variable)), - SDATA (BVAR (current_buffer, name))); + { + AUTO_STRING (format, "Making %s local to %s while let-bound!"); + CALLN (Fmessage, format, SYMBOL_NAME (variable), + BVAR (current_buffer, name)); + } } } @@ -1740,8 +1757,11 @@ Instead, use `add-hook' and specify t for the LOCAL argument. */) if (NILP (tem)) { if (let_shadows_buffer_binding_p (sym)) - message ("Making %s buffer-local while locally let-bound!", - SDATA (SYMBOL_NAME (variable))); + { + AUTO_STRING (format, + "Making %s buffer-local while locally let-bound!"); + 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 @@ -1906,8 +1926,10 @@ frame-local bindings). */) Lisp_Object symbol; XSETSYMBOL (symbol, sym); /* In case `variable' is aliased. */ if (let_shadows_global_binding_p (symbol)) - message ("Making %s frame-local while let-bound!", - SDATA (SYMBOL_NAME (variable))); + { + AUTO_STRING (format, "Making %s frame-local while let-bound!"); + CALLN (Fmessage, format, SYMBOL_NAME (variable)); + } } return variable; } @@ -2125,8 +2147,6 @@ DEFUN ("indirect-function", Findirect_function, Sindirect_function, 1, 2, 0, doc: /* Return the function at the end of OBJECT's function chain. If OBJECT is not a symbol, just return it. Otherwise, follow all function indirections to find the final function binding and return it. -If the final symbol in the chain is unbound, signal a void-function error. -Optional arg NOERROR non-nil means to return nil instead of signaling. Signal a cyclic-function-indirection error if there is a loop in the function chain of symbols. */) (register Lisp_Object object, Lisp_Object noerror) @@ -2141,9 +2161,6 @@ function chain of symbols. */) if (!NILP (result)) return result; - if (NILP (noerror)) - xsignal1 (Qvoid_function, object); - return Qnil; } @@ -2211,10 +2228,10 @@ bool-vector. IDX starts at 0. */) CHECK_NUMBER (idx); idxval = XINT (idx); CHECK_ARRAY (array, Qarrayp); - CHECK_IMPURE (array); if (VECTORP (array)) { + CHECK_IMPURE (array, XVECTOR (array)); if (idxval < 0 || idxval >= ASIZE (array)) args_out_of_range (array, idx); ASET (array, idxval, newelt); @@ -2234,6 +2251,7 @@ bool-vector. IDX starts at 0. */) { int c; + CHECK_IMPURE (array, XSTRING (array)); if (idxval < 0 || idxval >= SCHARS (array)) args_out_of_range (array, idx); CHECK_CHARACTER (newelt); @@ -2406,6 +2424,33 @@ 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. Signal an error if C does not have a valid format or is out of range. */ @@ -2598,6 +2643,7 @@ arith_driver (enum arithop code, ptrdiff_t nargs, Lisp_Object *args) accum = 0; break; case Amult: + case Adiv: accum = 1; break; case Alogand: @@ -2627,39 +2673,28 @@ arith_driver (enum arithop code, ptrdiff_t nargs, Lisp_Object *args) switch (code) { case Aadd: - if (INT_ADD_OVERFLOW (accum, next)) - { - overflow = 1; - accum &= INTMASK; - } - accum += next; + overflow |= INT_ADD_WRAPV (accum, next, &accum); break; case Asub: - if (INT_SUBTRACT_OVERFLOW (accum, next)) - { - overflow = 1; - accum &= INTMASK; - } - accum = argnum ? accum - next : nargs == 1 ? - next : next; + if (! argnum) + accum = nargs == 1 ? - next : next; + else + overflow |= INT_SUBTRACT_WRAPV (accum, next, &accum); break; case Amult: - if (INT_MULTIPLY_OVERFLOW (accum, next)) - { - EMACS_UINT a = accum, b = next, ab = a * b; - overflow = 1; - accum = ab & INTMASK; - } - else - accum *= next; + overflow |= INT_MULTIPLY_WRAPV (accum, next, &accum); break; case Adiv: - if (!argnum) + if (! (argnum || nargs == 1)) accum = next; else { if (next == 0) xsignal0 (Qarith_error); - accum /= next; + if (INT_DIVIDE_OVERFLOW (accum, next)) + overflow = true; + else + accum /= next; } break; case Alogand: @@ -2722,7 +2757,7 @@ float_arith_driver (double accum, ptrdiff_t argnum, enum arithop code, accum *= next; break; case Adiv: - if (!argnum) + if (! (argnum || nargs == 1)) accum = next; else { @@ -2777,9 +2812,11 @@ usage: (* &rest NUMBERS-OR-MARKERS) */) } DEFUN ("/", Fquo, Squo, 1, MANY, 0, - doc: /* Return first argument divided by all the remaining arguments. + doc: /* Divide number by divisors and return the result. +With two or more arguments, return first argument divided by the rest. +With one argument, return 1 divided by the argument. The arguments must be numbers or markers. -usage: (/ DIVIDEND &rest DIVISORS) */) +usage: (/ NUMBER &rest DIVISORS) */) (ptrdiff_t nargs, Lisp_Object *args) { ptrdiff_t argnum; @@ -3445,7 +3482,6 @@ syms_of_data (void) DEFSYM (Qlistp, "listp"); DEFSYM (Qconsp, "consp"); DEFSYM (Qsymbolp, "symbolp"); - DEFSYM (Qkeywordp, "keywordp"); DEFSYM (Qintegerp, "integerp"); DEFSYM (Qnatnump, "natnump"); DEFSYM (Qwholenump, "wholenump"); @@ -3457,9 +3493,11 @@ 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 (Qboundp, "boundp"); DEFSYM (Qfboundp, "fboundp"); DEFSYM (Qfloatp, "floatp"); @@ -3475,10 +3513,6 @@ syms_of_data (void) DEFSYM (Qcdr, "cdr"); - /* Handle automatic advice activation. */ - DEFSYM (Qad_advice_info, "ad-advice-info"); - DEFSYM (Qad_activate_internal, "ad-activate-internal"); - error_tail = pure_cons (Qerror, Qnil); /* ERROR is used as a signaler for random errors for which nothing else is @@ -3552,6 +3586,10 @@ syms_of_data (void) DEFSYM (Qcons, "cons"); DEFSYM (Qmarker, "marker"); DEFSYM (Qoverlay, "overlay"); + DEFSYM (Qfinalizer, "finalizer"); +#ifdef HAVE_MODULES + DEFSYM (Quser_ptr, "user-ptr"); +#endif DEFSYM (Qfloat, "float"); DEFSYM (Qwindow_configuration, "window-configuration"); DEFSYM (Qprocess, "process"); @@ -3563,7 +3601,6 @@ syms_of_data (void) DEFSYM (Qchar_table, "char-table"); DEFSYM (Qbool_vector, "bool-vector"); DEFSYM (Qhash_table, "hash-table"); - DEFSYM (Qmisc, "misc"); DEFSYM (Qdefun, "defun"); @@ -3667,6 +3704,9 @@ syms_of_data (void) defsubr (&Sbyteorder); defsubr (&Ssubr_arity); defsubr (&Ssubr_name); +#ifdef HAVE_MODULES + defsubr (&Suser_ptrp); +#endif defsubr (&Sbool_vector_exclusive_or); defsubr (&Sbool_vector_union);