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,
#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 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;
}
\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. */
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;
- return ((BUFFER_LOCAL_VALUEP (valcontents)
- || SOME_BUFFER_LOCAL_VALUEP (valcontents)
- || BUFFER_OBJFWDP (valcontents))
- ? Qt : Qnil);
+ 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;
+
+ /* 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 full-sized long integers and pairs of lispy integers. */
+/* Convert between long values and pairs of Lisp integers. */
Lisp_Object
long_to_cons (i)
(num)
Lisp_Object num;
{
- char buffer[20];
+ char buffer[VALBITS];
#ifndef LISP_FLOAT_TYPE
CHECK_NUMBER (num, 0);
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 */
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);