/* 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.
GNU Emacs is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
-the Free Software Foundation, either version 3 of the License, or
-(at your option) any later version.
+the Free Software Foundation, either version 3 of the License, or (at
+your option) any later version.
GNU Emacs is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
#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 *,
}
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)
{
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))
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)
(register Lisp_Object cell, Lisp_Object newcar)
{
CHECK_CONS (cell);
- CHECK_IMPURE (cell);
+ CHECK_IMPURE (cell, XCONS (cell));
XSETCAR (cell, newcar);
return newcar;
}
(register Lisp_Object cell, Lisp_Object newcdr)
{
CHECK_CONS (cell);
- CHECK_IMPURE (cell);
+ CHECK_IMPURE (cell, XCONS (cell));
XSETCDR (cell, newcdr);
return newcdr;
}
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. */
return;
}
+ maybe_set_redisplay (symbol);
sym = XSYMBOL (symbol);
start:
(Lisp_Object args)
{
Lisp_Object args_left, symbol, val;
- struct gcpro gcpro1;
args_left = val = args;
- GCPRO1 (args);
while (CONSP (args_left))
{
args_left = Fcdr (XCDR (args_left));
}
- UNGCPRO;
return val;
}
\f
{
struct Lisp_Symbol *sym;
struct Lisp_Buffer_Local_Value *blv = NULL;
- union Lisp_Val_Fwd valcontents IF_LINT (= {LISP_INITIALLY_ZERO});
- bool forwarded IF_LINT (= 0);
+ union Lisp_Val_Fwd valcontents;
+ bool forwarded;
CHECK_SYMBOL (variable);
sym = XSYMBOL (variable);
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));
+ }
}
}
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.\)
+VARIABLE previously had. If VARIABLE was void, it remains void.)
Return VARIABLE.
If the variable is already arranged to become local when set,
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'.
(Lisp_Object variable)
{
Lisp_Object tem;
- bool forwarded IF_LINT (= 0);
- union Lisp_Val_Fwd valcontents IF_LINT (= {LISP_INITIALLY_ZERO});
+ bool forwarded;
+ union Lisp_Val_Fwd valcontents;
struct Lisp_Symbol *sym;
struct Lisp_Buffer_Local_Value *blv = NULL;
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));
+ }
}
}
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
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;
}
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);
{
int c;
+ CHECK_IMPURE (array, XSTRING (array));
if (idxval < 0 || idxval >= SCHARS (array))
args_out_of_range (array, idx);
CHECK_CHARACTER (newelt);
return arithcompare (num1, num2, ARITH_NOTEQUAL);
}
\f
+/* 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. */
cons_to_unsigned (Lisp_Object c, uintmax_t max)
{
bool valid = 0;
- uintmax_t val IF_LINT (= 0);
+ uintmax_t val;
if (INTEGERP (c))
{
valid = 0 <= XINT (c);
cons_to_signed (Lisp_Object c, intmax_t min, intmax_t max)
{
bool valid = 0;
- intmax_t val IF_LINT (= 0);
+ intmax_t val;
if (INTEGERP (c))
{
val = XINT (c);
accum = 0;
break;
case Amult:
+ case Adiv:
accum = 1;
break;
case Alogand:
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:
accum *= next;
break;
case Adiv:
- if (!argnum)
+ if (! (argnum || nargs == 1))
accum = next;
else
{
}
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;
DEFSYM (Qlistp, "listp");
DEFSYM (Qconsp, "consp");
DEFSYM (Qsymbolp, "symbolp");
- DEFSYM (Qkeywordp, "keywordp");
DEFSYM (Qintegerp, "integerp");
DEFSYM (Qnatnump, "natnump");
DEFSYM (Qwholenump, "wholenump");
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");
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
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");
DEFSYM (Qchar_table, "char-table");
DEFSYM (Qbool_vector, "bool-vector");
DEFSYM (Qhash_table, "hash-table");
- DEFSYM (Qmisc, "misc");
DEFSYM (Qdefun, "defun");
defsubr (&Sbyteorder);
defsubr (&Ssubr_arity);
defsubr (&Ssubr_name);
+#ifdef HAVE_MODULES
+ defsubr (&Suser_ptrp);
+#endif
defsubr (&Sbool_vector_exclusive_or);
defsubr (&Sbool_vector_union);