/* Random utility Lisp functions.
- Copyright (C) 1985, 1986, 1987, 1993, 1994 Free Software Foundation, Inc.
+ Copyright (C) 1985, 86, 87, 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,
#include "keyboard.h"
#include "intervals.h"
+#ifndef NULL
+#define NULL (void *)0
+#endif
+
extern Lisp_Object Flookup_key ();
Lisp_Object Qstring_lessp, Qprovide, Qrequire;
Lisp_Object Qyes_or_no_p_history;
-static Lisp_Object internal_equal ();
+static int internal_equal ();
\f
DEFUN ("identity", Fidentity, Sidentity, 1, 1, 0,
"Return the argument unchanged.")
return arg;
}
+extern long get_random ();
+extern void seed_random ();
+extern long time ();
+
DEFUN ("random", Frandom, Srandom, 0, 1, 0,
"Return a pseudo-random number.\n\
-On most systems all integers representable in Lisp are equally likely.\n\
- This is 24 bits' worth.\n\
-With argument N, return random number in interval [0,N).\n\
+All integers representable in Lisp are equally likely.\n\
+ On most systems, this is 28 bits' worth.\n\
+With positive integer argument N, return random number in interval [0,N).\n\
With argument t, set the random number seed from the current time and pid.")
(limit)
Lisp_Object limit;
{
- int val;
+ EMACS_INT val;
+ Lisp_Object lispy_val;
unsigned long denominator;
- extern long random ();
- extern srandom ();
- extern long time ();
if (EQ (limit, Qt))
- srandom (getpid () + time (0));
- if (INTEGERP (limit) && XINT (limit) > 0)
+ seed_random (getpid () + time (NULL));
+ if (NATNUMP (limit) && XFASTINT (limit) != 0)
{
- if (XFASTINT (limit) >= 0x40000000)
- /* This case may occur on 64-bit machines. */
- val = random () % XFASTINT (limit);
- else
- {
- /* Try to take our random number from the higher bits of VAL,
- not the lower, since (says Gentzel) the low bits of `random'
- are less random than the higher ones. We do this by using the
- quotient rather than the remainder. At the high end of the RNG
- it's possible to get a quotient larger than limit; discarding
- these values eliminates the bias that would otherwise appear
- when using a large limit. */
- denominator = (unsigned long)0x40000000 / XFASTINT (limit);
- do
- val = (random () & 0x3fffffff) / denominator;
- while (val >= XFASTINT (limit));
- }
+ /* Try to take our random number from the higher bits of VAL,
+ not the lower, since (says Gentzel) the low bits of `random'
+ are less random than the higher ones. We do this by using the
+ quotient rather than the remainder. At the high end of the RNG
+ it's possible to get a quotient larger than limit; discarding
+ these values eliminates the bias that would otherwise appear
+ when using a large limit. */
+ denominator = ((unsigned long)1 << VALBITS) / XFASTINT (limit);
+ do
+ val = get_random () / denominator;
+ while (val >= XFASTINT (limit));
}
else
- val = random ();
- return make_number (val);
+ val = get_random ();
+ XSETINT (lispy_val, val);
+ return lispy_val;
}
\f
/* Random data-structure functions */
register int i;
retry:
- if (VECTORP (obj) || STRINGP (obj) || COMPILEDP (obj))
- return Farray_length (obj);
+ if (STRINGP (obj))
+ XSETFASTINT (val, XSTRING (obj)->size);
+ else if (VECTORP (obj))
+ XSETFASTINT (val, XVECTOR (obj)->size);
+ else if (CHAR_TABLE_P (obj))
+ XSETFASTINT (val, CHAR_TABLE_ORDINARY_SLOTS);
+ else if (BOOL_VECTOR_P (obj))
+ XSETFASTINT (val, XBOOL_VECTOR (obj)->size);
+ else if (COMPILEDP (obj))
+ XSETFASTINT (val, XVECTOR (obj)->size & PSEUDOVECTOR_SIZE_MASK);
else if (CONSP (obj))
{
- for (i = 0, tail = obj; !NILP(tail); i++)
+ for (i = 0, tail = obj; !NILP (tail); i++)
{
QUIT;
tail = Fcdr (tail);
}
XSETFASTINT (val, i);
- return val;
- }
- else if (NILP(obj))
- {
- XSETFASTINT (val, 0);
- return val;
}
+ else if (NILP (obj))
+ XSETFASTINT (val, 0);
else
{
obj = wrong_type_argument (Qsequencep, obj);
goto retry;
}
+ return val;
+}
+
+/* This does not check for quits. That is safe
+ since it must terminate. */
+
+DEFUN ("safe-length", Fsafe_length, Ssafe_length, 1, 1, 0,
+ "Return the length of a list, but avoid error or infinite loop.\n\
+This function never gets an error. If LIST is not really a list,\n\
+it returns 0. If LIST is circular, it returns a finite value\n\
+which is at least the number of distinct elements.")
+ (list)
+ Lisp_Object list;
+{
+ Lisp_Object tail, halftail, length;
+ int len = 0;
+
+ /* halftail is used to detect circular lists. */
+ halftail = list;
+ for (tail = list; CONSP (tail); tail = XCONS (tail)->cdr)
+ {
+ if (EQ (tail, halftail) && len != 0)
+ break;
+ len++;
+ if ((len & 1) == 0)
+ halftail = XCONS (halftail)->cdr;
+ }
+
+ XSETINT (length, len);
+ return length;
}
DEFUN ("string-equal", Fstring_equal, Sstring_equal, 2, 2, 0,
"T if two strings have identical contents.\n\
-Case is significant.\n\
+Case is significant, but text properties are ignored.\n\
Symbols are also allowed; their print names are used instead.")
(s1, s2)
register Lisp_Object s1, s2;
DEFUN ("concat", Fconcat, Sconcat, 0, MANY, 0,
"Concatenate all the arguments and make the result a string.\n\
The result is a string whose elements are the elements of all the arguments.\n\
-Each argument may be a string, a list of characters (integers),\n\
-or a vector of characters (integers).")
+Each argument may be a string or a list or vector of characters (integers).\n\
+\n\
+Do not use individual integers as arguments!\n\
+The behavior of `concat' in that case will be changed later!\n\
+If your program passes an integer as an argument to `concat',\n\
+you should change it right away not to do so.")
(nargs, args)
int nargs;
Lisp_Object *args;
int nargs;
Lisp_Object *args;
{
- return concat (nargs, args, Lisp_Vector, 0);
+ return concat (nargs, args, Lisp_Vectorlike, 0);
}
DEFUN ("copy-sequence", Fcopy_sequence, Scopy_sequence, 1, 1, 0,
Lisp_Object arg;
{
if (NILP (arg)) return arg;
+
+ if (CHAR_TABLE_P (arg))
+ {
+ int i, size;
+ Lisp_Object copy;
+
+ /* Calculate the number of extra slots. */
+ size = CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (arg));
+ copy = Fmake_char_table (XCHAR_TABLE (arg)->purpose, Qnil);
+ /* Copy all the slots, including the extra ones. */
+ bcopy (XCHAR_TABLE (arg)->contents, XCHAR_TABLE (copy)->contents,
+ (XCHAR_TABLE (arg)->size & PSEUDOVECTOR_SIZE_MASK) * sizeof (Lisp_Object));
+
+ /* Recursively copy any char-tables in the ordinary slots. */
+ for (i = 0; i < CHAR_TABLE_ORDINARY_SLOTS; i++)
+ if (CHAR_TABLE_P (XCHAR_TABLE (arg)->contents[i]))
+ XCHAR_TABLE (copy)->contents[i]
+ = Fcopy_sequence (XCHAR_TABLE (copy)->contents[i]);
+
+ return copy;
+ }
+
+ if (BOOL_VECTOR_P (arg))
+ {
+ Lisp_Object val;
+ int size_in_chars
+ = (XBOOL_VECTOR (arg)->size + BITS_PER_CHAR) / BITS_PER_CHAR;
+
+ val = Fmake_bool_vector (Flength (arg), Qnil);
+ bcopy (XBOOL_VECTOR (arg)->data, XBOOL_VECTOR (val)->data,
+ size_in_chars);
+ return val;
+ }
+
if (!CONSP (arg) && !VECTORP (arg) && !STRINGP (arg))
arg = wrong_type_argument (Qsequencep, arg);
return concat (1, &arg, CONSP (arg) ? Lisp_Cons : XTYPE (arg), 0);
{
this = args[argnum];
if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
- || COMPILEDP (this)))
+ || COMPILEDP (this) || BOOL_VECTOR_P (this)))
{
if (INTEGERP (this))
args[argnum] = Fnumber_to_string (this);
if (target_type == Lisp_Cons)
val = Fmake_list (len, Qnil);
- else if (target_type == Lisp_Vector)
+ else if (target_type == Lisp_Vectorlike)
val = Fmake_vector (len, Qnil);
else
val = Fmake_string (len, len);
if (thisindex >= thisleni) break;
if (STRINGP (this))
XSETFASTINT (elt, XSTRING (this)->data[thisindex++]);
+ else if (BOOL_VECTOR_P (this))
+ {
+ int size_in_chars
+ = ((XBOOL_VECTOR (this)->size + BITS_PER_CHAR)
+ / BITS_PER_CHAR);
+ int byte;
+ byte = XBOOL_VECTOR (val)->data[thisindex / BITS_PER_CHAR];
+ if (byte & (1 << thisindex))
+ elt = Qt;
+ else
+ elt = Qnil;
+ }
else
elt = XVECTOR (this)->contents[thisindex++];
}
{
if (CONSP (seq) || NILP (seq))
return Fcar (Fnthcdr (n, seq));
- else if (STRINGP (seq) || VECTORP (seq))
+ else if (STRINGP (seq) || VECTORP (seq) || BOOL_VECTOR_P (seq)
+ || CHAR_TABLE_P (seq))
return Faref (seq, n);
else
seq = wrong_type_argument (Qsequencep, seq);
DEFUN ("assoc", Fassoc, Sassoc, 2, 2, 0,
"Return non-nil if KEY is `equal' to the car of an element of LIST.\n\
-The value is actually the element of LIST whose car is KEY.")
+The value is actually the element of LIST whose car equals KEY.")
(key, list)
register Lisp_Object key;
Lisp_Object list;
}
return Qnil;
}
+
+DEFUN ("rassoc", Frassoc, Srassoc, 2, 2, 0,
+ "Return non-nil if KEY is `equal' to the cdr of an element of LIST.\n\
+The value is actually the element of LIST whose cdr equals KEY.")
+ (key, list)
+ register Lisp_Object key;
+ Lisp_Object list;
+{
+ register Lisp_Object tail;
+ for (tail = list; !NILP (tail); tail = Fcdr (tail))
+ {
+ register Lisp_Object elt, tem;
+ elt = Fcar (tail);
+ if (!CONSP (elt)) continue;
+ tem = Fequal (Fcdr (elt), key);
+ if (!NILP (tem)) return elt;
+ QUIT;
+ }
+ return Qnil;
+}
\f
DEFUN ("delq", Fdelq, Sdelq, 2, 2, 0,
"Delete by side effect any occurrences of ELT as a member of LIST.\n\
}
}
\f
-DEFUN ("get", Fget, Sget, 2, 2, 0,
- "Return the value of SYMBOL's PROPNAME property.\n\
-This is the last VALUE stored with `(put SYMBOL PROPNAME VALUE)'.")
- (sym, prop)
- Lisp_Object sym;
+
+DEFUN ("plist-get", Fplist_get, Splist_get, 2, 2, 0,
+ "Extract a value from a property list.\n\
+PLIST is a property list, which is a list of the form\n\
+\(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value\n\
+corresponding to the given PROP, or nil if PROP is not\n\
+one of the properties on the list.")
+ (val, prop)
+ Lisp_Object val;
register Lisp_Object prop;
{
register Lisp_Object tail;
- for (tail = Fsymbol_plist (sym); !NILP (tail); tail = Fcdr (Fcdr (tail)))
+ for (tail = val; !NILP (tail); tail = Fcdr (Fcdr (tail)))
{
register Lisp_Object tem;
tem = Fcar (tail);
return Qnil;
}
-DEFUN ("put", Fput, Sput, 3, 3, 0,
- "Store SYMBOL's PROPNAME property with value VALUE.\n\
-It can be retrieved with `(get SYMBOL PROPNAME)'.")
- (sym, prop, val)
- Lisp_Object sym;
- register Lisp_Object prop;
- Lisp_Object val;
+DEFUN ("get", Fget, Sget, 2, 2, 0,
+ "Return the value of SYMBOL's PROPNAME property.\n\
+This is the last value stored with `(put SYMBOL PROPNAME VALUE)'.")
+ (symbol, propname)
+ Lisp_Object symbol, propname;
+{
+ CHECK_SYMBOL (symbol, 0);
+ return Fplist_get (XSYMBOL (symbol)->plist, propname);
+}
+
+DEFUN ("plist-put", Fplist_put, Splist_put, 3, 3, 0,
+ "Change value in PLIST of PROP to VAL.\n\
+PLIST is a property list, which is a list of the form\n\
+\(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.\n\
+If PROP is already a property on the list, its value is set to VAL,\n\
+otherwise the new PROP VAL pair is added. The new plist is returned;\n\
+use `(setq x (plist-put x prop val))' to be sure to use the new value.\n\
+The PLIST is modified by side effects.")
+ (plist, prop, val)
+ Lisp_Object plist;
+ register Lisp_Object prop;
+ Lisp_Object val;
{
register Lisp_Object tail, prev;
Lisp_Object newcell;
prev = Qnil;
- for (tail = Fsymbol_plist (sym); !NILP (tail); tail = Fcdr (Fcdr (tail)))
+ for (tail = plist; CONSP (tail) && CONSP (XCONS (tail)->cdr);
+ tail = XCONS (XCONS (tail)->cdr)->cdr)
{
- register Lisp_Object tem;
- tem = Fcar (tail);
- if (EQ (prop, tem))
- return Fsetcar (Fcdr (tail), val);
+ if (EQ (prop, XCONS (tail)->car))
+ {
+ Fsetcar (XCONS (tail)->cdr, val);
+ return plist;
+ }
prev = tail;
}
newcell = Fcons (prop, Fcons (val, Qnil));
if (NILP (prev))
- Fsetplist (sym, newcell);
+ return newcell;
else
- Fsetcdr (Fcdr (prev), newcell);
- return val;
+ Fsetcdr (XCONS (prev)->cdr, newcell);
+ return plist;
+}
+
+DEFUN ("put", Fput, Sput, 3, 3, 0,
+ "Store SYMBOL's PROPNAME property with value VALUE.\n\
+It can be retrieved with `(get SYMBOL PROPNAME)'.")
+ (symbol, propname, value)
+ Lisp_Object symbol, propname, value;
+{
+ CHECK_SYMBOL (symbol, 0);
+ XSYMBOL (symbol)->plist
+ = Fplist_put (XSYMBOL (symbol)->plist, propname, value);
+ return value;
}
DEFUN ("equal", Fequal, Sequal, 2, 2, 0,
(o1, o2)
register Lisp_Object o1, o2;
{
- return internal_equal (o1, o2, 0);
+ return internal_equal (o1, o2, 0) ? Qt : Qnil;
}
-static Lisp_Object
+static int
internal_equal (o1, o2, depth)
register Lisp_Object o1, o2;
int depth;
{
if (depth > 200)
error ("Stack overflow in equal");
-do_cdr:
+
+ tail_recurse:
QUIT;
- if (EQ (o1, o2)) return Qt;
+ if (EQ (o1, o2))
+ return 1;
+ if (XTYPE (o1) != XTYPE (o2))
+ return 0;
+
+ switch (XTYPE (o1))
+ {
#ifdef LISP_FLOAT_TYPE
- if (FLOATP (o1) && FLOATP (o2))
- return (extract_float (o1) == extract_float (o2)) ? Qt : Qnil;
+ case Lisp_Float:
+ return (extract_float (o1) == extract_float (o2));
#endif
- if (XTYPE (o1) != XTYPE (o2)) return Qnil;
- if (MISCP (o1) && XMISC (o1)->type != XMISC (o2)->type) return Qnil;
- if (CONSP (o1) || OVERLAYP (o1))
- {
- Lisp_Object v1;
- v1 = internal_equal (Fcar (o1), Fcar (o2), depth + 1);
- if (NILP (v1))
- return v1;
- o1 = Fcdr (o1), o2 = Fcdr (o2);
- goto do_cdr;
- }
- if (MARKERP (o1))
- {
- return ((XMARKER (o1)->buffer == XMARKER (o2)->buffer
- && (XMARKER (o1)->buffer == 0
- || XMARKER (o1)->bufpos == XMARKER (o2)->bufpos))
- ? Qt : Qnil);
- }
- if (VECTORP (o1) || COMPILEDP (o1))
- {
- register int index;
- if (XVECTOR (o1)->size != XVECTOR (o2)->size)
- return Qnil;
- for (index = 0; index < XVECTOR (o1)->size; index++)
+
+ case Lisp_Cons:
+ if (!internal_equal (XCONS (o1)->car, XCONS (o2)->car, depth + 1))
+ return 0;
+ o1 = XCONS (o1)->cdr;
+ o2 = XCONS (o2)->cdr;
+ goto tail_recurse;
+
+ case Lisp_Misc:
+ if (XMISCTYPE (o1) != XMISCTYPE (o2))
+ return 0;
+ if (OVERLAYP (o1))
{
- Lisp_Object v, v1, v2;
- v1 = XVECTOR (o1)->contents [index];
- v2 = XVECTOR (o2)->contents [index];
- v = internal_equal (v1, v2, depth + 1);
- if (NILP (v)) return v;
+ if (!internal_equal (OVERLAY_START (o1), OVERLAY_START (o1),
+ depth + 1)
+ || !internal_equal (OVERLAY_END (o1), OVERLAY_END (o1),
+ depth + 1))
+ return 0;
+ o1 = XOVERLAY (o1)->plist;
+ o2 = XOVERLAY (o2)->plist;
+ goto tail_recurse;
}
- return Qt;
- }
- if (STRINGP (o1))
- {
+ if (MARKERP (o1))
+ {
+ return (XMARKER (o1)->buffer == XMARKER (o2)->buffer
+ && (XMARKER (o1)->buffer == 0
+ || XMARKER (o1)->bufpos == XMARKER (o2)->bufpos));
+ }
+ break;
+
+ case Lisp_Vectorlike:
+ {
+ register int i, size;
+ size = XVECTOR (o1)->size;
+ /* Pseudovectors have the type encoded in the size field, so this test
+ actually checks that the objects have the same type as well as the
+ same size. */
+ if (XVECTOR (o2)->size != size)
+ return 0;
+ /* Boolvectors are compared much like strings. */
+ if (BOOL_VECTOR_P (o1))
+ {
+ int size_in_chars
+ = (XBOOL_VECTOR (o1)->size + BITS_PER_CHAR) / BITS_PER_CHAR;
+
+ if (XBOOL_VECTOR (o1)->size != XBOOL_VECTOR (o2)->size)
+ return 0;
+ if (bcmp (XBOOL_VECTOR (o1)->data, XBOOL_VECTOR (o2)->data,
+ size_in_chars))
+ return 0;
+ return 1;
+ }
+
+ /* Aside from them, only true vectors, char-tables, and compiled
+ functions are sensible to compare, so eliminate the others now. */
+ if (size & PSEUDOVECTOR_FLAG)
+ {
+ if (!(size & (PVEC_COMPILED | PVEC_CHAR_TABLE)))
+ return 0;
+ size &= PSEUDOVECTOR_SIZE_MASK;
+ }
+ for (i = 0; i < size; i++)
+ {
+ Lisp_Object v1, v2;
+ v1 = XVECTOR (o1)->contents [i];
+ v2 = XVECTOR (o2)->contents [i];
+ if (!internal_equal (v1, v2, depth + 1))
+ return 0;
+ }
+ return 1;
+ }
+ break;
+
+ case Lisp_String:
if (XSTRING (o1)->size != XSTRING (o2)->size)
- return Qnil;
- if (bcmp (XSTRING (o1)->data, XSTRING (o2)->data, XSTRING (o1)->size))
- return Qnil;
- return Qt;
+ return 0;
+ if (bcmp (XSTRING (o1)->data, XSTRING (o2)->data,
+ XSTRING (o1)->size))
+ return 0;
+#ifdef USE_TEXT_PROPERTIES
+ /* If the strings have intervals, verify they match;
+ if not, they are unequal. */
+ if ((XSTRING (o1)->intervals != 0 || XSTRING (o2)->intervals != 0)
+ && ! compare_string_intervals (o1, o2))
+ return 0;
+#endif
+ return 1;
}
- return Qnil;
+ return 0;
}
\f
DEFUN ("fillarray", Ffillarray, Sfillarray, 2, 2, 0,
- "Store each element of ARRAY with ITEM. ARRAY is a vector or string.")
+ "Store each element of ARRAY with ITEM.\n\
+ARRAY is a vector, string, char-table, or bool-vector.")
(array, item)
Lisp_Object array, item;
{
for (index = 0; index < size; index++)
p[index] = item;
}
+ else if (CHAR_TABLE_P (array))
+ {
+ register Lisp_Object *p = XCHAR_TABLE (array)->contents;
+ size = CHAR_TABLE_ORDINARY_SLOTS;
+ for (index = 0; index < size; index++)
+ p[index] = item;
+ XCHAR_TABLE (array)->defalt = Qnil;
+ }
else if (STRINGP (array))
{
register unsigned char *p = XSTRING (array)->data;
for (index = 0; index < size; index++)
p[index] = charval;
}
+ else if (BOOL_VECTOR_P (array))
+ {
+ register unsigned char *p = XBOOL_VECTOR (array)->data;
+ int size_in_chars
+ = (XBOOL_VECTOR (array)->size + BITS_PER_CHAR) / BITS_PER_CHAR;
+
+ charval = (! NILP (item) ? -1 : 0);
+ for (index = 0; index < size_in_chars; index++)
+ p[index] = charval;
+ }
else
{
array = wrong_type_argument (Qarrayp, array);
return array;
}
+DEFUN ("char-table-subtype", Fchar_table_subtype, Schar_table_subtype,
+ 1, 1, 0,
+ "Return the subtype of char-table CHAR-TABLE. The value is a symbol.")
+ (chartable)
+ Lisp_Object chartable;
+{
+ CHECK_CHAR_TABLE (chartable, 0);
+
+ return XCHAR_TABLE (chartable)->purpose;
+}
+
+DEFUN ("char-table-parent", Fchar_table_parent, Schar_table_parent,
+ 1, 1, 0,
+ "Return the parent char-table of CHAR-TABLE.\n\
+The value is either nil or another char-table.\n\
+If CHAR-TABLE holds nil for a given character,\n\
+then the actual applicable value is inherited from the parent char-table\n\
+\(or from its parents, if necessary).")
+ (chartable)
+ Lisp_Object chartable;
+{
+ CHECK_CHAR_TABLE (chartable, 0);
+
+ return XCHAR_TABLE (chartable)->parent;
+}
+
+DEFUN ("set-char-table-parent", Fset_char_table_parent, Sset_char_table_parent,
+ 2, 2, 0,
+ "Set the parent char-table of CHAR-TABLE to PARENT.\n\
+PARENT must be either nil or another char-table.")
+ (chartable, parent)
+ Lisp_Object chartable, parent;
+{
+ Lisp_Object temp;
+
+ CHECK_CHAR_TABLE (chartable, 0);
+
+ if (!NILP (parent))
+ {
+ CHECK_CHAR_TABLE (parent, 0);
+
+ for (temp = parent; !NILP (temp); temp = XCHAR_TABLE (temp)->parent)
+ if (EQ (temp, chartable))
+ error ("Attempt to make a chartable be its own parent");
+ }
+
+ XCHAR_TABLE (chartable)->parent = parent;
+
+ return parent;
+}
+
+DEFUN ("char-table-extra-slot", Fchar_table_extra_slot, Schar_table_extra_slot,
+ 2, 2, 0,
+ "Return the value in extra-slot number N of char-table CHAR-TABLE.")
+ (chartable, n)
+ Lisp_Object chartable, n;
+{
+ CHECK_CHAR_TABLE (chartable, 1);
+ CHECK_NUMBER (n, 2);
+ if (XINT (n) < 0
+ || XINT (n) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (chartable)))
+ args_out_of_range (chartable, n);
+
+ return XCHAR_TABLE (chartable)->extras[XINT (n)];
+}
+
+DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot,
+ Sset_char_table_extra_slot,
+ 3, 3, 0,
+ "Set extra-slot number N of CHAR-TABLE to VALUE.")
+ (chartable, n, value)
+ Lisp_Object chartable, n, value;
+{
+ CHECK_CHAR_TABLE (chartable, 1);
+ CHECK_NUMBER (n, 2);
+ if (XINT (n) < 0
+ || XINT (n) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (chartable)))
+ args_out_of_range (chartable, n);
+
+ return XCHAR_TABLE (chartable)->extras[XINT (n)] = value;
+}
+
+DEFUN ("char-table-range", Fchar_table_range, Schar_table_range,
+ 2, 2, 0,
+ "Return the value in CHARTABLE for a range of characters RANGE.\n\
+RANGE should be t (for all characters), nil (for the default value)\n\
+a vector which identifies a character set or a row of a character set,\n\
+or a character code.")
+ (chartable, range)
+ Lisp_Object chartable, range;
+{
+ int i;
+
+ CHECK_CHAR_TABLE (chartable, 0);
+
+ if (EQ (range, Qnil))
+ return XCHAR_TABLE (chartable)->defalt;
+ else if (INTEGERP (range))
+ return Faref (chartable, range);
+ else if (VECTORP (range))
+ {
+ for (i = 0; i < XVECTOR (range)->size - 1; i++)
+ chartable = Faref (chartable, XVECTOR (range)->contents[i]);
+
+ if (EQ (XVECTOR (range)->contents[i], Qnil))
+ return XCHAR_TABLE (chartable)->defalt;
+ else
+ return Faref (chartable, XVECTOR (range)->contents[i]);
+ }
+ else
+ error ("Invalid RANGE argument to `char-table-range'");
+}
+
+DEFUN ("set-char-table-range", Fset_char_table_range, Sset_char_table_range,
+ 3, 3, 0,
+ "Set the value in CHARTABLE for a range of characters RANGE to VALUE.\n\
+RANGE should be t (for all characters), nil (for the default value)\n\
+a vector which identifies a character set or a row of a character set,\n\
+or a character code.")
+ (chartable, range, value)
+ Lisp_Object chartable, range, value;
+{
+ int i;
+
+ CHECK_CHAR_TABLE (chartable, 0);
+
+ if (EQ (range, Qt))
+ for (i = 0; i < CHAR_TABLE_ORDINARY_SLOTS; i++)
+ XCHAR_TABLE (chartable)->contents[i] = value;
+ else if (EQ (range, Qnil))
+ XCHAR_TABLE (chartable)->defalt = value;
+ else if (INTEGERP (range))
+ Faset (chartable, range, value);
+ else if (VECTORP (range))
+ {
+ for (i = 0; i < XVECTOR (range)->size - 1; i++)
+ chartable = Faref (chartable, XVECTOR (range)->contents[i]);
+
+ if (EQ (XVECTOR (range)->contents[i], Qnil))
+ XCHAR_TABLE (chartable)->defalt = value;
+ else
+ Faset (chartable, XVECTOR (range)->contents[i], value);
+ }
+ else
+ error ("Invalid RANGE argument to `set-char-table-range'");
+
+ return value;
+}
+\f
+/* Map C_FUNCTION or FUNCTION over CHARTABLE, calling it for each
+ character or group of characters that share a value.
+ DEPTH is the current depth in the originally specified
+ chartable, and INDICES contains the vector indices
+ for the levels our callers have descended. */
+
+void
+map_char_table (c_function, function, chartable, depth, indices)
+ Lisp_Object (*c_function) (), function, chartable, depth, *indices;
+{
+ int i;
+ int size = CHAR_TABLE_ORDINARY_SLOTS;
+
+ /* Make INDICES longer if we are about to fill it up. */
+ if ((depth % 10) == 9)
+ {
+ Lisp_Object *new_indices
+ = (Lisp_Object *) alloca ((depth += 10) * sizeof (Lisp_Object));
+ bcopy (indices, new_indices, depth * sizeof (Lisp_Object));
+ indices = new_indices;
+ }
+
+ for (i = 0; i < size; i++)
+ {
+ Lisp_Object elt;
+ indices[depth] = i;
+ elt = XCHAR_TABLE (chartable)->contents[i];
+ if (CHAR_TABLE_P (elt))
+ map_char_table (chartable, c_function, function, depth + 1, indices);
+ else if (c_function)
+ (*c_function) (depth + 1, indices, elt);
+ /* Here we should handle all cases where the range is a single character
+ by passing that character as a number. Currently, that is
+ all the time, but with the MULE code this will have to be changed. */
+ else if (depth == 0)
+ call2 (function, make_number (i), elt);
+ else
+ call2 (function, Fvector (depth + 1, indices), elt);
+ }
+}
+
+DEFUN ("map-char-table", Fmap_char_table, Smap_char_table,
+ 2, 2, 0,
+ "Call FUNCTION for each range of like characters in CHARTABLE.\n\
+FUNCTION is called with two arguments--a key and a value.\n\
+The key is always a possible RANGE argument to `set-char-table-range'.")
+ (function, chartable)
+ Lisp_Object function, chartable;
+{
+ Lisp_Object keyvec;
+ Lisp_Object *indices = (Lisp_Object *) alloca (10 * sizeof (Lisp_Object));
+
+ map_char_table (NULL, function, chartable, 0, indices);
+ return Qnil;
+}
+\f
/* ARGSUSED */
Lisp_Object
nconc2 (s1, s2)
while (1)
{
-#ifdef HAVE_X_MENU
+#if defined (HAVE_X_MENU) || defined (HAVE_NTGUI)
if ((NILP (last_nonmenu_event) || CONSP (last_nonmenu_event))
&& using_x_p ())
{
}
#endif
cursor_in_echo_area = 1;
- message ("%s(y or n) ", XSTRING (xprompt)->data);
+ message_nolog ("%s(y or n) ", XSTRING (xprompt)->data);
obj = read_filtered_event (1, 0, 0);
cursor_in_echo_area = 0;
}
else if (EQ (def, intern ("quit")))
Vquit_flag = Qt;
+ /* We want to exit this command for exit-prefix,
+ and this is the only way to do it. */
+ else if (EQ (def, intern ("exit-prefix")))
+ Vquit_flag = Qt;
QUIT;
if (! noninteractive)
{
cursor_in_echo_area = -1;
- message ("%s(y or n) %c", XSTRING (xprompt)->data, answer ? 'y' : 'n');
+ message_nolog ("%s(y or n) %c",
+ XSTRING (xprompt)->data, answer ? 'y' : 'n');
cursor_in_echo_area = ocech;
}
Takes one argument, which is the string to display to ask the question.\n\
It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.\n\
The user must confirm the answer with RET,\n\
-and can edit it until it as been confirmed.")
+and can edit it until it has been confirmed.")
(prompt)
Lisp_Object prompt;
{
CHECK_STRING (prompt, 0);
-#ifdef HAVE_X_MENU
- if ((NILP (last_nonmenu_event) || CONSP (last_nonmenu_event))
+#if defined (HAVE_X_MENU) || defined (HAVE_NTGUI)
+ if ((NILP (last_nonmenu_event) || CONSP (last_nonmenu_event))
&& using_x_p ())
{
Lisp_Object pane, menu, obj;
defsubr (&Sidentity);
defsubr (&Srandom);
defsubr (&Slength);
+ defsubr (&Ssafe_length);
defsubr (&Sstring_equal);
defsubr (&Sstring_lessp);
defsubr (&Sappend);
defsubr (&Sassq);
defsubr (&Sassoc);
defsubr (&Srassq);
+ defsubr (&Srassoc);
defsubr (&Sdelq);
defsubr (&Sdelete);
defsubr (&Snreverse);
defsubr (&Sreverse);
defsubr (&Ssort);
+ defsubr (&Splist_get);
defsubr (&Sget);
+ defsubr (&Splist_put);
defsubr (&Sput);
defsubr (&Sequal);
defsubr (&Sfillarray);
+ defsubr (&Schar_table_subtype);
+ defsubr (&Schar_table_parent);
+ defsubr (&Sset_char_table_parent);
+ defsubr (&Schar_table_extra_slot);
+ defsubr (&Sset_char_table_extra_slot);
+ defsubr (&Schar_table_range);
+ defsubr (&Sset_char_table_range);
+ defsubr (&Smap_char_table);
defsubr (&Snconc);
defsubr (&Smapcar);
defsubr (&Smapconcat);