/* 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, 1998 Free Software Foundation, Inc.
This file is part of GNU Emacs.
#include <config.h>
#include "lisp.h"
#include "puresize.h"
+#include "charset.h"
#ifndef standalone
#include "buffer.h"
#include "keyboard.h"
+#include "frame.h"
#endif
#include "syssignal.h"
#ifdef LISP_FLOAT_TYPE
#ifdef STDC_HEADERS
-#include <float.h>
#include <stdlib.h>
+#include <float.h>
#endif
/* If IEEE_FLOATING_POINT isn't defined, default it from FLT_*. */
extern double atof ();
#endif /* !atof */
+/* Nonzero means it is an error to set a symbol whose name starts with
+ colon. */
+int keyword_symbols_constant_flag;
+
Lisp_Object Qnil, Qt, Qquote, Qlambda, Qsubr, Qunbound;
Lisp_Object Qerror_conditions, Qerror_message, Qtop_level;
Lisp_Object Qerror, Qquit, Qwrong_type_argument, Qargs_out_of_range;
#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 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;
{
}
}
-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.")
+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;
{
#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;
{
\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)
+ && keyword_symbols_constant_flag))
return Fsignal (Qsetting_constant, Fcons (symbol, Qnil));
Fset (symbol, Qunbound);
return symbol;
Lisp_Object type;
type = *(Lisp_Object *)(offset + (char *)&buffer_local_types);
+ 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);
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;
}
Note that REALVALUE can be a forwarding pointer. */
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)
+ || selected_frame != XFRAME (XBUFFER_LOCAL_VALUE (valcontents)->frame))
{
- tem1 = XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr)->car;
+ tem1 = XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->car;
Fsetcdr (tem1,
- do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents)->car));
+ do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents)->realvalue));
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, 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;
+
+ XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->car = tem1;
+ XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents)->buffer, current_buffer);
+ XSETFRAME (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.
return set_internal (symbol, newval, 0);
}
-/* Stpre the value NEWVAL into SYMBOL.
+/* Store the value NEWVAL into SYMBOL.
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. */
register Lisp_Object valcontents, tem1, current_alist_element;
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)
+ && keyword_symbols_constant_flag && ! EQ (newval, symbol)))
return Fsignal (Qsetting_constant, Fcons (symbol, Qnil));
valcontents = XSYMBOL (symbol)->value;
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;
+ current_alist_element
+ = XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->car;
/* 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))
+ if (current_buffer != XBUFFER (XBUFFER_LOCAL_VALUE (valcontents)->buffer)
+ ||
+ selected_frame != XFRAME (XBUFFER_LOCAL_VALUE (valcontents)->frame)
|| (BUFFER_LOCAL_VALUEP (valcontents)
&& EQ (XCONS (current_alist_element)->car,
current_alist_element)))
back to its alist element. This works if the current
buffer only sees the default value, too. */
Fsetcdr (current_alist_element,
- do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents)->car));
+ do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents)->realvalue));
/* Find the new value for CURRENT-ALIST-ELEMENT. */
tem1 = Fassq (symbol, current_buffer->local_var_alist);
+ XBUFFER_LOCAL_VALUE (valcontents)->found_for_buffer = 1;
+ XBUFFER_LOCAL_VALUE (valcontents)->found_for_frame = 0;
+
if (NILP (tem1))
{
/* This buffer still sees the default value. */
make CURRENT-ALIST-ELEMENT point to itself,
indicating that we're seeing the default value. */
if (bindflag || SOME_BUFFER_LOCAL_VALUEP (valcontents))
- tem1 = XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr;
+ {
+ XBUFFER_LOCAL_VALUE (valcontents)->found_for_buffer = 0;
+
+ if (XBUFFER_LOCAL_VALUE (valcontents)->check_frame)
+ tem1 = Fassq (symbol, selected_frame->param_alist);
+ 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,
give this buffer a new assoc for a local value and set
CURRENT-ALIST-ELEMENT to point to that. */
else
{
tem1 = Fcons (symbol, Fcdr (current_alist_element));
- current_buffer->local_var_alist =
- Fcons (tem1, current_buffer->local_var_alist);
+ current_buffer->local_var_alist
+ = Fcons (tem1, current_buffer->local_var_alist);
}
}
+
/* Cache the new buffer's assoc in CURRENT-ALIST-ELEMENT. */
- XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr)->car
+ XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->car
= tem1;
- /* Set BUFFER, now that CURRENT-ALIST-ELEMENT is accurate. */
- XSETBUFFER (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->car,
+ /* Set BUFFER and FRAME for binding now loaded. */
+ XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents)->buffer,
current_buffer);
+ XSETFRAME (XBUFFER_LOCAL_VALUE (valcontents)->frame,
+ selected_frame);
}
- valcontents = XBUFFER_LOCAL_VALUE (valcontents)->car;
+ valcontents = XBUFFER_LOCAL_VALUE (valcontents)->realvalue;
}
/* If storing void (making the symbol void), forward only through
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;
+ = XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->car;
alist_element_car = XCONS (current_alist_element)->car;
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 XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->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)
register int mask = XINT (*((Lisp_Object *)
(idx + (char *)&buffer_local_flags)));
+ *(Lisp_Object *)(idx + (char *) &buffer_defaults) = 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 (mask > 0)
{
- *(Lisp_Object *)(idx + (char *) &buffer_defaults) = value;
for (b = all_buffers; b; b = b->next)
if (!(b->local_var_flags & mask))
*(Lisp_Object *)(idx + (char *) b) = value;
return Fset (symbol, value);
/* Store new value into the DEFAULT-VALUE slot */
- XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr)->cdr = value;
+ XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr = value;
/* If that slot is current, we must set the REALVALUE slot too */
current_alist_element
- = XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr)->car;
+ = XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->car;
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;
XCONS (tem)->car = 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 = 1;
+ 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;
}
XCONS (tem)->car = 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 */
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, XCONS (XBUFFER_LOCAL_VALUE (XSYMBOL (variable)->value)->cdr)->cdr),
current_buffer->local_var_alist);
/* Make sure symbol does not think it is set up for this buffer;
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;
}
}
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;
+ valcontents = XBUFFER_LOCAL_VALUE (XSYMBOL (variable)->value)->realvalue;
if (INTFWDP (valcontents) || BOOLFWDP (valcontents) || OBJFWDP (valcontents))
swap_in_symval_forwarding (variable, XSYMBOL (variable)->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;
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))
+ return variable;
+
+ if (EQ (valcontents, Qunbound))
+ XSYMBOL (variable)->value = Qnil;
+ tem = Fcons (Qnil, Fsymbol_value (variable));
+ XCONS (tem)->car = 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\
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];
+ if (idxval < CHAR_TABLE_ORDINARY_SLOTS)
+ {
+ /* 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;
+ if (NILP (array))
+ return Qnil;
+ val = XCHAR_TABLE (array)->contents[idxval];
+ if (NILP (val))
+ val = XCHAR_TABLE (array)->defalt;
+ }
+ return val;
+ }
else
{
- int charset;
- unsigned char c1, c2;
- Lisp_Object val, temp;
+ int code[4], i;
+ Lisp_Object sub_table;
- BREAKUP_NON_ASCII_CHAR (idxval, charset, c1, c2);
+ SPLIT_NON_ASCII_CHAR (idxval, code[0], code[1], code[2]);
+ if (code[0] != CHARSET_COMPOSITION)
+ {
+ if (code[1] < 32) code[1] = -1;
+ else if (code[2] < 32) code[2] = -1;
+ }
+ /* 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 */
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))
+ sub_table = array;
+ for (i = 0; code[i] >= 0; i++)
{
- array = XCHAR_TABLE (array)->parent;
- goto try_parent_char_table;
-
+ 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;
+ }
}
-
- if (c2 == 0 || !CHAR_TABLE_P (val))
- return val;
-
- temp = XCHAR_TABLE (val)->contents[c2];
- if (NILP (temp))
- val = XCHAR_TABLE (val)->defalt;
- else
- val = temp;
-
- if (NILP (val) && !NILP (XCHAR_TABLE (array)->parent))
+ /* 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
{
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;
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_NON_ASCII_CHAR (idxval, code[0], code[1], code[2]);
+ if (code[0] != CHARSET_COMPOSITION)
+ {
+ if (code[1] < 32) code[1] = -1;
+ else if (code[2] < 32) code[2] = -1;
+ }
+ /* 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;
- if (c1 == 0)
- return XCHAR_TABLE (array)->contents[charset] = newelt;
+ /* VAL is a leaf. Create a sub char table with the
+ default value VAL or XCHAR_TABLE (array)->defalt
+ and look into it. */
- val = XCHAR_TABLE (array)->contents[charset];
- if (!CHAR_TABLE_P (val))
- XCHAR_TABLE (array)->contents[charset]
- = val = Fmake_char_table (Qnil);
+ 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))
+ {
+ Lisp_Object new_len;
+ int c, idxval_byte, actual_len;
+ unsigned char *p, *str;
- if (c2 == 0)
- return XCHAR_TABLE (val)->contents[c1] = newelt;
+ if (idxval < 0 || idxval >= XSTRING (array)->size)
+ args_out_of_range (array, idx);
- val2 = XCHAR_TABLE (val)->contents[c2];
- if (!CHAR_TABLE_P (val2))
- XCHAR_TABLE (val)->contents[charset]
- = val2 = Fmake_char_table (Qnil);
+ idxval_byte = string_char_to_byte (array, idxval);
+ p = &XSTRING (array)->data[idxval_byte];
- return XCHAR_TABLE (val2)->contents[c2] = newelt;
- }
-#endif /* 0 */
+ actual_len
+ = MULTIBYTE_FORM_LENGTH (p, STRING_BYTES (XSTRING (array)) - idxval_byte);
+ new_len = Fchar_bytes (newelt);
+ if (actual_len != XINT (new_len))
+ error ("Attempt to change byte length of a string");
+
+ CHAR_STRING (XINT (newelt), p, str);
+ if (p != str)
+ bcopy (str, p, actual_len);
}
else
{
}
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;
{
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;
+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\
+Floating point numbers always use base 10.")
+ (string, base)
+ register Lisp_Object string, base;
{
- Lisp_Object value;
- unsigned char *p;
+ register unsigned char *p;
+ register int b, digit, v = 0;
+ int negative = 1;
CHECK_STRING (string, 0);
+ 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));
+ }
+
p = XSTRING (string)->data;
/* Skip any whitespace at the front of the number. Some versions of
while (*p == ' ' || *p == '\t')
p++;
+ if (*p == '-')
+ {
+ negative = -1;
+ p++;
+ }
+ else if (*p == '+')
+ p++;
+
#ifdef LISP_FLOAT_TYPE
if (isfloat_string (p))
- return make_float (atof (p));
+ return make_float (negative * 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));
- else
- abort ();
- return value;
+ while (1)
+ {
+ int digit = digit_to_number (*p++, b);
+ if (digit < 0)
+ break;
+ v = v * b + digit;
+ }
+
+ return make_number (negative * v);
}
+
\f
enum arithop
{ Aadd, Asub, Amult, Adiv, Alogand, Alogior, Alogxor, Amax, Amin };
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;
staticpro (&Qchar_table);
staticpro (&Qbool_vector);
+ DEFVAR_BOOL ("keyword-symbols-constant-flag", &keyword_symbols_constant_flag,
+ "Non-nil means it is an error to set a keyword symbol.\n\
+A keyword symbol is a symbol whose name starts with a colon (`:').");
+ keyword_symbols_constant_flag = 1;
+
defsubr (&Seq);
defsubr (&Snull);
defsubr (&Stype_of);
defsubr (&Snatnump);
defsubr (&Ssymbolp);
defsubr (&Sstringp);
+ defsubr (&Smultibyte_string_p);
defsubr (&Svectorp);
defsubr (&Schar_table_p);
defsubr (&Svector_or_char_table_p);
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);
Fsignal (Qarith_error, Qnil);
}
+void
init_data ()
{
/* Don't do this if just dumping out.