/* 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.
#include "keyboard.h"
#include "intervals.h"
+#ifndef NULL
+#define NULL (void *)0
+#endif
+
extern Lisp_Object Flookup_key ();
Lisp_Object Qstring_lessp, Qprovide, Qrequire;
(limit)
Lisp_Object limit;
{
- int val;
+ EMACS_INT val;
+ Lisp_Object lispy_val;
unsigned long denominator;
if (EQ (limit, Qt))
- seed_random (getpid () + time (0));
+ seed_random (getpid () + time (NULL));
if (NATNUMP (limit) && XFASTINT (limit) != 0)
{
/* Try to take our random number from the higher bits of VAL,
}
else
val = get_random ();
- return make_number (val);
+ XSETINT (lispy_val, val);
+ return lispy_val;
}
\f
/* Random data-structure functions */
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))
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, but text properties are ignored.\n\
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 character (integer), or a list or vector\n\
-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;
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] = Fcons (this, Qnil);
+ args[argnum] = Fnumber_to_string (this);
else
args[argnum] = wrong_type_argument (Qsequencep, this);
}
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 ("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\
+\(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)
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, prop;
+This is the last value stored with `(put SYMBOL PROPNAME VALUE)'.")
+ (symbol, propname)
+ Lisp_Object symbol, propname;
{
- return Fplist_get (Fsymbol_plist (sym), prop);
+ 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\
+\(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;
+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)
register Lisp_Object tail, prev;
Lisp_Object newcell;
prev = Qnil;
- for (tail = plist; !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))
+ if (EQ (prop, XCONS (tail)->car))
{
- Fsetcar (Fcdr (tail), val);
+ Fsetcar (XCONS (tail)->cdr, val);
return plist;
}
prev = tail;
if (NILP (prev))
return newcell;
else
- Fsetcdr (Fcdr (prev), newcell);
+ 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)'.")
- (sym, prop, val)
- Lisp_Object sym, prop, val;
+ (symbol, propname, value)
+ Lisp_Object symbol, propname, value;
{
- Fsetplist (sym, Fplist_put (Fsymbol_plist (sym), prop, val));
- return val;
+ CHECK_SYMBOL (symbol, 0);
+ XSYMBOL (symbol)->plist
+ = Fplist_put (XSYMBOL (symbol)->plist, propname, value);
+ return value;
}
DEFUN ("equal", Fequal, Sequal, 2, 2, 0,
goto tail_recurse;
case Lisp_Misc:
- if (XMISC (o1)->type != XMISC (o2)->type)
+ if (XMISCTYPE (o1) != XMISCTYPE (o2))
return 0;
if (OVERLAYP (o1))
{
same size. */
if (XVECTOR (o2)->size != size)
return 0;
- /* But only true vectors and compiled functions are actually sensible
- to compare, so eliminate the others now. */
+ /* 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))
+ if (!(size & (PVEC_COMPILED | PVEC_CHAR_TABLE)))
return 0;
size &= PSEUDOVECTOR_SIZE_MASK;
}
}
\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;
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 (&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);