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;
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 ();
return Qcons;
case Lisp_Misc:
- switch (XMISC (object)->type)
+ switch (XMISCTYPE (object))
{
case Lisp_Misc_Marker:
return Qmarker;
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 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 (BOOL_VECTOR_P (object))
+ return Qt;
+ return Qnil;
+}
+
DEFUN ("arrayp", Farrayp, Sarrayp, 1, 1, 0, "T if OBJECT is an array (string or vector).")
(object)
Lisp_Object object;
(object)
register Lisp_Object object;
{
- if (CONSP (object) || NILP (object) || VECTORP (object) || STRINGP (object))
+ if (CONSP (object) || NILP (object) || VECTORP (object) || STRINGP (object)
+ || CHAR_TABLE_P (object) || BOOL_VECTOR_P (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);
offset = XBUFFER_OBJFWD (valcontents)->offset;
return *(Lisp_Object *)(offset + (char *)current_buffer);
- case Lisp_Misc_Display_Objfwd:
- if (!current_perdisplay)
- abort ();
- offset = XDISPLAY_OBJFWD (valcontents)->offset;
- return *(Lisp_Object *)(offset + (char *)current_perdisplay);
+ case Lisp_Misc_Kboard_Objfwd:
+ offset = XKBOARD_OBJFWD (valcontents)->offset;
+ return *(Lisp_Object *)(offset + (char *)current_kboard);
}
return valcontents;
}
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:
}
break;
- case Lisp_Misc_Display_Objfwd:
- if (!current_perdisplay)
- abort ();
- (*(Lisp_Object *)((char *)current_perdisplay
- + XDISPLAY_OBJFWD (valcontents)->offset))
+ case Lisp_Misc_Kboard_Objfwd:
+ (*(Lisp_Object *)((char *)current_kboard
+ + XKBOARD_OBJFWD (valcontents)->offset))
= newval;
break;
\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);
return *(Lisp_Object *)(XBUFFER_OBJFWD (valcontents)->offset
+ (char *)current_buffer);
- case Lisp_Misc_Display_Objfwd:
- if (!current_perdisplay)
- abort ();
- return *(Lisp_Object *)(XDISPLAY_OBJFWD (valcontents)->offset
- + (char *)current_perdisplay);
+ case Lisp_Misc_Kboard_Objfwd:
+ return *(Lisp_Object *)(XKBOARD_OBJFWD (valcontents)->offset
+ + (char *)current_kboard);
}
}
CHECK_SYMBOL (sym, 0);
valcontents = XSYMBOL (sym)->value;
- if (EQ (sym, Qnil) || EQ (sym, Qt) || DISPLAY_OBJFWDP (valcontents))
+ if (EQ (sym, Qnil) || EQ (sym, Qt) || KBOARD_OBJFWDP (valcontents))
error ("Symbol %s may not be buffer-local", XSYMBOL (sym)->name->data);
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);
valcontents = XSYMBOL (sym)->value;
- if (EQ (sym, Qnil) || EQ (sym, Qt) || DISPLAY_OBJFWDP (valcontents))
+ if (EQ (sym, Qnil) || EQ (sym, Qt) || KBOARD_OBJFWDP (valcontents))
error ("Symbol %s may not be buffer-local", XSYMBOL (sym)->name->data);
if (BUFFER_LOCAL_VALUEP (valcontents) || BUFFER_OBJFWDP (valcontents))
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
{
int size;
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);
}
#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
enum arithop
{
register Lisp_Object val;
register int argnum;
- register int accum;
- register int next;
+ register EMACS_INT accum;
+ register EMACS_INT next;
switch (SWITCH_ENUM_CAST (code))
{
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));
}
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);
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);
Qbuffer = intern ("buffer");
Qframe = intern ("frame");
Qvector = intern ("vector");
+ Qchar_table = intern ("char-table");
+ Qbool_vector = intern ("bool-vector");
staticpro (&Qinteger);
staticpro (&Qsymbol);
staticpro (&Qbuffer);
staticpro (&Qframe);
staticpro (&Qvector);
+ staticpro (&Qchar_table);
+ staticpro (&Qbool_vector);
defsubr (&Seq);
defsubr (&Snull);
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);