/* 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.
GNU Emacs is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 1, or (at your option)
+the Free Software Foundation; either version 2, or (at your option)
any later version.
GNU Emacs is distributed in the hope that it will be useful,
#ifndef standalone
#include "buffer.h"
+#include "keyboard.h"
#endif
#include "syssignal.h"
-#ifdef MSDOS
-/* These are redefined (correctly, but differently) in values.h. */
-#undef INTBITS
-#undef LONGBITS
-#undef SHORTBITS
-#endif
-
#ifdef LISP_FLOAT_TYPE
#ifdef STDC_HEADERS
Lisp_Object Qchar_or_string_p, Qmarkerp, Qinteger_or_marker_p, Qvectorp;
Lisp_Object Qbuffer_or_string_p;
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 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 Qchar_table, Qbool_vector;
+
static Lisp_Object swap_in_symval_forwarding ();
Lisp_Object
}
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;
+ if (GC_CHAR_TABLE_P (object))
+ return Qchar_table;
+ if (GC_BOOL_VECTOR_P (object))
+ return Qbool_vector;
+
+#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 (object))
+ return Qt;
+ return Qnil;
+}
+
+DEFUN ("char-table-p", Fchar_table_p, Schar_table_p, 1, 1, 0, "T if OBJECT is a char-table.")
+ (object)
+ Lisp_Object object;
+{
+ if (CHAR_TABLE_P (object))
+ return Qt;
+ return Qnil;
+}
+
+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.")
+ (object)
+ Lisp_Object object;
+{
+ if (VECTORP (object) || CHAR_TABLE_P (object))
+ return Qt;
+ return Qnil;
+}
+
+DEFUN ("bool-vector-p", Fbool_vector_p, Sbool_vector_p, 1, 1, 0, "T if OBJECT is a bool-vector.")
+ (object)
+ Lisp_Object object;
{
- if (STRINGP (obj))
+ if (BOOL_VECTOR_P (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)
+ || CHAR_TABLE_P (object) || BOOL_VECTOR_P (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 (NATNUMP (obj))
+ 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;
{
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;
}
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
\f
/* Find the value of a symbol, returning Qunbound if it's not bound.
This is helpful for code which just wants to get a variable's value
- if it has one, without signalling an error.
+ if it has one, without signaling an error.
Note that it must not be possible to quit
within this function. Great care is required for this. */
if (MISCP (valcontents))
{
- switch (XMISC (valcontents)->type)
+ 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);
}
}
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))
{
- XMISC (XSYMBOL (sym)->value)->type = Lisp_Misc_Buffer_Local_Value;
+ XMISCTYPE (XSYMBOL (sym)->value) = Lisp_Misc_Buffer_Local_Value;
return sym;
}
if (EQ (valcontents, Qunbound))
tem = Fcons (Qnil, Fsymbol_value (sym));
XCONS (tem)->car = tem;
newval = allocate_misc ();
- XMISC (newval)->type = Lisp_Misc_Buffer_Local_Value;
+ 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;
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));
tem = Fcons (Qnil, do_symval_forwarding (valcontents));
XCONS (tem)->car = tem;
newval = allocate_misc ();
- XMISC (newval)->type = Lisp_Misc_Some_Buffer_Local_Value;
+ 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;
tem = Fassq (sym, current_buffer->local_var_alist);
if (NILP (tem))
{
+ /* Swap out any local binding for some other buffer, and make
+ sure the current value is permanently recorded, if it's the
+ default value. */
+ find_symbol_value (sym);
+
current_buffer->local_var_alist
= Fcons (Fcons (sym, XCONS (XCONS (XBUFFER_LOCAL_VALUE (XSYMBOL (sym)->value)->cdr)->cdr)->cdr),
current_buffer->local_var_alist);
force it to look once again for this buffer's value */
{
Lisp_Object *pvalbuf;
+
valcontents = XSYMBOL (sym)->value;
+
pvalbuf = &XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->car;
if (current_buffer == XBUFFER (*pvalbuf))
*pvalbuf = Qnil;
}
DEFUN ("local-variable-p", Flocal_variable_p, Slocal_variable_p,
- 1, 1, 0,
- "Non-nil if VARIABLE has a local binding in the current buffer.")
- (sym)
- register Lisp_Object sym;
+ 1, 2, 0,
+ "Non-nil if VARIABLE has a local binding in buffer BUFFER.\n\
+BUFFER defaults to the current buffer.")
+ (sym, buffer)
+ register Lisp_Object sym, buffer;
{
Lisp_Object valcontents;
+ register struct buffer *buf;
+
+ if (NILP (buffer))
+ buf = current_buffer;
+ else
+ {
+ CHECK_BUFFER (buffer, 0);
+ buf = XBUFFER (buffer);
+ }
+
+ CHECK_SYMBOL (sym, 0);
+
+ valcontents = XSYMBOL (sym)->value;
+ if (BUFFER_LOCAL_VALUEP (valcontents)
+ || SOME_BUFFER_LOCAL_VALUEP (valcontents))
+ {
+ Lisp_Object tail, elt;
+ for (tail = buf->local_var_alist; CONSP (tail); tail = XCONS (tail)->cdr)
+ {
+ elt = XCONS (tail)->car;
+ if (EQ (sym, XCONS (elt)->car))
+ 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))
+ return Qt;
+ }
+ return Qnil;
+}
+
+DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p, Slocal_variable_if_set_p,
+ 1, 2, 0,
+ "Non-nil if VARIABLE will be local in buffer BUFFER if it is set there.\n\
+BUFFER defaults to the current buffer.")
+ (sym, buffer)
+ register Lisp_Object sym, buffer;
+{
+ Lisp_Object valcontents;
+ register struct buffer *buf;
+
+ if (NILP (buffer))
+ buf = current_buffer;
+ else
+ {
+ CHECK_BUFFER (buffer, 0);
+ buf = XBUFFER (buffer);
+ }
CHECK_SYMBOL (sym, 0);
valcontents = XSYMBOL (sym)->value;
- return ((BUFFER_LOCAL_VALUEP (valcontents)
- || SOME_BUFFER_LOCAL_VALUEP (valcontents)
- || BUFFER_OBJFWDP (valcontents))
- ? Qt : Qnil);
+
+ /* This means that make-variable-buffer-local was done. */
+ if (BUFFER_LOCAL_VALUEP (valcontents))
+ return Qt;
+ /* All these slots become local if they are set. */
+ if (BUFFER_OBJFWDP (valcontents))
+ return Qt;
+ if (SOME_BUFFER_LOCAL_VALUEP (valcontents))
+ {
+ Lisp_Object tail, elt;
+ for (tail = buf->local_var_alist; CONSP (tail); tail = XCONS (tail)->cdr)
+ {
+ elt = XCONS (tail)->car;
+ if (EQ (sym, XCONS (elt)->car))
+ return Qt;
+ }
+ }
+ return Qnil;
}
\f
/* Find the function at the end of a chain of symbol function indirections. */
DEFUN ("aref", Faref, Saref, 2, 2, 0,
"Return the element of ARRAY at index INDEX.\n\
-ARRAY may be a vector or a string, or a byte-code object. INDEX starts at 0.")
+ARRAY may be a vector, a string, a char-table, a bool-vector,\n\
+or a byte-code object. INDEX starts at 0.")
(array, idx)
register Lisp_Object array;
Lisp_Object idx;
XSETFASTINT (val, (unsigned char) XSTRING (array)->data[idxval]);
return val;
}
+ else if (BOOL_VECTOR_P (array))
+ {
+ int val;
+
+ if (idxval < 0 || idxval >= XBOOL_VECTOR (array)->size)
+ args_out_of_range (array, idx);
+
+ val = (unsigned char) XBOOL_VECTOR (array)->data[idxval / BITS_PER_CHAR];
+ return (val & (1 << (idxval % BITS_PER_CHAR)) ? Qt : Qnil);
+ }
+ else if (CHAR_TABLE_P (array))
+ {
+ Lisp_Object val;
+
+ 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
+ {
+ 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))
+ {
+ array = XCHAR_TABLE (array)->parent;
+ goto try_parent_char_table;
+
+ }
+
+ 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))
+ {
+ array = XCHAR_TABLE (array)->parent;
+ goto try_parent_char_table;
+ }
+
+ return val;
+ }
+#endif /* 0 */
+ }
else
{
- if (!VECTORP (array) && !COMPILEDP (array))
- array = wrong_type_argument (Qarrayp, array);
- if (idxval < 0 || idxval >= XVECTOR (array)->size)
+ 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];
}
CHECK_NUMBER (idx, 1);
idxval = XINT (idx);
- if (!VECTORP (array) && !STRINGP (array))
+ if (!VECTORP (array) && !STRINGP (array) && !BOOL_VECTOR_P (array)
+ && ! CHAR_TABLE_P (array))
array = wrong_type_argument (Qarrayp, array);
CHECK_IMPURE (array);
args_out_of_range (array, idx);
XVECTOR (array)->contents[idxval] = newelt;
}
+ else if (BOOL_VECTOR_P (array))
+ {
+ int val;
+
+ if (idxval < 0 || idxval >= XBOOL_VECTOR (array)->size)
+ args_out_of_range (array, idx);
+
+ val = (unsigned char) XBOOL_VECTOR (array)->data[idxval / BITS_PER_CHAR];
+
+ if (! NILP (newelt))
+ val |= 1 << (idxval % BITS_PER_CHAR);
+ else
+ val &= ~(1 << (idxval % BITS_PER_CHAR));
+ XBOOL_VECTOR (array)->data[idxval / BITS_PER_CHAR] = val;
+ }
+ 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];
+ else
+ {
+ int charset;
+ unsigned char c1, c2;
+ Lisp_Object val, val2;
+
+ BREAKUP_NON_ASCII_CHAR (idxval, charset, c1, c2);
+
+ if (c1 == 0)
+ return XCHAR_TABLE (array)->contents[charset] = newelt;
+
+ val = XCHAR_TABLE (array)->contents[charset];
+ if (!CHAR_TABLE_P (val))
+ XCHAR_TABLE (array)->contents[charset]
+ = val = Fmake_char_table (Qnil);
+
+ if (c2 == 0)
+ return XCHAR_TABLE (val)->contents[c1] = newelt;
+
+ val2 = XCHAR_TABLE (val)->contents[c2];
+ if (!CHAR_TABLE_P (val2))
+ XCHAR_TABLE (val)->contents[charset]
+ = val2 = Fmake_char_table (Qnil);
+
+ return XCHAR_TABLE (val2)->contents[c2] = newelt;
+ }
+#endif /* 0 */
+ }
else
{
if (idxval < 0 || idxval >= XSTRING (array)->size)
return Qnil;
}
\f
-/* Convert between 32-bit values and pairs of lispy 24-bit values. */
+/* Convert between long values and pairs of Lisp integers. */
Lisp_Object
long_to_cons (i)
unsigned int bot = i & 0xFFFF;
if (top == 0)
return make_number (bot);
- if (top == 0xFFFF)
+ if (top == (unsigned long)-1 >> 16)
return Fcons (make_number (-1), make_number (bot));
return Fcons (make_number (top), make_number (bot));
}
(num)
Lisp_Object num;
{
- char buffer[20];
+ char buffer[VALBITS];
#ifndef LISP_FLOAT_TYPE
CHECK_NUMBER (num, 0);
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;
fmod (f1, f2)
double f1, f2;
{
-#ifdef HAVE_DREM /* Some systems use this non-standard name. */
- return (drem (f1, f2));
-#else /* Other systems don't seem to have it at all. */
+ if (f2 < 0.0)
+ f2 = -f2;
return (f1 - f2 * floor (f1/f2));
-#endif
}
#endif /* ! HAVE_FMOD */
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;
}
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");
+
Qcdr = intern ("cdr");
/* Handle automatic advice activation */
staticpro (&Qnumberp);
staticpro (&Qnumber_or_marker_p);
#endif /* LISP_FLOAT_TYPE */
+ staticpro (&Qchar_table_p);
+ staticpro (&Qvector_or_char_table_p);
staticpro (&Qboundp);
staticpro (&Qfboundp);
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");
+ Qchar_table = intern ("char-table");
+ Qbool_vector = intern ("bool-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);
+ staticpro (&Qchar_table);
+ staticpro (&Qbool_vector);
+
defsubr (&Seq);
defsubr (&Snull);
+ defsubr (&Stype_of);
defsubr (&Slistp);
defsubr (&Snlistp);
defsubr (&Sconsp);
defsubr (&Ssymbolp);
defsubr (&Sstringp);
defsubr (&Svectorp);
+ defsubr (&Schar_table_p);
+ defsubr (&Svector_or_char_table_p);
+ defsubr (&Sbool_vector_p);
defsubr (&Sarrayp);
defsubr (&Ssequencep);
defsubr (&Sbufferp);
defsubr (&Smake_local_variable);
defsubr (&Skill_local_variable);
defsubr (&Slocal_variable_p);
+ defsubr (&Slocal_variable_if_set_p);
defsubr (&Saref);
defsubr (&Saset);
defsubr (&Snumber_to_string);
return;
#endif /* CANNOT_DUMP */
signal (SIGFPE, arith_error);
-
+
#ifdef uts
signal (SIGEMT, arith_error);
#endif /* uts */