/* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
- Copyright (C) 1985, 86, 88, 93, 94, 95 Free Software Foundation, Inc.
+ Copyright (C) 1985,86,88,93,94,95,97,98,99,2000 Free Software Foundation, Inc.
This file is part of GNU Emacs.
Boston, MA 02111-1307, USA. */
-#include <signal.h>
-
#include <config.h>
+#include <signal.h>
+#include <stdio.h>
#include "lisp.h"
#include "puresize.h"
-
-#ifndef standalone
+#include "charset.h"
#include "buffer.h"
#include "keyboard.h"
-#endif
-
+#include "frame.h"
#include "syssignal.h"
-#ifdef LISP_FLOAT_TYPE
-
#ifdef STDC_HEADERS
-#include <stdlib.h>
+#include <float.h>
+#endif
+
+/* If IEEE_FLOATING_POINT isn't defined, default it from FLT_*. */
+#ifndef IEEE_FLOATING_POINT
+#if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \
+ && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128)
+#define IEEE_FLOATING_POINT 1
+#else
+#define IEEE_FLOATING_POINT 0
+#endif
#endif
/* Work around a problem that happens because math.h on hpux 7
#endif
#include <math.h>
-#endif /* LISP_FLOAT_TYPE */
#if !defined (atof)
extern double atof ();
Lisp_Object Qinvalid_function, Qwrong_number_of_arguments, Qno_catch;
Lisp_Object Qend_of_file, Qarith_error, Qmark_inactive;
Lisp_Object Qbeginning_of_buffer, Qend_of_buffer, Qbuffer_read_only;
+Lisp_Object Qtext_read_only;
Lisp_Object Qintegerp, Qnatnump, Qwholenump, Qsymbolp, Qlistp, Qconsp;
Lisp_Object Qstringp, Qarrayp, Qsequencep, Qbufferp;
Lisp_Object Qchar_or_string_p, Qmarkerp, Qinteger_or_marker_p, Qvectorp;
-Lisp_Object Qbuffer_or_string_p;
+Lisp_Object Qbuffer_or_string_p, Qkeywordp;
Lisp_Object Qboundp, Qfboundp;
Lisp_Object Qchar_table_p, Qvector_or_char_table_p;
Lisp_Object Qcdr;
-Lisp_Object Qad_advice_info, Qad_activate;
+Lisp_Object Qad_advice_info, Qad_activate_internal;
Lisp_Object Qrange_error, Qdomain_error, Qsingularity_error;
Lisp_Object Qoverflow_error, Qunderflow_error;
-#ifdef LISP_FLOAT_TYPE
Lisp_Object Qfloatp;
Lisp_Object Qnumberp, Qnumber_or_marker_p;
-#endif
static Lisp_Object Qinteger, Qsymbol, Qstring, Qcons, Qmarker, Qoverlay;
-static Lisp_Object Qfloat, Qwindow_configuration, Qprocess, Qwindow;
+static Lisp_Object Qfloat, Qwindow_configuration, Qwindow;
+Lisp_Object Qprocess;
static Lisp_Object Qcompiled_function, Qbuffer, Qframe, Qvector;
-static Lisp_Object Qchar_table, Qbool_vector;
+static Lisp_Object Qchar_table, Qbool_vector, Qhash_table;
+static Lisp_Object Qsubrp, Qmany, Qunevalled;
static Lisp_Object swap_in_symval_forwarding ();
+Lisp_Object set_internal ();
+
Lisp_Object
wrong_type_argument (predicate, value)
register Lisp_Object predicate, value;
{
if (STRINGP (value) &&
(EQ (predicate, Qintegerp) || EQ (predicate, Qinteger_or_marker_p)))
- return Fstring_to_number (value);
+ return Fstring_to_number (value, Qnil);
if (INTEGERP (value) && EQ (predicate, Qstringp))
return Fnumber_to_string (value);
}
return value;
}
+void
pure_write_error ()
{
error ("Attempt to modify read-only object");
/* Data type predicates */
DEFUN ("eq", Feq, Seq, 2, 2, 0,
- "T if the two args are the same Lisp object.")
+ "Return t if the two args are the same Lisp object.")
(obj1, obj2)
Lisp_Object obj1, obj2;
{
return Qnil;
}
-DEFUN ("null", Fnull, Snull, 1, 1, 0, "T if OBJECT is nil.")
+DEFUN ("null", Fnull, Snull, 1, 1, 0, "Return t if OBJECT is nil.")
(object)
Lisp_Object object;
{
return Qbool_vector;
if (GC_FRAMEP (object))
return Qframe;
+ if (GC_HASH_TABLE_P (object))
+ return Qhash_table;
return Qvector;
-#ifdef LISP_FLOAT_TYPE
case Lisp_Float:
return Qfloat;
-#endif
default:
abort ();
}
}
-DEFUN ("consp", Fconsp, Sconsp, 1, 1, 0, "T if OBJECT is a cons cell.")
+DEFUN ("consp", Fconsp, Sconsp, 1, 1, 0, "Return t if OBJECT is a cons cell.")
(object)
Lisp_Object object;
{
return Qnil;
}
-DEFUN ("atom", Fatom, Satom, 1, 1, 0, "T if OBJECT is not a cons cell. This includes nil.")
+DEFUN ("atom", Fatom, Satom, 1, 1, 0,
+ "Return t if OBJECT is not a cons cell. This includes nil.")
(object)
Lisp_Object object;
{
return Qt;
}
-DEFUN ("listp", Flistp, Slistp, 1, 1, 0, "T if OBJECT is a list. This includes nil.")
+DEFUN ("listp", Flistp, Slistp, 1, 1, 0,
+ "Return t if OBJECT is a list. This includes nil.")
(object)
Lisp_Object object;
{
return Qnil;
}
-DEFUN ("nlistp", Fnlistp, Snlistp, 1, 1, 0, "T if OBJECT is not a list. Lists include nil.")
+DEFUN ("nlistp", Fnlistp, Snlistp, 1, 1, 0,
+ "Return t if OBJECT is not a list. Lists include nil.")
(object)
Lisp_Object object;
{
return Qt;
}
\f
-DEFUN ("symbolp", Fsymbolp, Ssymbolp, 1, 1, 0, "T if OBJECT is a symbol.")
+DEFUN ("symbolp", Fsymbolp, Ssymbolp, 1, 1, 0,
+ "Return t if OBJECT is a symbol.")
(object)
Lisp_Object object;
{
return Qnil;
}
-DEFUN ("vectorp", Fvectorp, Svectorp, 1, 1, 0, "T if OBJECT is a vector.")
+/* Define this in C to avoid unnecessarily consing up the symbol
+ name. */
+DEFUN ("keywordp", Fkeywordp, Skeywordp, 1, 1, 0,
+ "Return t if OBJECT is a keyword.\n\
+This means that it is a symbol with a print name beginning with `:'\n\
+interned in the initial obarray.")
+ (object)
+ Lisp_Object object;
+{
+ if (SYMBOLP (object)
+ && XSYMBOL (object)->name->data[0] == ':'
+ && EQ (XSYMBOL (object)->obarray, initial_obarray))
+ return Qt;
+ return Qnil;
+}
+
+DEFUN ("vectorp", Fvectorp, Svectorp, 1, 1, 0,
+ "Return t if OBJECT is a vector.")
(object)
Lisp_Object object;
{
return Qnil;
}
-DEFUN ("stringp", Fstringp, Sstringp, 1, 1, 0, "T if OBJECT is a string.")
+DEFUN ("stringp", Fstringp, Sstringp, 1, 1, 0,
+ "Return t if OBJECT is a string.")
(object)
Lisp_Object object;
{
return Qnil;
}
-DEFUN ("char-table-p", Fchar_table_p, Schar_table_p, 1, 1, 0, "T if OBJECT is a char-table.")
+DEFUN ("multibyte-string-p", Fmultibyte_string_p, Smultibyte_string_p,
+ 1, 1, 0, "Return t if OBJECT is a multibyte string.")
+ (object)
+ Lisp_Object object;
+{
+ if (STRINGP (object) && STRING_MULTIBYTE (object))
+ return Qt;
+ return Qnil;
+}
+
+DEFUN ("char-table-p", Fchar_table_p, Schar_table_p, 1, 1, 0,
+ "Return t if OBJECT is a char-table.")
(object)
Lisp_Object object;
{
DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p,
Svector_or_char_table_p, 1, 1, 0,
- "T if OBJECT is a char-table or vector.")
+ "Return t if OBJECT is a char-table or vector.")
(object)
Lisp_Object object;
{
return Qnil;
}
-DEFUN ("bool-vector-p", Fbool_vector_p, Sbool_vector_p, 1, 1, 0, "T if OBJECT is a bool-vector.")
+DEFUN ("bool-vector-p", Fbool_vector_p, Sbool_vector_p, 1, 1, 0, "Return t if OBJECT is a bool-vector.")
(object)
Lisp_Object object;
{
return Qnil;
}
-DEFUN ("arrayp", Farrayp, Sarrayp, 1, 1, 0, "T if OBJECT is an array (string or vector).")
+DEFUN ("arrayp", Farrayp, Sarrayp, 1, 1, 0, "Return t if OBJECT is an array (string or vector).")
(object)
Lisp_Object object;
{
- if (VECTORP (object) || STRINGP (object))
+ if (VECTORP (object) || STRINGP (object)
+ || CHAR_TABLE_P (object) || BOOL_VECTOR_P (object))
return Qt;
return Qnil;
}
DEFUN ("sequencep", Fsequencep, Ssequencep, 1, 1, 0,
- "T if OBJECT is a sequence (list or array).")
+ "Return t if OBJECT is a sequence (list or array).")
(object)
register Lisp_Object object;
{
return Qnil;
}
-DEFUN ("bufferp", Fbufferp, Sbufferp, 1, 1, 0, "T if OBJECT is an editor buffer.")
+DEFUN ("bufferp", Fbufferp, Sbufferp, 1, 1, 0, "Return t if OBJECT is an editor buffer.")
(object)
Lisp_Object object;
{
return Qnil;
}
-DEFUN ("markerp", Fmarkerp, Smarkerp, 1, 1, 0, "T if OBJECT is a marker (editor pointer).")
+DEFUN ("markerp", Fmarkerp, Smarkerp, 1, 1, 0, "Return t if OBJECT is a marker (editor pointer).")
(object)
Lisp_Object object;
{
return Qnil;
}
-DEFUN ("subrp", Fsubrp, Ssubrp, 1, 1, 0, "T if OBJECT is a built-in function.")
+DEFUN ("subrp", Fsubrp, Ssubrp, 1, 1, 0, "Return t if OBJECT is a built-in function.")
(object)
Lisp_Object object;
{
}
DEFUN ("byte-code-function-p", Fbyte_code_function_p, Sbyte_code_function_p,
- 1, 1, 0, "T if OBJECT is a byte-compiled function object.")
+ 1, 1, 0, "Return t if OBJECT is a byte-compiled function object.")
(object)
Lisp_Object object;
{
}
DEFUN ("char-or-string-p", Fchar_or_string_p, Schar_or_string_p, 1, 1, 0,
- "T if OBJECT is a character (an integer) or a string.")
+ "Return t if OBJECT is a character (an integer) or a string.")
(object)
register Lisp_Object object;
{
return Qnil;
}
\f
-DEFUN ("integerp", Fintegerp, Sintegerp, 1, 1, 0, "T if OBJECT is an integer.")
+DEFUN ("integerp", Fintegerp, Sintegerp, 1, 1, 0, "Return t if OBJECT is an integer.")
(object)
Lisp_Object object;
{
}
DEFUN ("integer-or-marker-p", Finteger_or_marker_p, Sinteger_or_marker_p, 1, 1, 0,
- "T if OBJECT is an integer or a marker (editor pointer).")
+ "Return t if OBJECT is an integer or a marker (editor pointer).")
(object)
register Lisp_Object object;
{
}
DEFUN ("natnump", Fnatnump, Snatnump, 1, 1, 0,
- "T if OBJECT is a nonnegative integer.")
+ "Return t if OBJECT is a nonnegative integer.")
(object)
Lisp_Object object;
{
}
DEFUN ("numberp", Fnumberp, Snumberp, 1, 1, 0,
- "T if OBJECT is a number (floating point or integer).")
+ "Return t if OBJECT is a number (floating point or integer).")
(object)
Lisp_Object object;
{
DEFUN ("number-or-marker-p", Fnumber_or_marker_p,
Snumber_or_marker_p, 1, 1, 0,
- "T if OBJECT is a number or a marker.")
+ "Return t if OBJECT is a number or a marker.")
(object)
Lisp_Object object;
{
return Qnil;
}
-#ifdef LISP_FLOAT_TYPE
DEFUN ("floatp", Ffloatp, Sfloatp, 1, 1, 0,
- "T if OBJECT is a floating point number.")
+ "Return t if OBJECT is a floating point number.")
(object)
Lisp_Object object;
{
return Qt;
return Qnil;
}
-#endif /* LISP_FLOAT_TYPE */
+
\f
/* Extract and set components of lists */
while (1)
{
if (CONSP (list))
- return XCONS (list)->car;
+ return XCAR (list);
else if (EQ (list, Qnil))
return Qnil;
else
Lisp_Object object;
{
if (CONSP (object))
- return XCONS (object)->car;
+ return XCAR (object);
else
return Qnil;
}
while (1)
{
if (CONSP (list))
- return XCONS (list)->cdr;
+ return XCDR (list);
else if (EQ (list, Qnil))
return Qnil;
else
Lisp_Object object;
{
if (CONSP (object))
- return XCONS (object)->cdr;
+ return XCDR (object);
else
return Qnil;
}
cell = wrong_type_argument (Qconsp, cell);
CHECK_IMPURE (cell);
- XCONS (cell)->car = newcar;
+ XCAR (cell) = newcar;
return newcar;
}
cell = wrong_type_argument (Qconsp, cell);
CHECK_IMPURE (cell);
- XCONS (cell)->cdr = newcdr;
+ XCDR (cell) = newcdr;
return newcdr;
}
\f
/* Extract and set components of symbols */
-DEFUN ("boundp", Fboundp, Sboundp, 1, 1, 0, "T if SYMBOL's value is not void.")
+DEFUN ("boundp", Fboundp, Sboundp, 1, 1, 0, "Return t if SYMBOL's value is not void.")
(symbol)
register Lisp_Object symbol;
{
return (EQ (valcontents, Qunbound) ? Qnil : Qt);
}
-DEFUN ("fboundp", Ffboundp, Sfboundp, 1, 1, 0, "T if SYMBOL's function definition is not void.")
+DEFUN ("fboundp", Ffboundp, Sfboundp, 1, 1, 0, "Return t if SYMBOL's function definition is not void.")
(symbol)
register Lisp_Object symbol;
{
register Lisp_Object symbol;
{
CHECK_SYMBOL (symbol, 0);
- if (NILP (symbol) || EQ (symbol, Qt))
+ if (NILP (symbol) || EQ (symbol, Qt)
+ || (XSYMBOL (symbol)->name->data[0] == ':'
+ && EQ (XSYMBOL (symbol)->obarray, initial_obarray)))
return Fsignal (Qsetting_constant, Fcons (symbol, Qnil));
Fset (symbol, Qunbound);
return symbol;
}
DEFUN ("fset", Ffset, Sfset, 2, 2, 0,
- "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.")
- (symbol, newdef)
- register Lisp_Object symbol, newdef;
+ "Set SYMBOL's function definition to DEFINITION, and return DEFINITION.")
+ (symbol, definition)
+ register Lisp_Object symbol, definition;
{
CHECK_SYMBOL (symbol, 0);
if (NILP (symbol) || EQ (symbol, Qt))
if (!NILP (Vautoload_queue) && !EQ (XSYMBOL (symbol)->function, Qunbound))
Vautoload_queue = Fcons (Fcons (symbol, XSYMBOL (symbol)->function),
Vautoload_queue);
- XSYMBOL (symbol)->function = newdef;
+ XSYMBOL (symbol)->function = definition;
/* Handle automatic advice activation */
if (CONSP (XSYMBOL (symbol)->plist) && !NILP (Fget (symbol, Qad_advice_info)))
{
- call2 (Qad_activate, symbol, Qnil);
- newdef = XSYMBOL (symbol)->function;
+ call2 (Qad_activate_internal, symbol, Qnil);
+ definition = XSYMBOL (symbol)->function;
}
- return newdef;
+ return definition;
}
-/* This name should be removed once it is eliminated from elsewhere. */
-
DEFUN ("defalias", Fdefalias, Sdefalias, 2, 2, 0,
- "Set SYMBOL's function definition to NEWDEF, and return NEWDEF.\n\
+ "Set SYMBOL's function definition to DEFINITION, and return DEFINITION.\n\
Associates the function with the current load file, if any.")
- (symbol, newdef)
- register Lisp_Object symbol, newdef;
+ (symbol, definition)
+ register Lisp_Object symbol, definition;
{
- CHECK_SYMBOL (symbol, 0);
- if (!NILP (Vautoload_queue) && !EQ (XSYMBOL (symbol)->function, Qunbound))
- Vautoload_queue = Fcons (Fcons (symbol, XSYMBOL (symbol)->function),
- Vautoload_queue);
- XSYMBOL (symbol)->function = newdef;
- /* Handle automatic advice activation */
- if (CONSP (XSYMBOL (symbol)->plist) && !NILP (Fget (symbol, Qad_advice_info)))
- {
- call2 (Qad_activate, symbol, Qnil);
- newdef = XSYMBOL (symbol)->function;
- }
+ definition = Ffset (symbol, definition);
LOADHIST_ATTACH (symbol);
- return newdef;
-}
-
-DEFUN ("define-function", Fdefine_function, Sdefine_function, 2, 2, 0,
- "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.\n\
-Associates the function with the current load file, if any.")
- (symbol, newdef)
- register Lisp_Object symbol, newdef;
-{
- CHECK_SYMBOL (symbol, 0);
- if (!NILP (Vautoload_queue) && !EQ (XSYMBOL (symbol)->function, Qunbound))
- Vautoload_queue = Fcons (Fcons (symbol, XSYMBOL (symbol)->function),
- Vautoload_queue);
- XSYMBOL (symbol)->function = newdef;
- /* Handle automatic advice activation */
- if (CONSP (XSYMBOL (symbol)->plist) && !NILP (Fget (symbol, Qad_advice_info)))
- {
- call2 (Qad_activate, symbol, Qnil);
- newdef = XSYMBOL (symbol)->function;
- }
- LOADHIST_ATTACH (symbol);
- return newdef;
+ return definition;
}
DEFUN ("setplist", Fsetplist, Ssetplist, 2, 2, 0,
return newplist;
}
+DEFUN ("subr-arity", Fsubr_arity, Ssubr_arity, 1, 1, 0,
+ "Return minimum and maximum number of args allowed for SUBR.\n\
+SUBR must be a built-in function.\n\
+The returned value is a pair (MIN . MAX). MIN is the minimum number\n\
+of args. MAX is the maximum number or the symbol `many', for a\n\
+function with `&rest' args, or `unevalled' for a special form.")
+ (subr)
+ Lisp_Object subr;
+{
+ short minargs, maxargs;
+ if (!SUBRP (subr))
+ wrong_type_argument (Qsubrp, subr);
+ minargs = XSUBR (subr)->min_args;
+ maxargs = XSUBR (subr)->max_args;
+ if (maxargs == MANY)
+ return Fcons (make_number (minargs), Qmany);
+ else if (maxargs == UNEVALLED)
+ return Fcons (make_number (minargs), Qunevalled);
+ else
+ return Fcons (make_number (minargs), make_number (maxargs));
+}
+
\f
/* Getting and setting values of symbols */
case Lisp_Misc_Buffer_Objfwd:
offset = XBUFFER_OBJFWD (valcontents)->offset;
- return *(Lisp_Object *)(offset + (char *)current_buffer);
+ return PER_BUFFER_VALUE (current_buffer, offset);
case Lisp_Misc_Kboard_Objfwd:
offset = XKBOARD_OBJFWD (valcontents)->offset;
int offset = XBUFFER_OBJFWD (valcontents)->offset;
Lisp_Object type;
- type = *(Lisp_Object *)(offset + (char *)&buffer_local_types);
+ type = PER_BUFFER_TYPE (offset);
+ if (XINT (type) == -1)
+ error ("Variable %s is read-only", XSYMBOL (symbol)->name->data);
+
if (! NILP (type) && ! NILP (newval)
&& XTYPE (newval) != XINT (type))
buffer_slot_type_mismatch (offset);
- *(Lisp_Object *)(offset + (char *)current_buffer) = newval;
+ PER_BUFFER_VALUE (current_buffer, offset) = newval;
}
break;
valcontents = XSYMBOL (symbol)->value;
if (BUFFER_LOCAL_VALUEP (valcontents)
|| SOME_BUFFER_LOCAL_VALUEP (valcontents))
- XBUFFER_LOCAL_VALUE (valcontents)->car = newval;
+ XBUFFER_LOCAL_VALUE (valcontents)->realvalue = newval;
else
XSYMBOL (symbol)->value = newval;
}
}
-/* Set up the buffer-local symbol SYMBOL for validity in the current
- buffer. VALCONTENTS is the contents of its value cell.
- Return the value forwarded one step past the buffer-local indicator. */
+/* Set up SYMBOL to refer to its global binding.
+ This makes it safe to alter the status of other bindings. */
-static Lisp_Object
-swap_in_symval_forwarding (symbol, valcontents)
- Lisp_Object symbol, valcontents;
+void
+swap_in_global_binding (symbol)
+ Lisp_Object symbol;
{
- /* valcontents is a pointer to a struct resembling the cons
- (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE)).
+ Lisp_Object valcontents, cdr;
+
+ valcontents = XSYMBOL (symbol)->value;
+ if (!BUFFER_LOCAL_VALUEP (valcontents)
+ && !SOME_BUFFER_LOCAL_VALUEP (valcontents))
+ abort ();
+ cdr = XBUFFER_LOCAL_VALUE (valcontents)->cdr;
- CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
- local_var_alist, that being the element whose car is this
- variable. Or it can be a pointer to the
- (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not have
- an element in its alist for this variable.
+ /* Unload the previously loaded binding. */
+ Fsetcdr (XCAR (cdr),
+ do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents)->realvalue));
+
+ /* Select the global binding in the symbol. */
+ XCAR (cdr) = cdr;
+ store_symval_forwarding (symbol, valcontents, XCDR (cdr));
- If the current buffer is not BUFFER, we store the current
- REALVALUE value into CURRENT-ALIST-ELEMENT, then find the
- appropriate alist element for the buffer now current and set up
- CURRENT-ALIST-ELEMENT. Then we set REALVALUE out of that
- element, and store into BUFFER.
+ /* Indicate that the global binding is set up now. */
+ XBUFFER_LOCAL_VALUE (valcontents)->frame = Qnil;
+ XBUFFER_LOCAL_VALUE (valcontents)->buffer = Qnil;
+ XBUFFER_LOCAL_VALUE (valcontents)->found_for_frame = 0;
+ XBUFFER_LOCAL_VALUE (valcontents)->found_for_buffer = 0;
+}
+
+/* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
+ VALCONTENTS is the contents of its value cell,
+ which points to a struct Lisp_Buffer_Local_Value.
- Note that REALVALUE can be a forwarding pointer. */
+ Return the value forwarded one step past the buffer-local stage.
+ This could be another forwarding pointer. */
+static Lisp_Object
+swap_in_symval_forwarding (symbol, valcontents)
+ Lisp_Object symbol, valcontents;
+{
register Lisp_Object tem1;
- tem1 = XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->car;
+ tem1 = XBUFFER_LOCAL_VALUE (valcontents)->buffer;
- if (NILP (tem1) || current_buffer != XBUFFER (tem1))
+ if (NILP (tem1)
+ || current_buffer != XBUFFER (tem1)
+ || (XBUFFER_LOCAL_VALUE (valcontents)->check_frame
+ && ! EQ (selected_frame, XBUFFER_LOCAL_VALUE (valcontents)->frame)))
{
- tem1 = XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr)->car;
+ /* Unload the previously loaded binding. */
+ tem1 = XCAR (XBUFFER_LOCAL_VALUE (valcontents)->cdr);
Fsetcdr (tem1,
- do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents)->car));
+ do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents)->realvalue));
+ /* Choose the new binding. */
tem1 = assq_no_quit (symbol, current_buffer->local_var_alist);
+ XBUFFER_LOCAL_VALUE (valcontents)->found_for_frame = 0;
+ XBUFFER_LOCAL_VALUE (valcontents)->found_for_buffer = 0;
if (NILP (tem1))
- tem1 = XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr;
- XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr)->car = tem1;
- XSETBUFFER (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->car,
- current_buffer);
- store_symval_forwarding (symbol, XBUFFER_LOCAL_VALUE (valcontents)->car,
+ {
+ if (XBUFFER_LOCAL_VALUE (valcontents)->check_frame)
+ tem1 = assq_no_quit (symbol, XFRAME (selected_frame)->param_alist);
+ if (! NILP (tem1))
+ XBUFFER_LOCAL_VALUE (valcontents)->found_for_frame = 1;
+ else
+ tem1 = XBUFFER_LOCAL_VALUE (valcontents)->cdr;
+ }
+ else
+ XBUFFER_LOCAL_VALUE (valcontents)->found_for_buffer = 1;
+
+ /* Load the new binding. */
+ XCAR (XBUFFER_LOCAL_VALUE (valcontents)->cdr) = tem1;
+ XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents)->buffer, current_buffer);
+ XBUFFER_LOCAL_VALUE (valcontents)->frame = selected_frame;
+ store_symval_forwarding (symbol,
+ XBUFFER_LOCAL_VALUE (valcontents)->realvalue,
Fcdr (tem1));
}
- return XBUFFER_LOCAL_VALUE (valcontents)->car;
+ return XBUFFER_LOCAL_VALUE (valcontents)->realvalue;
}
\f
/* Find the value of a symbol, returning Qunbound if it's not bound.
find_symbol_value (symbol)
Lisp_Object symbol;
{
- register Lisp_Object valcontents, tem1;
+ register Lisp_Object valcontents;
register Lisp_Object val;
CHECK_SYMBOL (symbol, 0);
valcontents = XSYMBOL (symbol)->value;
if (BUFFER_LOCAL_VALUEP (valcontents)
|| SOME_BUFFER_LOCAL_VALUEP (valcontents))
- valcontents = swap_in_symval_forwarding (symbol, valcontents);
+ valcontents = swap_in_symval_forwarding (symbol, valcontents,
+ current_buffer);
if (MISCP (valcontents))
{
return *XOBJFWD (valcontents)->objvar;
case Lisp_Misc_Buffer_Objfwd:
- return *(Lisp_Object *)(XBUFFER_OBJFWD (valcontents)->offset
- + (char *)current_buffer);
+ return PER_BUFFER_VALUE (current_buffer,
+ XBUFFER_OBJFWD (valcontents)->offset);
case Lisp_Misc_Kboard_Objfwd:
return *(Lisp_Object *)(XKBOARD_OBJFWD (valcontents)->offset
"Set SYMBOL's value to NEWVAL, and return NEWVAL.")
(symbol, newval)
register Lisp_Object symbol, newval;
+{
+ return set_internal (symbol, newval, current_buffer, 0);
+}
+
+/* Return 1 if SYMBOL currently has a let-binding
+ which was made in the buffer that is now current. */
+
+static int
+let_shadows_buffer_binding_p (symbol)
+ Lisp_Object symbol;
+{
+ struct specbinding *p;
+
+ for (p = specpdl_ptr - 1; p >= specpdl; p--)
+ if (p->func == 0
+ && CONSP (p->symbol)
+ && EQ (symbol, XCAR (p->symbol))
+ && XBUFFER (XCDR (XCDR (p->symbol))) == current_buffer)
+ return 1;
+
+ return 0;
+}
+
+/* Store the value NEWVAL into SYMBOL.
+ If buffer-locality is an issue, BUF specifies which buffer to use.
+ (0 stands for the current buffer.)
+
+ If BINDFLAG is zero, then if this symbol is supposed to become
+ local in every buffer where it is set, then we make it local.
+ If BINDFLAG is nonzero, we don't do that. */
+
+Lisp_Object
+set_internal (symbol, newval, buf, bindflag)
+ register Lisp_Object symbol, newval;
+ struct buffer *buf;
+ int bindflag;
{
int voide = EQ (newval, Qunbound);
- register Lisp_Object valcontents, tem1, current_alist_element;
+ register Lisp_Object valcontents, innercontents, tem1, current_alist_element;
+
+ if (buf == 0)
+ buf = current_buffer;
+
+ /* If restoring in a dead buffer, do nothing. */
+ if (NILP (buf->name))
+ return newval;
CHECK_SYMBOL (symbol, 0);
- if (NILP (symbol) || EQ (symbol, Qt))
+ if (NILP (symbol) || EQ (symbol, Qt)
+ || (XSYMBOL (symbol)->name->data[0] == ':'
+ && EQ (XSYMBOL (symbol)->obarray, initial_obarray)
+ && !EQ (newval, symbol)))
return Fsignal (Qsetting_constant, Fcons (symbol, Qnil));
- valcontents = XSYMBOL (symbol)->value;
+
+ innercontents = valcontents = XSYMBOL (symbol)->value;
if (BUFFER_OBJFWDP (valcontents))
{
- register int idx = XBUFFER_OBJFWD (valcontents)->offset;
- register int mask = XINT (*((Lisp_Object *)
- (idx + (char *)&buffer_local_flags)));
- if (mask > 0)
- current_buffer->local_var_flags |= mask;
+ int offset = XBUFFER_OBJFWD (valcontents)->offset;
+ int idx = PER_BUFFER_IDX (offset);
+ if (idx > 0
+ && !bindflag
+ && !let_shadows_buffer_binding_p (symbol))
+ SET_PER_BUFFER_VALUE_P (buf, idx, 1);
}
else if (BUFFER_LOCAL_VALUEP (valcontents)
|| SOME_BUFFER_LOCAL_VALUEP (valcontents))
{
- /* valcontents is actually a pointer to a struct resembling a cons,
- with contents something like:
- (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE).
-
- BUFFER is the last buffer for which this symbol's value was
- made up to date.
-
- CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
- local_var_alist, that being the element whose car is this
- variable. Or it can be a pointer to the
- (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not
- have an element in its alist for this variable (that is, if
- BUFFER sees the default value of this variable).
-
- If we want to examine or set the value and BUFFER is current,
- we just examine or set REALVALUE. If BUFFER is not current, we
- store the current REALVALUE value into CURRENT-ALIST-ELEMENT,
- then find the appropriate alist element for the buffer now
- current and set up CURRENT-ALIST-ELEMENT. Then we set
- REALVALUE out of that element, and store into BUFFER.
-
- If we are setting the variable and the current buffer does
- not have an alist entry for this variable, an alist entry is
- created.
-
- Note that REALVALUE can be a forwarding pointer. Each time
- it is examined or set, forwarding must be done. */
-
- /* What value are we caching right now? */
- current_alist_element =
- XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr)->car;
+ /* valcontents is a struct Lisp_Buffer_Local_Value. */
+
+ /* What binding is loaded right now? */
+ current_alist_element
+ = XCAR (XBUFFER_LOCAL_VALUE (valcontents)->cdr);
/* If the current buffer is not the buffer whose binding is
- currently cached, or if it's a Lisp_Buffer_Local_Value and
- we're looking at the default value, the cache is invalid; we
- need to write it out, and find the new CURRENT-ALIST-ELEMENT. */
- if ((current_buffer
- != XBUFFER (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->car))
+ loaded, or if there may be frame-local bindings and the frame
+ isn't the right one, or if it's a Lisp_Buffer_Local_Value and
+ the default binding is loaded, the loaded binding may be the
+ wrong one. */
+ if (!BUFFERP (XBUFFER_LOCAL_VALUE (valcontents)->buffer)
+ || buf != XBUFFER (XBUFFER_LOCAL_VALUE (valcontents)->buffer)
+ || (XBUFFER_LOCAL_VALUE (valcontents)->check_frame
+ && !EQ (selected_frame, XBUFFER_LOCAL_VALUE (valcontents)->frame))
|| (BUFFER_LOCAL_VALUEP (valcontents)
- && EQ (XCONS (current_alist_element)->car,
+ && EQ (XCAR (current_alist_element),
current_alist_element)))
{
- /* Write out the cached value for the old buffer; copy it
- back to its alist element. This works if the current
- buffer only sees the default value, too. */
+ /* The currently loaded binding is not necessarily valid.
+ We need to unload it, and choose a new binding. */
+
+ /* Write out `realvalue' to the old loaded binding. */
Fsetcdr (current_alist_element,
- do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents)->car));
+ do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents)->realvalue));
+
+ /* Find the new binding. */
+ tem1 = Fassq (symbol, buf->local_var_alist);
+ XBUFFER_LOCAL_VALUE (valcontents)->found_for_buffer = 1;
+ XBUFFER_LOCAL_VALUE (valcontents)->found_for_frame = 0;
- /* Find the new value for CURRENT-ALIST-ELEMENT. */
- tem1 = Fassq (symbol, current_buffer->local_var_alist);
if (NILP (tem1))
{
/* This buffer still sees the default value. */
/* If the variable is a Lisp_Some_Buffer_Local_Value,
+ or if this is `let' rather than `set',
make CURRENT-ALIST-ELEMENT point to itself,
- indicating that we're seeing the default value. */
- if (SOME_BUFFER_LOCAL_VALUEP (valcontents))
- tem1 = XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr;
+ indicating that we're seeing the default value.
+ Likewise if the variable has been let-bound
+ in the current buffer. */
+ if (bindflag || SOME_BUFFER_LOCAL_VALUEP (valcontents)
+ || let_shadows_buffer_binding_p (symbol))
+ {
+ XBUFFER_LOCAL_VALUE (valcontents)->found_for_buffer = 0;
+
+ if (XBUFFER_LOCAL_VALUE (valcontents)->check_frame)
+ tem1 = Fassq (symbol,
+ XFRAME (selected_frame)->param_alist);
- /* If it's a Lisp_Buffer_Local_Value, give this buffer a
- new assoc for a local value and set
- CURRENT-ALIST-ELEMENT to point to that. */
+ if (! NILP (tem1))
+ XBUFFER_LOCAL_VALUE (valcontents)->found_for_frame = 1;
+ else
+ tem1 = XBUFFER_LOCAL_VALUE (valcontents)->cdr;
+ }
+ /* If it's a Lisp_Buffer_Local_Value, being set not bound,
+ and we're not within a let that was made for this buffer,
+ create a new buffer-local binding for the variable.
+ That means, give this buffer a new assoc for a local value
+ and load that binding. */
else
{
tem1 = Fcons (symbol, Fcdr (current_alist_element));
- current_buffer->local_var_alist =
- Fcons (tem1, current_buffer->local_var_alist);
+ buf->local_var_alist
+ = Fcons (tem1, buf->local_var_alist);
}
}
- /* Cache the new buffer's assoc in CURRENT-ALIST-ELEMENT. */
- XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr)->car
+
+ /* Record which binding is now loaded. */
+ XCAR (XBUFFER_LOCAL_VALUE (valcontents)->cdr)
= tem1;
- /* Set BUFFER, now that CURRENT-ALIST-ELEMENT is accurate. */
- XSETBUFFER (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->car,
- current_buffer);
+ /* Set `buffer' and `frame' slots for thebinding now loaded. */
+ XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents)->buffer, buf);
+ XBUFFER_LOCAL_VALUE (valcontents)->frame = selected_frame;
}
- valcontents = XBUFFER_LOCAL_VALUE (valcontents)->car;
+ innercontents = XBUFFER_LOCAL_VALUE (valcontents)->realvalue;
}
/* If storing void (making the symbol void), forward only through
if (voide)
store_symval_forwarding (symbol, Qnil, newval);
else
- store_symval_forwarding (symbol, valcontents, newval);
+ store_symval_forwarding (symbol, innercontents, newval);
+
+ /* If we just set a variable whose current binding is frame-local,
+ store the new value in the frame parameter too. */
+
+ if (BUFFER_LOCAL_VALUEP (valcontents)
+ || SOME_BUFFER_LOCAL_VALUEP (valcontents))
+ {
+ /* What binding is loaded right now? */
+ current_alist_element
+ = XCAR (XBUFFER_LOCAL_VALUE (valcontents)->cdr);
+
+ /* If the current buffer is not the buffer whose binding is
+ loaded, or if there may be frame-local bindings and the frame
+ isn't the right one, or if it's a Lisp_Buffer_Local_Value and
+ the default binding is loaded, the loaded binding may be the
+ wrong one. */
+ if (XBUFFER_LOCAL_VALUE (valcontents)->found_for_frame)
+ XCDR (current_alist_element) = newval;
+ }
return newval;
}
rather than letting do_symval_forwarding get the current value. */
if (BUFFER_OBJFWDP (valcontents))
{
- register int idx = XBUFFER_OBJFWD (valcontents)->offset;
-
- if (XINT (*(Lisp_Object *) (idx + (char *) &buffer_local_flags)) != 0)
- return *(Lisp_Object *)(idx + (char *) &buffer_defaults);
+ int offset = XBUFFER_OBJFWD (valcontents)->offset;
+ if (PER_BUFFER_IDX (offset) != 0)
+ return PER_BUFFER_DEFAULT (offset);
}
/* Handle user-created local variables. */
{
/* If var is set up for a buffer that lacks a local value for it,
the current value is nominally the default value.
- But the current value slot may be more up to date, since
+ But the `realvalue' slot may be more up to date, since
ordinary setq stores just that slot. So use that. */
Lisp_Object current_alist_element, alist_element_car;
current_alist_element
- = XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr)->car;
- alist_element_car = XCONS (current_alist_element)->car;
+ = XCAR (XBUFFER_LOCAL_VALUE (valcontents)->cdr);
+ alist_element_car = XCAR (current_alist_element);
if (EQ (alist_element_car, current_alist_element))
- return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents)->car);
+ return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents)->realvalue);
else
- return XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr)->cdr;
+ return XCDR (XBUFFER_LOCAL_VALUE (valcontents)->cdr);
}
/* For other variables, get the current value. */
return do_symval_forwarding (valcontents);
}
DEFUN ("default-boundp", Fdefault_boundp, Sdefault_boundp, 1, 1, 0,
- "Return T if SYMBOL has a non-void default value.\n\
+ "Return t if SYMBOL has a non-void default value.\n\
This is the value that is seen in buffers that do not have their own values\n\
for this variable.")
(symbol)
variables. */
if (BUFFER_OBJFWDP (valcontents))
{
- register int idx = XBUFFER_OBJFWD (valcontents)->offset;
- register struct buffer *b;
- register int mask = XINT (*((Lisp_Object *)
- (idx + (char *)&buffer_local_flags)));
+ int offset = XBUFFER_OBJFWD (valcontents)->offset;
+ int idx = PER_BUFFER_IDX (offset);
- if (mask > 0)
+ PER_BUFFER_DEFAULT (offset) = value;
+
+ /* If this variable is not always local in all buffers,
+ set it in the buffers that don't nominally have a local value. */
+ if (idx > 0)
{
- *(Lisp_Object *)(idx + (char *) &buffer_defaults) = value;
+ struct buffer *b;
+
for (b = all_buffers; b; b = b->next)
- if (!(b->local_var_flags & mask))
- *(Lisp_Object *)(idx + (char *) b) = value;
+ if (!PER_BUFFER_VALUE_P (b, idx))
+ PER_BUFFER_VALUE (b, offset) = value;
}
return value;
}
&& !SOME_BUFFER_LOCAL_VALUEP (valcontents))
return Fset (symbol, value);
- /* Store new value into the DEFAULT-VALUE slot */
- XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr)->cdr = value;
+ /* Store new value into the DEFAULT-VALUE slot. */
+ XCDR (XBUFFER_LOCAL_VALUE (valcontents)->cdr) = value;
- /* If that slot is current, we must set the REALVALUE slot too */
+ /* If the default binding is now loaded, set the REALVALUE slot too. */
current_alist_element
- = XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr)->car;
+ = XCAR (XBUFFER_LOCAL_VALUE (valcontents)->cdr);
alist_element_buffer = Fcar (current_alist_element);
if (EQ (alist_element_buffer, current_alist_element))
- store_symval_forwarding (symbol, XBUFFER_LOCAL_VALUE (valcontents)->car,
+ store_symval_forwarding (symbol, XBUFFER_LOCAL_VALUE (valcontents)->realvalue,
value);
return value;
DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local, Smake_variable_buffer_local,
1, 1, "vMake Variable Buffer Local: ",
- "Make VARIABLE have a separate value for each buffer.\n\
-At any time, the value for the current buffer is in effect.\n\
-There is also a default value which is seen in any buffer which has not yet\n\
-set its own value.\n\
-Using `set' or `setq' to set the variable causes it to have a separate value\n\
-for the current buffer if it was previously using the default value.\n\
+ "Make VARIABLE become buffer-local whenever it is set.\n\
+At any time, the value for the current buffer is in effect,\n\
+unless the variable has never been set in this buffer,\n\
+in which case the default value is in effect.\n\
+Note that binding the variable with `let', or setting it while\n\
+a `let'-style binding made in this buffer is in effect,\n\
+does not make the variable buffer-local.\n\
+\n\
The function `default-value' gets the default value and `set-default' sets it.")
(variable)
register Lisp_Object variable;
if (EQ (valcontents, Qunbound))
XSYMBOL (variable)->value = Qnil;
tem = Fcons (Qnil, Fsymbol_value (variable));
- XCONS (tem)->car = tem;
+ XCAR (tem) = tem;
newval = allocate_misc ();
XMISCTYPE (newval) = Lisp_Misc_Buffer_Local_Value;
- XBUFFER_LOCAL_VALUE (newval)->car = XSYMBOL (variable)->value;
- XBUFFER_LOCAL_VALUE (newval)->cdr = Fcons (Fcurrent_buffer (), tem);
+ XBUFFER_LOCAL_VALUE (newval)->realvalue = XSYMBOL (variable)->value;
+ XBUFFER_LOCAL_VALUE (newval)->buffer = Fcurrent_buffer ();
+ XBUFFER_LOCAL_VALUE (newval)->frame = Qnil;
+ XBUFFER_LOCAL_VALUE (newval)->found_for_buffer = 0;
+ XBUFFER_LOCAL_VALUE (newval)->found_for_frame = 0;
+ XBUFFER_LOCAL_VALUE (newval)->check_frame = 0;
+ XBUFFER_LOCAL_VALUE (newval)->cdr = tem;
XSYMBOL (variable)->value = newval;
return variable;
}
Other buffers will continue to share a common default value.\n\
\(The buffer-local value of VARIABLE starts out as the same value\n\
VARIABLE previously had. If VARIABLE was void, it remains void.\)\n\
-See also `make-variable-buffer-local'.\n\n\
+See also `make-variable-buffer-local'.\n\
+\n\
If the variable is already arranged to become local when set,\n\
this function causes a local value to exist for this buffer,\n\
just as setting the variable would do.\n\
\n\
+This function returns VARIABLE, and therefore\n\
+ (set (make-local-variable 'VARIABLE) VALUE-EXP)\n\
+works.\n\
+\n\
Do not use `make-local-variable' to make a hook variable buffer-local.\n\
Use `make-local-hook' instead.")
(variable)
Fset (variable, (EQ (tem, Qt) ? Fsymbol_value (variable) : Qunbound));
return variable;
}
- /* Make sure symbol is set up to hold per-buffer values */
+ /* Make sure symbol is set up to hold per-buffer values. */
if (!SOME_BUFFER_LOCAL_VALUEP (valcontents))
{
Lisp_Object newval;
tem = Fcons (Qnil, do_symval_forwarding (valcontents));
- XCONS (tem)->car = tem;
+ XCAR (tem) = tem;
newval = allocate_misc ();
XMISCTYPE (newval) = Lisp_Misc_Some_Buffer_Local_Value;
- XBUFFER_LOCAL_VALUE (newval)->car = XSYMBOL (variable)->value;
- XBUFFER_LOCAL_VALUE (newval)->cdr = Fcons (Qnil, tem);
+ XBUFFER_LOCAL_VALUE (newval)->realvalue = XSYMBOL (variable)->value;
+ XBUFFER_LOCAL_VALUE (newval)->buffer = Qnil;
+ XBUFFER_LOCAL_VALUE (newval)->frame = Qnil;
+ XBUFFER_LOCAL_VALUE (newval)->found_for_buffer = 0;
+ XBUFFER_LOCAL_VALUE (newval)->found_for_frame = 0;
+ XBUFFER_LOCAL_VALUE (newval)->check_frame = 0;
+ XBUFFER_LOCAL_VALUE (newval)->cdr = tem;
XSYMBOL (variable)->value = newval;
}
- /* Make sure this buffer has its own value of symbol */
+ /* Make sure this buffer has its own value of symbol. */
tem = Fassq (variable, current_buffer->local_var_alist);
if (NILP (tem))
{
find_symbol_value (variable);
current_buffer->local_var_alist
- = Fcons (Fcons (variable, XCONS (XCONS (XBUFFER_LOCAL_VALUE (XSYMBOL (variable)->value)->cdr)->cdr)->cdr),
+ = Fcons (Fcons (variable, XCDR (XBUFFER_LOCAL_VALUE (XSYMBOL (variable)->value)->cdr)),
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 */
+ force it to look once again for this buffer's value. */
{
Lisp_Object *pvalbuf;
valcontents = XSYMBOL (variable)->value;
- pvalbuf = &XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->car;
+ pvalbuf = &XBUFFER_LOCAL_VALUE (valcontents)->buffer;
if (current_buffer == XBUFFER (*pvalbuf))
*pvalbuf = Qnil;
+ XBUFFER_LOCAL_VALUE (valcontents)->found_for_buffer = 0;
}
}
- /* If the symbol forwards into a C variable, then swap in the
- variable for this buffer immediately. If C code modifies the
- variable before we swap in, then that new value will clobber the
- default value the next time we swap. */
- valcontents = XBUFFER_LOCAL_VALUE (XSYMBOL (variable)->value)->car;
+ /* 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. */
+ valcontents = XBUFFER_LOCAL_VALUE (XSYMBOL (variable)->value)->realvalue;
if (INTFWDP (valcontents) || BOOLFWDP (valcontents) || OBJFWDP (valcontents))
swap_in_symval_forwarding (variable, XSYMBOL (variable)->value);
if (BUFFER_OBJFWDP (valcontents))
{
- register int idx = XBUFFER_OBJFWD (valcontents)->offset;
- register int mask = XINT (*((Lisp_Object*)
- (idx + (char *)&buffer_local_flags)));
+ int offset = XBUFFER_OBJFWD (valcontents)->offset;
+ int idx = PER_BUFFER_IDX (offset);
- if (mask > 0)
+ if (idx > 0)
{
- *(Lisp_Object *)(idx + (char *) current_buffer)
- = *(Lisp_Object *)(idx + (char *) &buffer_defaults);
- current_buffer->local_var_flags &= ~mask;
+ SET_PER_BUFFER_VALUE_P (current_buffer, idx, 0);
+ PER_BUFFER_VALUE (current_buffer, offset)
+ = PER_BUFFER_DEFAULT (offset);
}
return variable;
}
&& !SOME_BUFFER_LOCAL_VALUEP (valcontents))
return variable;
- /* Get rid of this buffer's alist element, if any */
+ /* Get rid of this buffer's alist element, if any. */
tem = Fassq (variable, current_buffer->local_var_alist);
if (!NILP (tem))
current_buffer->local_var_alist
= Fdelq (tem, current_buffer->local_var_alist);
- /* If the symbol is set up for the current buffer, recompute its
- value. We have to do it now, or else forwarded objects won't
- work right. */
+ /* If the symbol is set up with the current buffer's binding
+ loaded, recompute its value. We have to do it now, or else
+ forwarded objects won't work right. */
{
Lisp_Object *pvalbuf;
valcontents = XSYMBOL (variable)->value;
- pvalbuf = &XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->car;
+ pvalbuf = &XBUFFER_LOCAL_VALUE (valcontents)->buffer;
if (current_buffer == XBUFFER (*pvalbuf))
{
*pvalbuf = Qnil;
+ XBUFFER_LOCAL_VALUE (valcontents)->found_for_buffer = 0;
find_symbol_value (variable);
}
}
return variable;
}
+/* Lisp functions for creating and removing buffer-local variables. */
+
+DEFUN ("make-variable-frame-local", Fmake_variable_frame_local, Smake_variable_frame_local,
+ 1, 1, "vMake Variable Frame Local: ",
+ "Enable VARIABLE to have frame-local bindings.\n\
+When a frame-local binding exists in the current frame,\n\
+it is in effect whenever the current buffer has no buffer-local binding.\n\
+A frame-local binding is actual a frame parameter value;\n\
+thus, any given frame has a local binding for VARIABLE\n\
+if it has a value for the frame parameter named VARIABLE.\n\
+See `modify-frame-parameters'.")
+ (variable)
+ register Lisp_Object variable;
+{
+ register Lisp_Object tem, valcontents, newval;
+
+ CHECK_SYMBOL (variable, 0);
+
+ valcontents = XSYMBOL (variable)->value;
+ if (EQ (variable, Qnil) || EQ (variable, Qt) || KBOARD_OBJFWDP (valcontents)
+ || BUFFER_OBJFWDP (valcontents))
+ error ("Symbol %s may not be frame-local", XSYMBOL (variable)->name->data);
+
+ if (BUFFER_LOCAL_VALUEP (valcontents)
+ || SOME_BUFFER_LOCAL_VALUEP (valcontents))
+ {
+ XBUFFER_LOCAL_VALUE (valcontents)->check_frame = 1;
+ return variable;
+ }
+
+ if (EQ (valcontents, Qunbound))
+ XSYMBOL (variable)->value = Qnil;
+ tem = Fcons (Qnil, Fsymbol_value (variable));
+ XCAR (tem) = tem;
+ newval = allocate_misc ();
+ XMISCTYPE (newval) = Lisp_Misc_Some_Buffer_Local_Value;
+ XBUFFER_LOCAL_VALUE (newval)->realvalue = XSYMBOL (variable)->value;
+ XBUFFER_LOCAL_VALUE (newval)->buffer = Qnil;
+ XBUFFER_LOCAL_VALUE (newval)->frame = Qnil;
+ XBUFFER_LOCAL_VALUE (newval)->found_for_buffer = 0;
+ XBUFFER_LOCAL_VALUE (newval)->found_for_frame = 0;
+ XBUFFER_LOCAL_VALUE (newval)->check_frame = 1;
+ XBUFFER_LOCAL_VALUE (newval)->cdr = tem;
+ XSYMBOL (variable)->value = newval;
+ return variable;
+}
+
DEFUN ("local-variable-p", Flocal_variable_p, Slocal_variable_p,
1, 2, 0,
"Non-nil if VARIABLE has a local binding in buffer BUFFER.\n\
|| SOME_BUFFER_LOCAL_VALUEP (valcontents))
{
Lisp_Object tail, elt;
- for (tail = buf->local_var_alist; CONSP (tail); tail = XCONS (tail)->cdr)
+ for (tail = buf->local_var_alist; CONSP (tail); tail = XCDR (tail))
{
- elt = XCONS (tail)->car;
- if (EQ (variable, XCONS (elt)->car))
+ elt = XCAR (tail);
+ if (EQ (variable, XCAR (elt)))
return Qt;
}
}
if (BUFFER_OBJFWDP (valcontents))
{
int offset = XBUFFER_OBJFWD (valcontents)->offset;
- int mask = XINT (*(Lisp_Object *)(offset + (char *)&buffer_local_flags));
- if (mask == -1 || (buf->local_var_flags & mask))
+ int idx = PER_BUFFER_IDX (offset);
+ if (idx == -1 || PER_BUFFER_VALUE_P (buf, idx))
return Qt;
}
return Qnil;
if (SOME_BUFFER_LOCAL_VALUEP (valcontents))
{
Lisp_Object tail, elt;
- for (tail = buf->local_var_alist; CONSP (tail); tail = XCONS (tail)->cdr)
+ for (tail = buf->local_var_alist; CONSP (tail); tail = XCDR (tail))
{
- elt = XCONS (tail)->car;
- if (EQ (variable, XCONS (elt)->car))
+ elt = XCAR (tail);
+ if (EQ (variable, XCAR (elt)))
return Qt;
}
}
idxval = XINT (idx);
if (STRINGP (array))
{
- Lisp_Object val;
+ int c, idxval_byte;
+
if (idxval < 0 || idxval >= XSTRING (array)->size)
args_out_of_range (array, idx);
- XSETFASTINT (val, (unsigned char) XSTRING (array)->data[idxval]);
- return val;
+ if (! STRING_MULTIBYTE (array))
+ return make_number ((unsigned char) XSTRING (array)->data[idxval]);
+ idxval_byte = string_char_to_byte (array, idxval);
+
+ c = STRING_CHAR (&XSTRING (array)->data[idxval_byte],
+ STRING_BYTES (XSTRING (array)) - idxval_byte);
+ return make_number (c);
}
else if (BOOL_VECTOR_P (array))
{
if (idxval < 0)
args_out_of_range (array, idx);
-#if 1
- if ((unsigned) idxval >= CHAR_TABLE_ORDINARY_SLOTS)
- args_out_of_range (array, idx);
- return val = XCHAR_TABLE (array)->contents[idxval];
-#else /* 0 */
- if ((unsigned) idxval < CHAR_TABLE_ORDINARY_SLOTS)
- val = XCHAR_TABLE (array)->data[idxval];
- else
+ if (idxval < CHAR_TABLE_ORDINARY_SLOTS)
{
- int charset;
- unsigned char c1, c2;
- Lisp_Object val, temp;
-
- BREAKUP_NON_ASCII_CHAR (idxval, charset, c1, c2);
-
- try_parent_char_table:
- val = XCHAR_TABLE (array)->contents[charset];
- if (c1 == 0 || !CHAR_TABLE_P (val))
- return val;
-
- temp = XCHAR_TABLE (val)->contents[c1];
- if (NILP (temp))
- val = XCHAR_TABLE (val)->defalt;
- else
- val = temp;
-
- if (NILP (val) && !NILP (XCHAR_TABLE (array)->parent))
+ /* For ASCII and 8-bit European characters, the element is
+ stored in the top table. */
+ val = XCHAR_TABLE (array)->contents[idxval];
+ if (NILP (val))
+ val = XCHAR_TABLE (array)->defalt;
+ while (NILP (val)) /* Follow parents until we find some value. */
{
array = XCHAR_TABLE (array)->parent;
- goto try_parent_char_table;
-
+ if (NILP (array))
+ return Qnil;
+ val = XCHAR_TABLE (array)->contents[idxval];
+ if (NILP (val))
+ val = XCHAR_TABLE (array)->defalt;
}
+ return val;
+ }
+ else
+ {
+ int code[4], i;
+ Lisp_Object sub_table;
- if (c2 == 0 || !CHAR_TABLE_P (val))
- return val;
+ SPLIT_CHAR (idxval, code[0], code[1], code[2]);
+ if (code[1] < 32) code[1] = -1;
+ else if (code[2] < 32) code[2] = -1;
- temp = XCHAR_TABLE (val)->contents[c2];
- if (NILP (temp))
- val = XCHAR_TABLE (val)->defalt;
- else
- val = temp;
+ /* Here, the possible range of CODE[0] (== charset ID) is
+ 128..MAX_CHARSET. Since the top level char table contains
+ data for multibyte characters after 256th element, we must
+ increment CODE[0] by 128 to get a correct index. */
+ code[0] += 128;
+ code[3] = -1; /* anchor */
- if (NILP (val) && !NILP (XCHAR_TABLE (array)->parent))
+ try_parent_char_table:
+ sub_table = array;
+ for (i = 0; code[i] >= 0; i++)
+ {
+ val = XCHAR_TABLE (sub_table)->contents[code[i]];
+ if (SUB_CHAR_TABLE_P (val))
+ sub_table = val;
+ else
+ {
+ if (NILP (val))
+ val = XCHAR_TABLE (sub_table)->defalt;
+ if (NILP (val))
+ {
+ array = XCHAR_TABLE (array)->parent;
+ if (!NILP (array))
+ goto try_parent_char_table;
+ }
+ return val;
+ }
+ }
+ /* Here, VAL is a sub char table. We try the default value
+ and parent. */
+ val = XCHAR_TABLE (val)->defalt;
+ if (NILP (val))
{
array = XCHAR_TABLE (array)->parent;
- goto try_parent_char_table;
+ if (!NILP (array))
+ goto try_parent_char_table;
}
-
return val;
}
-#endif /* 0 */
}
else
{
}
}
+/* Don't use alloca for relocating string data larger than this, lest
+ we overflow their stack. The value is the same as what used in
+ fns.c for base64 handling. */
+#define MAX_ALLOCA 16*1024
+
DEFUN ("aset", Faset, Saset, 3, 3, 0,
"Store into the element of ARRAY at index IDX the value NEWELT.\n\
-ARRAY may be a vector or a string. IDX starts at 0.")
+ARRAY may be a vector, a string, a char-table or a bool-vector.\n\
+IDX starts at 0.")
(array, idx, newelt)
register Lisp_Object array;
Lisp_Object idx, newelt;
}
else if (CHAR_TABLE_P (array))
{
- Lisp_Object val;
-
if (idxval < 0)
args_out_of_range (array, idx);
-#if 1
- if (idxval >= CHAR_TABLE_ORDINARY_SLOTS)
- args_out_of_range (array, idx);
- XCHAR_TABLE (array)->contents[idxval] = newelt;
- return newelt;
-#else /* 0 */
if (idxval < CHAR_TABLE_ORDINARY_SLOTS)
- val = XCHAR_TABLE (array)->contents[idxval];
+ XCHAR_TABLE (array)->contents[idxval] = newelt;
else
{
- int charset;
- unsigned char c1, c2;
- Lisp_Object val, val2;
+ int code[4], i;
+ Lisp_Object val;
- BREAKUP_NON_ASCII_CHAR (idxval, charset, c1, c2);
+ SPLIT_CHAR (idxval, code[0], code[1], code[2]);
+ if (code[1] < 32) code[1] = -1;
+ else if (code[2] < 32) code[2] = -1;
- if (c1 == 0)
- return XCHAR_TABLE (array)->contents[charset] = newelt;
+ /* See the comment of the corresponding part in Faref. */
+ code[0] += 128;
+ code[3] = -1; /* anchor */
+ for (i = 0; code[i + 1] >= 0; i++)
+ {
+ val = XCHAR_TABLE (array)->contents[code[i]];
+ if (SUB_CHAR_TABLE_P (val))
+ array = val;
+ else
+ {
+ Lisp_Object temp;
- val = XCHAR_TABLE (array)->contents[charset];
- if (!CHAR_TABLE_P (val))
- XCHAR_TABLE (array)->contents[charset]
- = val = Fmake_char_table (Qnil);
+ /* VAL is a leaf. Create a sub char table with the
+ default value VAL or XCHAR_TABLE (array)->defalt
+ and look into it. */
- if (c2 == 0)
- return XCHAR_TABLE (val)->contents[c1] = newelt;
+ temp = make_sub_char_table (NILP (val)
+ ? XCHAR_TABLE (array)->defalt
+ : val);
+ XCHAR_TABLE (array)->contents[code[i]] = temp;
+ array = temp;
+ }
+ }
+ XCHAR_TABLE (array)->contents[code[i]] = newelt;
+ }
+ }
+ else if (STRING_MULTIBYTE (array))
+ {
+ int idxval_byte, prev_bytes, new_bytes;
+ unsigned char workbuf[MAX_MULTIBYTE_LENGTH], *p0 = workbuf, *p1;
- val2 = XCHAR_TABLE (val)->contents[c2];
- if (!CHAR_TABLE_P (val2))
- XCHAR_TABLE (val)->contents[charset]
- = val2 = Fmake_char_table (Qnil);
+ if (idxval < 0 || idxval >= XSTRING (array)->size)
+ args_out_of_range (array, idx);
+ CHECK_NUMBER (newelt, 2);
- return XCHAR_TABLE (val2)->contents[c2] = newelt;
+ idxval_byte = string_char_to_byte (array, idxval);
+ p1 = &XSTRING (array)->data[idxval_byte];
+ PARSE_MULTIBYTE_SEQ (p1, nbytes - idxval_byte, prev_bytes);
+ new_bytes = CHAR_STRING (XINT (newelt), p0);
+ if (prev_bytes != new_bytes)
+ {
+ /* We must relocate the string data. */
+ int nchars = XSTRING (array)->size;
+ int nbytes = STRING_BYTES (XSTRING (array));
+ unsigned char *str;
+
+ str = (nbytes <= MAX_ALLOCA
+ ? (unsigned char *) alloca (nbytes)
+ : (unsigned char *) xmalloc (nbytes));
+ bcopy (XSTRING (array)->data, str, nbytes);
+ allocate_string_data (XSTRING (array), nchars,
+ nbytes + new_bytes - prev_bytes);
+ bcopy (str, XSTRING (array)->data, idxval_byte);
+ p1 = XSTRING (array)->data + idxval_byte;
+ bcopy (str + idxval_byte + prev_bytes, p1 + new_bytes,
+ nbytes - (idxval_byte + prev_bytes));
+ if (nbytes > MAX_ALLOCA)
+ xfree (str);
+ clear_string_char_byte_cache ();
}
-#endif /* 0 */
+ while (new_bytes--)
+ *p1++ = *p0++;
}
else
{
if (idxval < 0 || idxval >= XSTRING (array)->size)
args_out_of_range (array, idx);
CHECK_NUMBER (newelt, 2);
- XSTRING (array)->data[idxval] = XINT (newelt);
+
+ if (XINT (newelt) < 0 || SINGLE_BYTE_CHAR_P (XINT (newelt)))
+ XSTRING (array)->data[idxval] = XINT (newelt);
+ else
+ {
+ /* We must relocate the string data while converting it to
+ multibyte. */
+ int idxval_byte, prev_bytes, new_bytes;
+ unsigned char workbuf[MAX_MULTIBYTE_LENGTH], *p0 = workbuf, *p1;
+ unsigned char *origstr = XSTRING (array)->data, *str;
+ int nchars, nbytes;
+
+ nchars = XSTRING (array)->size;
+ nbytes = idxval_byte = count_size_as_multibyte (origstr, idxval);
+ nbytes += count_size_as_multibyte (origstr + idxval,
+ nchars - idxval);
+ str = (nbytes <= MAX_ALLOCA
+ ? (unsigned char *) alloca (nbytes)
+ : (unsigned char *) xmalloc (nbytes));
+ copy_text (XSTRING (array)->data, str, nchars, 0, 1);
+ PARSE_MULTIBYTE_SEQ (str + idxval_byte, nbytes - idxval_byte,
+ prev_bytes);
+ new_bytes = CHAR_STRING (XINT (newelt), p0);
+ allocate_string_data (XSTRING (array), nchars,
+ nbytes + new_bytes - prev_bytes);
+ bcopy (str, XSTRING (array)->data, idxval_byte);
+ p1 = XSTRING (array)->data + idxval_byte;
+ while (new_bytes--)
+ *p1++ = *p0++;
+ bcopy (str + idxval_byte + prev_bytes, p1,
+ nbytes - (idxval_byte + prev_bytes));
+ if (nbytes > MAX_ALLOCA)
+ xfree (str);
+ clear_string_char_byte_cache ();
+ }
}
return newelt;
double f1, f2;
int floatp = 0;
-#ifdef LISP_FLOAT_TYPE
CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1, 0);
CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2, 0);
if (FLOATP (num1) || FLOATP (num2))
{
floatp = 1;
- f1 = (FLOATP (num1)) ? XFLOAT (num1)->data : XINT (num1);
- f2 = (FLOATP (num2)) ? XFLOAT (num2)->data : XINT (num2);
+ f1 = (FLOATP (num1)) ? XFLOAT_DATA (num1) : XINT (num1);
+ f2 = (FLOATP (num2)) ? XFLOAT_DATA (num2) : XINT (num2);
}
-#else
- CHECK_NUMBER_COERCE_MARKER (num1, 0);
- CHECK_NUMBER_COERCE_MARKER (num2, 0);
-#endif /* LISP_FLOAT_TYPE */
switch (comparison)
{
}
DEFUN ("=", Feqlsign, Seqlsign, 2, 2, 0,
- "T if two args, both numbers or markers, are equal.")
+ "Return t if two args, both numbers or markers, are equal.")
(num1, num2)
register Lisp_Object num1, num2;
{
}
DEFUN ("<", Flss, Slss, 2, 2, 0,
- "T if first arg is less than second arg. Both must be numbers or markers.")
+ "Return t if first arg is less than second arg. Both must be numbers or markers.")
(num1, num2)
register Lisp_Object num1, num2;
{
}
DEFUN (">", Fgtr, Sgtr, 2, 2, 0,
- "T if first arg is greater than second arg. Both must be numbers or markers.")
+ "Return t if first arg is greater than second arg. Both must be numbers or markers.")
(num1, num2)
register Lisp_Object num1, num2;
{
}
DEFUN ("<=", Fleq, Sleq, 2, 2, 0,
- "T if first arg is less than or equal to second arg.\n\
+ "Return t if first arg is less than or equal to second arg.\n\
Both must be numbers or markers.")
(num1, num2)
register Lisp_Object num1, num2;
}
DEFUN (">=", Fgeq, Sgeq, 2, 2, 0,
- "T if first arg is greater than or equal to second arg.\n\
+ "Return t if first arg is greater than or equal to second arg.\n\
Both must be numbers or markers.")
(num1, num2)
register Lisp_Object num1, num2;
}
DEFUN ("/=", Fneq, Sneq, 2, 2, 0,
- "T if first arg is not equal to second arg. Both must be numbers or markers.")
+ "Return t if first arg is not equal to second arg. Both must be numbers or markers.")
(num1, num2)
register Lisp_Object num1, num2;
{
return arithcompare (num1, num2, notequal);
}
-DEFUN ("zerop", Fzerop, Szerop, 1, 1, 0, "T if NUMBER is zero.")
+DEFUN ("zerop", Fzerop, Szerop, 1, 1, 0, "Return t if NUMBER is zero.")
(number)
register Lisp_Object number;
{
-#ifdef LISP_FLOAT_TYPE
CHECK_NUMBER_OR_FLOAT (number, 0);
if (FLOATP (number))
{
- if (XFLOAT(number)->data == 0.0)
+ if (XFLOAT_DATA (number) == 0.0)
return Qt;
return Qnil;
}
-#else
- CHECK_NUMBER (number, 0);
-#endif /* LISP_FLOAT_TYPE */
if (!XINT (number))
return Qt;
Lisp_Object top, bot;
if (INTEGERP (c))
return XINT (c);
- top = XCONS (c)->car;
- bot = XCONS (c)->cdr;
+ top = XCAR (c);
+ bot = XCDR (c);
if (CONSP (bot))
- bot = XCONS (bot)->car;
+ bot = XCAR (bot);
return ((XINT (top) << 16) | XINT (bot));
}
\f
{
char buffer[VALBITS];
-#ifndef LISP_FLOAT_TYPE
- CHECK_NUMBER (number, 0);
-#else
CHECK_NUMBER_OR_FLOAT (number, 0);
if (FLOATP (number))
{
char pigbuf[350]; /* see comments in float_to_string */
- float_to_string (pigbuf, XFLOAT(number)->data);
+ float_to_string (pigbuf, XFLOAT_DATA (number));
return build_string (pigbuf);
}
-#endif /* LISP_FLOAT_TYPE */
if (sizeof (int) == sizeof (EMACS_INT))
sprintf (buffer, "%d", XINT (number));
else if (sizeof (long) == sizeof (EMACS_INT))
- sprintf (buffer, "%ld", XINT (number));
+ sprintf (buffer, "%ld", (long) XINT (number));
else
abort ();
return build_string (buffer);
}
-DEFUN ("string-to-number", Fstring_to_number, Sstring_to_number, 1, 1, 0,
+INLINE static int
+digit_to_number (character, base)
+ int character, base;
+{
+ int digit;
+
+ if (character >= '0' && character <= '9')
+ digit = character - '0';
+ else if (character >= 'a' && character <= 'z')
+ digit = character - 'a' + 10;
+ else if (character >= 'A' && character <= 'Z')
+ digit = character - 'A' + 10;
+ else
+ return -1;
+
+ if (digit >= base)
+ return -1;
+ else
+ return digit;
+}
+
+DEFUN ("string-to-number", Fstring_to_number, Sstring_to_number, 1, 2, 0,
"Convert STRING to a number by parsing it as a decimal number.\n\
This parses both integers and floating point numbers.\n\
-It ignores leading spaces and tabs.")
- (string)
- register Lisp_Object string;
-{
- Lisp_Object value;
- unsigned char *p;
+It ignores leading spaces and tabs.\n\
+\n\
+If BASE, interpret STRING as a number in that base. If BASE isn't\n\
+present, base 10 is used. BASE must be between 2 and 16 (inclusive).\n\
+If the base used is not 10, floating point is not recognized.")
+ (string, base)
+ register Lisp_Object string, base;
+{
+ register unsigned char *p;
+ register int b;
+ int sign = 1;
+ Lisp_Object val;
CHECK_STRING (string, 0);
- p = XSTRING (string)->data;
+ if (NILP (base))
+ b = 10;
+ else
+ {
+ CHECK_NUMBER (base, 1);
+ b = XINT (base);
+ if (b < 2 || b > 16)
+ Fsignal (Qargs_out_of_range, Fcons (base, Qnil));
+ }
/* Skip any whitespace at the front of the number. Some versions of
atoi do this anyway, so we might as well make Emacs lisp consistent. */
+ p = XSTRING (string)->data;
while (*p == ' ' || *p == '\t')
p++;
-#ifdef LISP_FLOAT_TYPE
- if (isfloat_string (p))
- return make_float (atof (p));
-#endif /* LISP_FLOAT_TYPE */
-
- if (sizeof (int) == sizeof (EMACS_INT))
- XSETINT (value, atoi (p));
- else if (sizeof (long) == sizeof (EMACS_INT))
- XSETINT (value, atol (p));
+ if (*p == '-')
+ {
+ sign = -1;
+ p++;
+ }
+ else if (*p == '+')
+ p++;
+
+ if (isfloat_string (p) && b == 10)
+ val = make_float (sign * atof (p));
else
- abort ();
- return value;
+ {
+ double v = 0;
+
+ while (1)
+ {
+ int digit = digit_to_number (*p++, b);
+ if (digit < 0)
+ break;
+ v = v * b + digit;
+ }
+
+ if (v > (EMACS_UINT) (VALMASK >> 1))
+ val = make_float (sign * v);
+ else
+ val = make_number (sign * (int) v);
+ }
+
+ return val;
}
+
\f
enum arithop
{ Aadd, Asub, Amult, Adiv, Alogand, Alogior, Alogxor, Amax, Amin };
extern Lisp_Object float_arith_driver ();
+extern Lisp_Object fmod_float ();
Lisp_Object
arith_driver (code, nargs, args)
for (argnum = 0; argnum < nargs; argnum++)
{
val = args[argnum]; /* using args[argnum] as argument to CHECK_NUMBER_... */
-#ifdef LISP_FLOAT_TYPE
CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val, argnum);
if (FLOATP (val)) /* time to do serious math */
return (float_arith_driver ((double) accum, argnum, code,
nargs, args));
-#else
- CHECK_NUMBER_COERCE_MARKER (val, argnum);
-#endif /* LISP_FLOAT_TYPE */
args[argnum] = val; /* runs into a compiler bug. */
next = XINT (args[argnum]);
switch (SWITCH_ENUM_CAST (code))
{
case Aadd: accum += next; break;
case Asub:
- if (!argnum && nargs != 1)
- next = - next;
- accum -= next;
+ accum = argnum ? accum - next : nargs == 1 ? - next : next;
break;
case Amult: accum *= next; break;
case Adiv:
return val;
}
-#ifdef LISP_FLOAT_TYPE
-
#undef isnan
#define isnan(x) ((x) != (x))
if (FLOATP (val))
{
- next = XFLOAT (val)->data;
+ next = XFLOAT_DATA (val);
}
else
{
accum += next;
break;
case Asub:
- if (!argnum && nargs != 1)
- next = - next;
- accum -= next;
+ accum = argnum ? accum - next : nargs == 1 ? - next : next;
break;
case Amult:
accum *= next;
accum = next;
else
{
- if (next == 0)
+ if (! IEEE_FLOATING_POINT && next == 0)
Fsignal (Qarith_error, Qnil);
accum /= next;
}
return make_float (accum);
}
-#endif /* LISP_FLOAT_TYPE */
+
DEFUN ("+", Fplus, Splus, 0, MANY, 0,
"Return sum of any number of arguments, which are numbers or markers.")
fmod (f1, f2)
double f1, f2;
{
+ double r = f1;
+
if (f2 < 0.0)
f2 = -f2;
- return (f1 - f2 * floor (f1/f2));
+
+ /* If the magnitude of the result exceeds that of the divisor, or
+ the sign of the result does not agree with that of the dividend,
+ iterate with the reduced value. This does not yield a
+ particularly accurate result, but at least it will be in the
+ range promised by fmod. */
+ do
+ r -= f2 * floor (r / f2);
+ while (f2 <= (r < 0 ? -r : r) || ((r < 0) != (f1 < 0) && ! isnan (r)));
+
+ return r;
}
#endif /* ! HAVE_FMOD */
Lisp_Object val;
EMACS_INT i1, i2;
-#ifdef LISP_FLOAT_TYPE
CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x, 0);
CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y, 1);
if (FLOATP (x) || FLOATP (y))
- {
- double f1, f2;
-
- f1 = FLOATP (x) ? XFLOAT (x)->data : XINT (x);
- f2 = FLOATP (y) ? XFLOAT (y)->data : XINT (y);
- if (f2 == 0)
- Fsignal (Qarith_error, Qnil);
-
- f1 = fmod (f1, f2);
- /* If the "remainder" comes out with the wrong sign, fix it. */
- if (f2 < 0 ? f1 > 0 : f1 < 0)
- f1 += f2;
- return (make_float (f1));
- }
-#else /* not LISP_FLOAT_TYPE */
- CHECK_NUMBER_COERCE_MARKER (x, 0);
- CHECK_NUMBER_COERCE_MARKER (y, 1);
-#endif /* not LISP_FLOAT_TYPE */
+ return fmod_float (x, y);
i1 = XINT (x);
i2 = XINT (y);
CHECK_NUMBER (value, 0);
CHECK_NUMBER (count, 1);
- if (XINT (count) > 0)
+ if (XINT (count) >= BITS_PER_EMACS_INT)
+ XSETINT (val, 0);
+ else if (XINT (count) > 0)
XSETINT (val, XINT (value) << XFASTINT (count));
+ else if (XINT (count) <= -BITS_PER_EMACS_INT)
+ XSETINT (val, XINT (value) < 0 ? -1 : 0);
else
XSETINT (val, XINT (value) >> -XINT (count));
return val;
CHECK_NUMBER (value, 0);
CHECK_NUMBER (count, 1);
- if (XINT (count) > 0)
+ if (XINT (count) >= BITS_PER_EMACS_INT)
+ XSETINT (val, 0);
+ else if (XINT (count) > 0)
XSETINT (val, (EMACS_UINT) XUINT (value) << XFASTINT (count));
+ else if (XINT (count) <= -BITS_PER_EMACS_INT)
+ XSETINT (val, 0);
else
XSETINT (val, (EMACS_UINT) XUINT (value) >> -XINT (count));
return val;
(number)
register Lisp_Object number;
{
-#ifdef LISP_FLOAT_TYPE
CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number, 0);
if (FLOATP (number))
- return (make_float (1.0 + XFLOAT (number)->data));
-#else
- CHECK_NUMBER_COERCE_MARKER (number, 0);
-#endif /* LISP_FLOAT_TYPE */
+ return (make_float (1.0 + XFLOAT_DATA (number)));
XSETINT (number, XINT (number) + 1);
return number;
(number)
register Lisp_Object number;
{
-#ifdef LISP_FLOAT_TYPE
CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number, 0);
if (FLOATP (number))
- return (make_float (-1.0 + XFLOAT (number)->data));
-#else
- CHECK_NUMBER_COERCE_MARKER (number, 0);
-#endif /* LISP_FLOAT_TYPE */
+ return (make_float (-1.0 + XFLOAT_DATA (number)));
XSETINT (number, XINT (number) - 1);
return number;
Qbeginning_of_buffer = intern ("beginning-of-buffer");
Qend_of_buffer = intern ("end-of-buffer");
Qbuffer_read_only = intern ("buffer-read-only");
+ Qtext_read_only = intern ("text-read-only");
Qmark_inactive = intern ("mark-inactive");
Qlistp = intern ("listp");
Qconsp = intern ("consp");
Qsymbolp = intern ("symbolp");
+ Qkeywordp = intern ("keywordp");
Qintegerp = intern ("integerp");
Qnatnump = intern ("natnump");
Qwholenump = intern ("wholenump");
Qboundp = intern ("boundp");
Qfboundp = intern ("fboundp");
-#ifdef LISP_FLOAT_TYPE
Qfloatp = intern ("floatp");
Qnumberp = intern ("numberp");
Qnumber_or_marker_p = intern ("number-or-marker-p");
-#endif /* LISP_FLOAT_TYPE */
Qchar_table_p = intern ("char-table-p");
Qvector_or_char_table_p = intern ("vector-or-char-table-p");
+ Qsubrp = intern ("subrp");
+ Qunevalled = intern ("unevalled");
+ Qmany = intern ("many");
+
Qcdr = intern ("cdr");
/* Handle automatic advice activation */
Qad_advice_info = intern ("ad-advice-info");
- Qad_activate = intern ("ad-activate");
+ Qad_activate_internal = intern ("ad-activate-internal");
error_tail = Fcons (Qerror, Qnil);
Fput (Qbuffer_read_only, Qerror_message,
build_string ("Buffer is read-only"));
-#ifdef LISP_FLOAT_TYPE
+ Fput (Qtext_read_only, Qerror_conditions,
+ Fcons (Qtext_read_only, error_tail));
+ Fput (Qtext_read_only, Qerror_message,
+ build_string ("Text is read-only"));
+
Qrange_error = intern ("range-error");
Qdomain_error = intern ("domain-error");
Qsingularity_error = intern ("singularity-error");
staticpro (&Qsingularity_error);
staticpro (&Qoverflow_error);
staticpro (&Qunderflow_error);
-#endif /* LISP_FLOAT_TYPE */
staticpro (&Qnil);
staticpro (&Qt);
staticpro (&Qbeginning_of_buffer);
staticpro (&Qend_of_buffer);
staticpro (&Qbuffer_read_only);
+ staticpro (&Qtext_read_only);
staticpro (&Qmark_inactive);
staticpro (&Qlistp);
staticpro (&Qconsp);
staticpro (&Qsymbolp);
+ staticpro (&Qkeywordp);
staticpro (&Qintegerp);
staticpro (&Qnatnump);
staticpro (&Qwholenump);
staticpro (&Qmarkerp);
staticpro (&Qbuffer_or_string_p);
staticpro (&Qinteger_or_marker_p);
-#ifdef LISP_FLOAT_TYPE
staticpro (&Qfloatp);
staticpro (&Qnumberp);
staticpro (&Qnumber_or_marker_p);
-#endif /* LISP_FLOAT_TYPE */
staticpro (&Qchar_table_p);
staticpro (&Qvector_or_char_table_p);
+ staticpro (&Qsubrp);
+ staticpro (&Qmany);
+ staticpro (&Qunevalled);
staticpro (&Qboundp);
staticpro (&Qfboundp);
staticpro (&Qcdr);
staticpro (&Qad_advice_info);
- staticpro (&Qad_activate);
+ staticpro (&Qad_activate_internal);
/* Types that type-of returns. */
Qinteger = intern ("integer");
Qvector = intern ("vector");
Qchar_table = intern ("char-table");
Qbool_vector = intern ("bool-vector");
+ Qhash_table = intern ("hash-table");
staticpro (&Qinteger);
staticpro (&Qsymbol);
staticpro (&Qvector);
staticpro (&Qchar_table);
staticpro (&Qbool_vector);
+ staticpro (&Qhash_table);
defsubr (&Seq);
defsubr (&Snull);
defsubr (&Sinteger_or_marker_p);
defsubr (&Snumberp);
defsubr (&Snumber_or_marker_p);
-#ifdef LISP_FLOAT_TYPE
defsubr (&Sfloatp);
-#endif /* LISP_FLOAT_TYPE */
defsubr (&Snatnump);
defsubr (&Ssymbolp);
+ defsubr (&Skeywordp);
defsubr (&Sstringp);
+ defsubr (&Smultibyte_string_p);
defsubr (&Svectorp);
defsubr (&Schar_table_p);
defsubr (&Svector_or_char_table_p);
defsubr (&Sfboundp);
defsubr (&Sfset);
defsubr (&Sdefalias);
- defsubr (&Sdefine_function);
defsubr (&Ssetplist);
defsubr (&Ssymbol_value);
defsubr (&Sset);
defsubr (&Smake_variable_buffer_local);
defsubr (&Smake_local_variable);
defsubr (&Skill_local_variable);
+ defsubr (&Smake_variable_frame_local);
defsubr (&Slocal_variable_p);
defsubr (&Slocal_variable_if_set_p);
defsubr (&Saref);
defsubr (&Sadd1);
defsubr (&Ssub1);
defsubr (&Slognot);
+ defsubr (&Ssubr_arity);
XSYMBOL (Qwholenump)->function = XSYMBOL (Qnatnump)->function;
}
Fsignal (Qarith_error, Qnil);
}
+void
init_data ()
{
/* Don't do this if just dumping out.
HCoop / bpt / emacs.git / blobdiff