/* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
- Copyright (C) 1985, 1986, 1988, 1993, 1994 Free Software Foundation, Inc.
+ Copyright (C) 1985, 86, 88, 93, 94, 95 Free Software Foundation, Inc.
This file is part of GNU Emacs.
#ifndef standalone
#include "buffer.h"
+#include "keyboard.h"
#endif
#include "syssignal.h"
Lisp_Object Qchar_or_string_p, Qmarkerp, Qinteger_or_marker_p, Qvectorp;
Lisp_Object Qbuffer_or_string_p;
Lisp_Object Qboundp, Qfboundp;
+
Lisp_Object Qcdr;
Lisp_Object Qad_advice_info, Qad_activate;
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 Qcompiled_function, Qbuffer, Qframe, Qvector;
+
static Lisp_Object swap_in_symval_forwarding ();
Lisp_Object
if (INTEGERP (value) && EQ (predicate, Qstringp))
return Fnumber_to_string (value);
}
+
+ /* If VALUE is not even a valid Lisp object, abort here
+ where we can get a backtrace showing where it came from. */
+ if ((unsigned int) XGCTYPE (value) >= Lisp_Type_Limit)
+ abort ();
+
value = Fsignal (Qwrong_type_argument, Fcons (predicate, Fcons (value, Qnil)));
tem = call1 (predicate, value);
}
}
DEFUN ("null", Fnull, Snull, 1, 1, 0, "T if OBJECT is nil.")
- (obj)
- Lisp_Object obj;
+ (object)
+ Lisp_Object object;
{
- if (NILP (obj))
+ if (NILP (object))
return Qt;
return Qnil;
}
+DEFUN ("type-of", Ftype_of, Stype_of, 1, 1, 0,
+ "Return a symbol representing the type of OBJECT.\n\
+The symbol returned names the object's basic type;\n\
+for example, (type-of 1) returns `integer'.")
+ (object)
+ Lisp_Object object;
+{
+ switch (XGCTYPE (object))
+ {
+ case Lisp_Int:
+ return Qinteger;
+
+ case Lisp_Symbol:
+ return Qsymbol;
+
+ case Lisp_String:
+ return Qstring;
+
+ case Lisp_Cons:
+ return Qcons;
+
+ case Lisp_Misc:
+ switch (XMISCTYPE (object))
+ {
+ case Lisp_Misc_Marker:
+ return Qmarker;
+ case Lisp_Misc_Overlay:
+ return Qoverlay;
+ case Lisp_Misc_Float:
+ return Qfloat;
+ }
+ abort ();
+
+ case Lisp_Vectorlike:
+ if (GC_WINDOW_CONFIGURATIONP (object))
+ return Qwindow_configuration;
+ if (GC_PROCESSP (object))
+ return Qprocess;
+ if (GC_WINDOWP (object))
+ return Qwindow;
+ if (GC_SUBRP (object))
+ return Qsubr;
+ if (GC_COMPILEDP (object))
+ return Qcompiled_function;
+ if (GC_BUFFERP (object))
+ return Qbuffer;
+
+#ifdef MULTI_FRAME
+ if (GC_FRAMEP (object))
+ return Qframe;
+#endif
+ 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.")
- (obj)
- Lisp_Object obj;
+ (object)
+ Lisp_Object object;
{
- if (CONSP (obj))
+ if (CONSP (object))
return Qt;
return Qnil;
}
DEFUN ("atom", Fatom, Satom, 1, 1, 0, "T if OBJECT is not a cons cell. This includes nil.")
- (obj)
- Lisp_Object obj;
+ (object)
+ Lisp_Object object;
{
- if (CONSP (obj))
+ if (CONSP (object))
return Qnil;
return Qt;
}
DEFUN ("listp", Flistp, Slistp, 1, 1, 0, "T if OBJECT is a list. This includes nil.")
- (obj)
- Lisp_Object obj;
+ (object)
+ Lisp_Object object;
{
- if (CONSP (obj) || NILP (obj))
+ if (CONSP (object) || NILP (object))
return Qt;
return Qnil;
}
DEFUN ("nlistp", Fnlistp, Snlistp, 1, 1, 0, "T if OBJECT is not a list. Lists include nil.")
- (obj)
- Lisp_Object obj;
+ (object)
+ Lisp_Object object;
{
- if (CONSP (obj) || NILP (obj))
+ if (CONSP (object) || NILP (object))
return Qnil;
return Qt;
}
\f
DEFUN ("symbolp", Fsymbolp, Ssymbolp, 1, 1, 0, "T if OBJECT is a symbol.")
- (obj)
- Lisp_Object obj;
+ (object)
+ Lisp_Object object;
{
- if (SYMBOLP (obj))
+ if (SYMBOLP (object))
return Qt;
return Qnil;
}
DEFUN ("vectorp", Fvectorp, Svectorp, 1, 1, 0, "T if OBJECT is a vector.")
- (obj)
- Lisp_Object obj;
+ (object)
+ Lisp_Object object;
{
- if (VECTORP (obj))
+ if (VECTORP (object))
return Qt;
return Qnil;
}
DEFUN ("stringp", Fstringp, Sstringp, 1, 1, 0, "T if OBJECT is a string.")
- (obj)
- Lisp_Object obj;
+ (object)
+ Lisp_Object object;
{
- if (STRINGP (obj))
+ if (STRINGP (object))
return Qt;
return Qnil;
}
DEFUN ("arrayp", Farrayp, Sarrayp, 1, 1, 0, "T if OBJECT is an array (string or vector).")
- (obj)
- Lisp_Object obj;
+ (object)
+ Lisp_Object object;
{
- if (VECTORP (obj) || STRINGP (obj))
+ if (VECTORP (object) || STRINGP (object))
return Qt;
return Qnil;
}
DEFUN ("sequencep", Fsequencep, Ssequencep, 1, 1, 0,
"T if OBJECT is a sequence (list or array).")
- (obj)
- register Lisp_Object obj;
+ (object)
+ register Lisp_Object object;
{
- if (CONSP (obj) || NILP (obj) || VECTORP (obj) || STRINGP (obj))
+ if (CONSP (object) || NILP (object) || VECTORP (object) || STRINGP (object))
return Qt;
return Qnil;
}
DEFUN ("bufferp", Fbufferp, Sbufferp, 1, 1, 0, "T if OBJECT is an editor buffer.")
- (obj)
- Lisp_Object obj;
+ (object)
+ Lisp_Object object;
{
- if (BUFFERP (obj))
+ if (BUFFERP (object))
return Qt;
return Qnil;
}
DEFUN ("markerp", Fmarkerp, Smarkerp, 1, 1, 0, "T if OBJECT is a marker (editor pointer).")
- (obj)
- Lisp_Object obj;
+ (object)
+ Lisp_Object object;
{
- if (MARKERP (obj))
+ if (MARKERP (object))
return Qt;
return Qnil;
}
DEFUN ("subrp", Fsubrp, Ssubrp, 1, 1, 0, "T if OBJECT is a built-in function.")
- (obj)
- Lisp_Object obj;
+ (object)
+ Lisp_Object object;
{
- if (SUBRP (obj))
+ if (SUBRP (object))
return Qt;
return Qnil;
}
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.")
- (obj)
- Lisp_Object obj;
+ (object)
+ Lisp_Object object;
{
- if (COMPILEDP (obj))
+ if (COMPILEDP (object))
return Qt;
return Qnil;
}
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.")
- (obj)
- register Lisp_Object obj;
+ (object)
+ register Lisp_Object object;
{
- if (INTEGERP (obj) || STRINGP (obj))
+ if (INTEGERP (object) || STRINGP (object))
return Qt;
return Qnil;
}
\f
DEFUN ("integerp", Fintegerp, Sintegerp, 1, 1, 0, "T if OBJECT is an integer.")
- (obj)
- Lisp_Object obj;
+ (object)
+ Lisp_Object object;
{
- if (INTEGERP (obj))
+ if (INTEGERP (object))
return Qt;
return Qnil;
}
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).")
- (obj)
- register Lisp_Object obj;
+ (object)
+ register Lisp_Object object;
{
- if (MARKERP (obj) || INTEGERP (obj))
+ if (MARKERP (object) || INTEGERP (object))
return Qt;
return Qnil;
}
DEFUN ("natnump", Fnatnump, Snatnump, 1, 1, 0,
"T if OBJECT is a nonnegative integer.")
- (obj)
- Lisp_Object obj;
+ (object)
+ Lisp_Object object;
{
- if (INTEGERP (obj) && XINT (obj) >= 0)
+ if (NATNUMP (object))
return Qt;
return Qnil;
}
DEFUN ("numberp", Fnumberp, Snumberp, 1, 1, 0,
"T if OBJECT is a number (floating point or integer).")
- (obj)
- Lisp_Object obj;
+ (object)
+ Lisp_Object object;
{
- if (NUMBERP (obj))
+ if (NUMBERP (object))
return Qt;
else
return Qnil;
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.")
- (obj)
- Lisp_Object obj;
+ (object)
+ Lisp_Object object;
{
- if (NUMBERP (obj) || MARKERP (obj))
+ if (NUMBERP (object) || MARKERP (object))
return Qt;
return Qnil;
}
#ifdef LISP_FLOAT_TYPE
DEFUN ("floatp", Ffloatp, Sfloatp, 1, 1, 0,
"T if OBJECT is a floating point number.")
- (obj)
- Lisp_Object obj;
+ (object)
+ Lisp_Object object;
{
- if (FLOATP (obj))
+ if (FLOATP (object))
return Qt;
return Qnil;
}
/* Extract and set components of lists */
DEFUN ("car", Fcar, Scar, 1, 1, 0,
- "Return the car of CONSCELL. If arg is nil, return nil.\n\
+ "Return the car of LIST. If arg is nil, return nil.\n\
Error if arg is not nil and not a cons cell. See also `car-safe'.")
(list)
register Lisp_Object list;
}
DEFUN ("cdr", Fcdr, Scdr, 1, 1, 0,
- "Return the cdr of CONSCELL. If arg is nil, return nil.\n\
+ "Return the cdr of LIST. If arg is nil, return nil.\n\
Error if arg is not nil and not a cons cell. See also `cdr-safe'.")
(list)
}
DEFUN ("setcar", Fsetcar, Ssetcar, 2, 2, 0,
- "Set the car of CONSCELL to be NEWCAR. Returns NEWCAR.")
+ "Set the car of CELL to be NEWCAR. Returns NEWCAR.")
(cell, newcar)
register Lisp_Object cell, newcar;
{
}
DEFUN ("setcdr", Fsetcdr, Ssetcdr, 2, 2, 0,
- "Set the cdr of CONSCELL to be NEWCDR. Returns NEWCDR.")
+ "Set the cdr of CELL to be NEWCDR. Returns NEWCDR.")
(cell, newcdr)
register Lisp_Object cell, newcdr;
{
valcontents = XSYMBOL (sym)->value;
-#ifdef SWITCH_ENUM_BUG
- switch ((int) XTYPE (valcontents))
-#else
- switch (XTYPE (valcontents))
-#endif
- {
- case Lisp_Buffer_Local_Value:
- case Lisp_Some_Buffer_Local_Value:
- valcontents = swap_in_symval_forwarding (sym, valcontents);
- }
+ if (BUFFER_LOCAL_VALUEP (valcontents)
+ || SOME_BUFFER_LOCAL_VALUEP (valcontents))
+ valcontents = swap_in_symval_forwarding (sym, valcontents);
return (EQ (valcontents, Qunbound) ? Qnil : Qt);
}
register Lisp_Object val;
int offset;
if (MISCP (valcontents))
- switch (XMISC (valcontents)->type)
+ switch (XMISCTYPE (valcontents))
{
case Lisp_Misc_Intfwd:
XSETINT (val, *XINTFWD (valcontents)->intvar);
case Lisp_Misc_Buffer_Objfwd:
offset = XBUFFER_OBJFWD (valcontents)->offset;
return *(Lisp_Object *)(offset + (char *)current_buffer);
+
+ case Lisp_Misc_Kboard_Objfwd:
+ offset = XKBOARD_OBJFWD (valcontents)->offset;
+ return *(Lisp_Object *)(offset + (char *)current_kboard);
}
return valcontents;
}
Lisp_Object sym;
register Lisp_Object valcontents, newval;
{
-#ifdef SWITCH_ENUM_BUG
- switch ((int) XTYPE (valcontents))
-#else
- switch (XTYPE (valcontents))
-#endif
+ switch (SWITCH_ENUM_CAST (XTYPE (valcontents)))
{
case Lisp_Misc:
- switch (XMISC (valcontents)->type)
+ switch (XMISCTYPE (valcontents))
{
case Lisp_Misc_Intfwd:
CHECK_NUMBER (newval, 1);
*XINTFWD (valcontents)->intvar = XINT (newval);
+ if (*XINTFWD (valcontents)->intvar != XINT (newval))
+ error ("Value out of range for variable `%s'",
+ XSYMBOL (sym)->name->data);
break;
case Lisp_Misc_Boolfwd:
buffer_slot_type_mismatch (offset);
*(Lisp_Object *)(offset + (char *)current_buffer) = newval;
- break;
}
+ break;
+
+ case Lisp_Misc_Kboard_Objfwd:
+ (*(Lisp_Object *)((char *)current_kboard
+ + XKBOARD_OBJFWD (valcontents)->offset))
+ = newval;
+ break;
+
default:
goto def;
}
valcontents = XSYMBOL (sym)->value;
if (BUFFER_LOCAL_VALUEP (valcontents)
|| SOME_BUFFER_LOCAL_VALUEP (valcontents))
- XCONS (XSYMBOL (sym)->value)->car = newval;
+ XBUFFER_LOCAL_VALUE (valcontents)->car = newval;
else
XSYMBOL (sym)->value = newval;
}
swap_in_symval_forwarding (sym, valcontents)
Lisp_Object sym, valcontents;
{
- /* valcontents is a list
+ /* valcontents is a pointer to a struct resembling the cons
(REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE)).
-
+
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
Note that REALVALUE can be a forwarding pointer. */
register Lisp_Object tem1;
- tem1 = XCONS (XCONS (valcontents)->cdr)->car;
+ tem1 = XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->car;
if (NILP (tem1) || current_buffer != XBUFFER (tem1))
{
- tem1 = XCONS (XCONS (XCONS (valcontents)->cdr)->cdr)->car;
- Fsetcdr (tem1, do_symval_forwarding (XCONS (valcontents)->car));
+ tem1 = XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr)->car;
+ Fsetcdr (tem1,
+ do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents)->car));
tem1 = assq_no_quit (sym, current_buffer->local_var_alist);
if (NILP (tem1))
- tem1 = XCONS (XCONS (valcontents)->cdr)->cdr;
- XCONS (XCONS (XCONS (valcontents)->cdr)->cdr)->car = tem1;
- XSETBUFFER (XCONS (XCONS (valcontents)->cdr)->car, current_buffer);
- store_symval_forwarding (sym, XCONS (valcontents)->car, Fcdr (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 (sym, XBUFFER_LOCAL_VALUE (valcontents)->car,
+ Fcdr (tem1));
}
- return XCONS (valcontents)->car;
+ return XBUFFER_LOCAL_VALUE (valcontents)->car;
}
\f
/* Find the value of a symbol, returning Qunbound if it's not bound.
CHECK_SYMBOL (sym, 0);
valcontents = XSYMBOL (sym)->value;
- retry:
-#ifdef SWITCH_ENUM_BUG
- switch ((int) XTYPE (valcontents))
-#else
- switch (XTYPE (valcontents))
-#endif
- {
- case Lisp_Buffer_Local_Value:
- case Lisp_Some_Buffer_Local_Value:
- valcontents = swap_in_symval_forwarding (sym, valcontents);
- goto retry;
+ if (BUFFER_LOCAL_VALUEP (valcontents)
+ || SOME_BUFFER_LOCAL_VALUEP (valcontents))
+ valcontents = swap_in_symval_forwarding (sym, valcontents);
- case Lisp_Misc:
- switch (XMISC (valcontents)->type)
+ if (MISCP (valcontents))
+ {
+ switch (XMISCTYPE (valcontents))
{
case Lisp_Misc_Intfwd:
XSETINT (val, *XINTFWD (valcontents)->intvar);
case Lisp_Misc_Buffer_Objfwd:
return *(Lisp_Object *)(XBUFFER_OBJFWD (valcontents)->offset
+ (char *)current_buffer);
+
+ case Lisp_Misc_Kboard_Objfwd:
+ return *(Lisp_Object *)(XKBOARD_OBJFWD (valcontents)->offset
+ + (char *)current_kboard);
}
}
else if (BUFFER_LOCAL_VALUEP (valcontents)
|| SOME_BUFFER_LOCAL_VALUEP (valcontents))
{
- /* valcontents is actually a pointer to a cons heading something like:
+ /* 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
/* What value are we caching right now? */
current_alist_element =
- XCONS (XCONS (XCONS (valcontents)->cdr)->cdr)->car;
+ XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->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 (XCONS (valcontents)->cdr)->car))
+ != XBUFFER (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->car))
|| (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 (XCONS (valcontents)->car));
+ do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents)->car));
/* Find the new value for CURRENT-ALIST-ELEMENT. */
tem1 = Fassq (sym, current_buffer->local_var_alist);
make CURRENT-ALIST-ELEMENT point to itself,
indicating that we're seeing the default value. */
if (SOME_BUFFER_LOCAL_VALUEP (valcontents))
- tem1 = XCONS (XCONS (valcontents)->cdr)->cdr;
+ tem1 = XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr;
/* If it's a Lisp_Buffer_Local_Value, give this buffer a
new assoc for a local value and set
}
}
/* Cache the new buffer's assoc in CURRENT-ALIST-ELEMENT. */
- XCONS (XCONS (XCONS (valcontents)->cdr)->cdr)->car = tem1;
+ XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr)->car
+ = tem1;
/* Set BUFFER, now that CURRENT-ALIST-ELEMENT is accurate. */
- XSETBUFFER (XCONS (XCONS (valcontents)->cdr)->car, current_buffer);
+ XSETBUFFER (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->car,
+ current_buffer);
}
- valcontents = XCONS (valcontents)->car;
+ valcontents = XBUFFER_LOCAL_VALUE (valcontents)->car;
}
/* 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 (XCONS (valcontents)->cdr)->cdr)->car;
+ = XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr)->car;
alist_element_car = XCONS (current_alist_element)->car;
if (EQ (alist_element_car, current_alist_element))
- return do_symval_forwarding (XCONS (valcontents)->car);
+ return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents)->car);
else
- return XCONS (XCONS (XCONS (valcontents)->cdr)->cdr)->cdr;
+ return XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr)->cdr;
}
/* For other variables, get the current value. */
return do_symval_forwarding (valcontents);
return Fset (sym, value);
/* Store new value into the DEFAULT-VALUE slot */
- XCONS (XCONS (XCONS (valcontents)->cdr)->cdr)->cdr = value;
+ XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr)->cdr = value;
/* If that slot is current, we must set the REALVALUE slot too */
- current_alist_element = XCONS (XCONS (XCONS (valcontents)->cdr)->cdr)->car;
+ current_alist_element
+ = XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr)->car;
alist_element_buffer = Fcar (current_alist_element);
if (EQ (alist_element_buffer, current_alist_element))
- store_symval_forwarding (sym, XCONS (valcontents)->car, value);
+ store_symval_forwarding (sym, XBUFFER_LOCAL_VALUE (valcontents)->car,
+ value);
return value;
}
(sym)
register Lisp_Object sym;
{
- register Lisp_Object tem, valcontents;
+ register Lisp_Object tem, valcontents, newval;
CHECK_SYMBOL (sym, 0);
- if (EQ (sym, Qnil) || EQ (sym, Qt))
+ valcontents = XSYMBOL (sym)->value;
+ if (EQ (sym, Qnil) || EQ (sym, Qt) || KBOARD_OBJFWDP (valcontents))
error ("Symbol %s may not be buffer-local", XSYMBOL (sym)->name->data);
- valcontents = XSYMBOL (sym)->value;
if (BUFFER_LOCAL_VALUEP (valcontents) || BUFFER_OBJFWDP (valcontents))
return sym;
if (SOME_BUFFER_LOCAL_VALUEP (valcontents))
{
- XSETTYPE (XSYMBOL (sym)->value, Lisp_Buffer_Local_Value);
+ XMISCTYPE (XSYMBOL (sym)->value) = Lisp_Misc_Buffer_Local_Value;
return sym;
}
if (EQ (valcontents, Qunbound))
XSYMBOL (sym)->value = Qnil;
tem = Fcons (Qnil, Fsymbol_value (sym));
XCONS (tem)->car = tem;
- XSYMBOL (sym)->value = Fcons (XSYMBOL (sym)->value, Fcons (Fcurrent_buffer (), tem));
- XSETTYPE (XSYMBOL (sym)->value, Lisp_Buffer_Local_Value);
+ newval = allocate_misc ();
+ XMISCTYPE (newval) = Lisp_Misc_Buffer_Local_Value;
+ XBUFFER_LOCAL_VALUE (newval)->car = XSYMBOL (sym)->value;
+ XBUFFER_LOCAL_VALUE (newval)->cdr = Fcons (Fcurrent_buffer (), tem);
+ XSYMBOL (sym)->value = newval;
return sym;
}
CHECK_SYMBOL (sym, 0);
- if (EQ (sym, Qnil) || EQ (sym, Qt))
+ valcontents = XSYMBOL (sym)->value;
+ if (EQ (sym, Qnil) || EQ (sym, Qt) || KBOARD_OBJFWDP (valcontents))
error ("Symbol %s may not be buffer-local", XSYMBOL (sym)->name->data);
- valcontents = XSYMBOL (sym)->value;
if (BUFFER_LOCAL_VALUEP (valcontents) || BUFFER_OBJFWDP (valcontents))
{
tem = Fboundp (sym);
-
+
/* Make sure the symbol has a local value in this particular buffer,
by setting it to the same value it already has. */
Fset (sym, (EQ (tem, Qt) ? Fsymbol_value (sym) : Qunbound));
/* Make sure sym 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;
- XSYMBOL (sym)->value = Fcons (XSYMBOL (sym)->value, Fcons (Qnil, tem));
- XSETTYPE (XSYMBOL (sym)->value, Lisp_Some_Buffer_Local_Value);
+ newval = allocate_misc ();
+ XMISCTYPE (newval) = Lisp_Misc_Some_Buffer_Local_Value;
+ XBUFFER_LOCAL_VALUE (newval)->car = XSYMBOL (sym)->value;
+ XBUFFER_LOCAL_VALUE (newval)->cdr = Fcons (Qnil, tem);
+ XSYMBOL (sym)->value = newval;
}
/* Make sure this buffer has its own value of sym */
tem = Fassq (sym, current_buffer->local_var_alist);
if (NILP (tem))
{
current_buffer->local_var_alist
- = Fcons (Fcons (sym, XCONS (XCONS (XCONS (XSYMBOL (sym)->value)->cdr)->cdr)->cdr),
+ = Fcons (Fcons (sym, XCONS (XCONS (XBUFFER_LOCAL_VALUE (XSYMBOL (sym)->value)->cdr)->cdr)->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 */
{
- /* This local variable avoids "expression too complex" on IBM RT. */
- Lisp_Object xs;
-
- xs = XSYMBOL (sym)->value;
- if (current_buffer == XBUFFER (XCONS (XCONS (xs)->cdr)->car))
- XCONS (XCONS (XSYMBOL (sym)->value)->cdr)->car = Qnil;
+ Lisp_Object *pvalbuf;
+ valcontents = XSYMBOL (sym)->value;
+ pvalbuf = &XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->car;
+ if (current_buffer == XBUFFER (*pvalbuf))
+ *pvalbuf = Qnil;
}
}
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 = XCONS (XSYMBOL (sym)->value)->car;
+ valcontents = XBUFFER_LOCAL_VALUE (XSYMBOL (sym)->value)->car;
if (INTFWDP (valcontents) || BOOLFWDP (valcontents) || OBJFWDP (valcontents))
swap_in_symval_forwarding (sym, XSYMBOL (sym)->value);
tem = Fassq (sym, current_buffer->local_var_alist);
if (!NILP (tem))
- current_buffer->local_var_alist = Fdelq (tem, current_buffer->local_var_alist);
+ current_buffer->local_var_alist
+ = Fdelq (tem, 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 */
{
- Lisp_Object sv;
- sv = XSYMBOL (sym)->value;
- if (current_buffer == XBUFFER (XCONS (XCONS (sv)->cdr)->car))
- XCONS (XCONS (sv)->cdr)->car = Qnil;
+ Lisp_Object *pvalbuf;
+ valcontents = XSYMBOL (sym)->value;
+ pvalbuf = &XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->car;
+ if (current_buffer == XBUFFER (*pvalbuf))
+ *pvalbuf = Qnil;
}
return sym;
CHECK_NUMBER (idx, 1);
idxval = XINT (idx);
- if (!VECTORP (array) && !STRINGP (array) && !COMPILEDP (array))
- array = wrong_type_argument (Qarrayp, array);
- if (idxval < 0 || idxval >= XVECTOR (array)->size)
- args_out_of_range (array, idx);
if (STRINGP (array))
{
Lisp_Object val;
+ if (idxval < 0 || idxval >= XSTRING (array)->size)
+ args_out_of_range (array, idx);
XSETFASTINT (val, (unsigned char) XSTRING (array)->data[idxval]);
return val;
}
else
- return XVECTOR (array)->contents[idxval];
+ {
+ int size;
+ if (VECTORP (array))
+ size = XVECTOR (array)->size;
+ else if (COMPILEDP (array))
+ size = XVECTOR (array)->size & PSEUDOVECTOR_SIZE_MASK;
+ else
+ wrong_type_argument (Qarrayp, array);
+
+ if (idxval < 0 || idxval >= size)
+ args_out_of_range (array, idx);
+ return XVECTOR (array)->contents[idxval];
+ }
}
DEFUN ("aset", Faset, Saset, 3, 3, 0,
idxval = XINT (idx);
if (!VECTORP (array) && !STRINGP (array))
array = wrong_type_argument (Qarrayp, array);
- if (idxval < 0 || idxval >= XVECTOR (array)->size)
- args_out_of_range (array, idx);
CHECK_IMPURE (array);
if (VECTORP (array))
- XVECTOR (array)->contents[idxval] = newelt;
+ {
+ if (idxval < 0 || idxval >= XVECTOR (array)->size)
+ args_out_of_range (array, idx);
+ XVECTOR (array)->contents[idxval] = newelt;
+ }
else
{
+ if (idxval < 0 || idxval >= XSTRING (array)->size)
+ args_out_of_range (array, idx);
CHECK_NUMBER (newelt, 2);
XSTRING (array)->data[idxval] = XINT (newelt);
}
return newelt;
}
-
-Lisp_Object
-Farray_length (array)
- register Lisp_Object array;
-{
- register Lisp_Object size;
- if (!VECTORP (array) && !STRINGP (array) && !COMPILEDP (array))
- array = wrong_type_argument (Qarrayp, array);
- XSETFASTINT (size, XVECTOR (array)->size);
- return size;
-}
\f
/* Arithmetic functions */
char pigbuf[350]; /* see comments in float_to_string */
float_to_string (pigbuf, XFLOAT(num)->data);
- return build_string (pigbuf);
+ return build_string (pigbuf);
}
#endif /* LISP_FLOAT_TYPE */
- sprintf (buffer, "%d", XINT (num));
+ if (sizeof (int) == sizeof (EMACS_INT))
+ sprintf (buffer, "%d", XINT (num));
+ else if (sizeof (long) == sizeof (EMACS_INT))
+ sprintf (buffer, "%ld", XINT (num));
+ else
+ abort ();
return build_string (buffer);
}
(str)
register Lisp_Object str;
{
+ Lisp_Object value;
unsigned char *p;
CHECK_STRING (str, 0);
return make_float (atof (p));
#endif /* LISP_FLOAT_TYPE */
- return make_number (atoi (p));
+ 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;
}
-\f
+\f
enum arithop
{ Aadd, Asub, Amult, Adiv, Alogand, Alogior, Alogxor, Amax, Amin };
{
register Lisp_Object val;
register int argnum;
- register int accum;
- register int next;
+ register EMACS_INT accum;
+ register EMACS_INT next;
-#ifdef SWITCH_ENUM_BUG
- switch ((int) code)
-#else
- switch (code)
-#endif
+ switch (SWITCH_ENUM_CAST (code))
{
case Alogior:
case Alogxor:
#endif /* LISP_FLOAT_TYPE */
args[argnum] = val; /* runs into a compiler bug. */
next = XINT (args[argnum]);
-#ifdef SWITCH_ENUM_BUG
- switch ((int) code)
-#else
- switch (code)
-#endif
+ switch (SWITCH_ENUM_CAST (code))
{
case Aadd: accum += next; break;
case Asub:
{
register Lisp_Object val;
double next;
-
+
for (; argnum < nargs; argnum++)
{
val = args[argnum]; /* using args[argnum] as argument to CHECK_NUMBER_... */
args[argnum] = val; /* runs into a compiler bug. */
next = XINT (args[argnum]);
}
-#ifdef SWITCH_ENUM_BUG
- switch ((int) code)
-#else
- switch (code)
-#endif
+ switch (SWITCH_ENUM_CAST (code))
{
case Aadd:
accum += next;
register Lisp_Object num1, num2;
{
Lisp_Object val;
- int i1, i2;
+ EMACS_INT i1, i2;
#ifdef LISP_FLOAT_TYPE
CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1, 0);
f1 = fmod (f1, f2);
/* If the "remainder" comes out with the wrong sign, fix it. */
- if ((f1 < 0) != (f2 < 0))
+ if (f2 < 0 ? f1 > 0 : f1 < 0)
f1 += f2;
return (make_float (f1));
}
if (i2 == 0)
Fsignal (Qarith_error, Qnil);
-
+
i1 %= i2;
/* If the "remainder" comes out with the wrong sign, fix it. */
- if ((i1 < 0) != (i2 < 0))
+ if (i2 < 0 ? i1 > 0 : i1 < 0)
i1 += i2;
XSETINT (val, i1);
"Return VALUE with its bits shifted left by COUNT.\n\
If COUNT is negative, shifting is actually to the right.\n\
In this case, the sign bit is duplicated.")
- (num1, num2)
- register Lisp_Object num1, num2;
+ (value, count)
+ register Lisp_Object value, count;
{
register Lisp_Object val;
- CHECK_NUMBER (num1, 0);
- CHECK_NUMBER (num2, 1);
+ CHECK_NUMBER (value, 0);
+ CHECK_NUMBER (count, 1);
- if (XINT (num2) > 0)
- XSETINT (val, XINT (num1) << XFASTINT (num2));
+ if (XINT (count) > 0)
+ XSETINT (val, XINT (value) << XFASTINT (count));
else
- XSETINT (val, XINT (num1) >> -XINT (num2));
+ XSETINT (val, XINT (value) >> -XINT (count));
return val;
}
"Return VALUE with its bits shifted left by COUNT.\n\
If COUNT is negative, shifting is actually to the right.\n\
In this case, zeros are shifted in on the left.")
- (num1, num2)
- register Lisp_Object num1, num2;
+ (value, count)
+ register Lisp_Object value, count;
{
register Lisp_Object val;
- CHECK_NUMBER (num1, 0);
- CHECK_NUMBER (num2, 1);
+ CHECK_NUMBER (value, 0);
+ CHECK_NUMBER (count, 1);
- if (XINT (num2) > 0)
- XSETINT (val, (EMACS_UINT) XUINT (num1) << XFASTINT (num2));
+ if (XINT (count) > 0)
+ XSETINT (val, (EMACS_UINT) XUINT (value) << XFASTINT (count));
else
- XSETINT (val, (EMACS_UINT) XUINT (num1) >> -XINT (num2));
+ XSETINT (val, (EMACS_UINT) XUINT (value) >> -XINT (count));
return val;
}
staticpro (&Qad_advice_info);
staticpro (&Qad_activate);
+ /* Types that type-of returns. */
+ Qinteger = intern ("integer");
+ Qsymbol = intern ("symbol");
+ Qstring = intern ("string");
+ Qcons = intern ("cons");
+ Qmarker = intern ("marker");
+ Qoverlay = intern ("overlay");
+ Qfloat = intern ("float");
+ Qwindow_configuration = intern ("window-configuration");
+ Qprocess = intern ("process");
+ Qwindow = intern ("window");
+ /* Qsubr = intern ("subr"); */
+ Qcompiled_function = intern ("compiled-function");
+ Qbuffer = intern ("buffer");
+ Qframe = intern ("frame");
+ Qvector = intern ("vector");
+
+ staticpro (&Qinteger);
+ staticpro (&Qsymbol);
+ staticpro (&Qstring);
+ staticpro (&Qcons);
+ staticpro (&Qmarker);
+ staticpro (&Qoverlay);
+ staticpro (&Qfloat);
+ staticpro (&Qwindow_configuration);
+ staticpro (&Qprocess);
+ staticpro (&Qwindow);
+ /* staticpro (&Qsubr); */
+ staticpro (&Qcompiled_function);
+ staticpro (&Qbuffer);
+ staticpro (&Qframe);
+ staticpro (&Qvector);
+
defsubr (&Seq);
defsubr (&Snull);
+ defsubr (&Stype_of);
defsubr (&Slistp);
defsubr (&Snlistp);
defsubr (&Sconsp);
defsubr (&Ssub1);
defsubr (&Slognot);
- Fset (Qwholenump, Qnatnump);
+ XSYMBOL (Qwholenump)->function = XSYMBOL (Qnatnump)->function;
}
SIGTYPE
return;
#endif /* CANNOT_DUMP */
signal (SIGFPE, arith_error);
-
+
#ifdef uts
signal (SIGEMT, arith_error);
#endif /* uts */
HCoop / bpt / emacs.git / blobdiff