You should have received a copy of the GNU General Public License
along with GNU Emacs; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA. */
#include <config.h>
#include "lisp.h"
#include "commands.h"
+#include "charset.h"
#include "buffer.h"
#include "keyboard.h"
#include "intervals.h"
+#include "frame.h"
+#include "window.h"
+
+#ifndef NULL
+#define NULL (void *)0
+#endif
+
+/* Nonzero enables use of dialog boxes for questions
+ asked by mouse commands. */
+int use_dialog_box;
extern Lisp_Object Flookup_key ();
+extern int minibuffer_auto_raise;
+extern Lisp_Object minibuf_window;
+
Lisp_Object Qstring_lessp, Qprovide, Qrequire;
Lisp_Object Qyes_or_no_p_history;
+Lisp_Object Qcursor_in_echo_area;
static int internal_equal ();
\f
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;
+ (n)
+ Lisp_Object n;
{
- int val;
+ EMACS_INT val;
+ Lisp_Object lispy_val;
unsigned long denominator;
- if (EQ (limit, Qt))
- seed_random (getpid () + time (0));
- if (NATNUMP (limit) && XFASTINT (limit) != 0)
+ if (EQ (n, Qt))
+ seed_random (getpid () + time (NULL));
+ if (NATNUMP (n) && XFASTINT (n) != 0)
{
/* 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
+ it's possible to get a quotient larger than n; discarding
these values eliminates the bias that would otherwise appear
- when using a large limit. */
- denominator = ((unsigned long)1 << VALBITS) / XFASTINT (limit);
+ when using a large n. */
+ denominator = ((unsigned long)1 << VALBITS) / XFASTINT (n);
do
val = get_random () / denominator;
- while (val >= XFASTINT (limit));
+ while (val >= XFASTINT (n));
}
else
val = get_random ();
- return make_number (val);
+ XSETINT (lispy_val, val);
+ return lispy_val;
}
\f
/* Random data-structure functions */
DEFUN ("length", Flength, Slength, 1, 1, 0,
"Return the length of vector, list or string SEQUENCE.\n\
A byte-code function object is also allowed.")
- (obj)
- register Lisp_Object obj;
+ (sequence)
+ register Lisp_Object sequence;
{
register Lisp_Object tail, val;
register int i;
retry:
- if (STRINGP (obj))
- XSETFASTINT (val, XSTRING (obj)->size);
- else if (VECTORP (obj))
- XSETFASTINT (val, XVECTOR (obj)->size);
- else if (COMPILEDP (obj))
- XSETFASTINT (val, XVECTOR (obj)->size & PSEUDOVECTOR_SIZE_MASK);
- else if (CONSP (obj))
+ if (STRINGP (sequence))
+ XSETFASTINT (val, XSTRING (sequence)->size);
+ else if (VECTORP (sequence))
+ XSETFASTINT (val, XVECTOR (sequence)->size);
+ else if (CHAR_TABLE_P (sequence))
+ XSETFASTINT (val, CHAR_TABLE_ORDINARY_SLOTS);
+ else if (BOOL_VECTOR_P (sequence))
+ XSETFASTINT (val, XBOOL_VECTOR (sequence)->size);
+ else if (COMPILEDP (sequence))
+ XSETFASTINT (val, XVECTOR (sequence)->size & PSEUDOVECTOR_SIZE_MASK);
+ else if (CONSP (sequence))
{
- for (i = 0, tail = obj; !NILP (tail); i++)
+ for (i = 0, tail = sequence; !NILP (tail); i++)
{
QUIT;
tail = Fcdr (tail);
XSETFASTINT (val, i);
}
- else if (NILP (obj))
+ else if (NILP (sequence))
XSETFASTINT (val, 0);
else
{
- obj = wrong_type_argument (Qsequencep, obj);
+ sequence = wrong_type_argument (Qsequencep, sequence);
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, but text properties are ignored.\n\
return concat (nargs, args, Lisp_Vectorlike, 0);
}
+/* Retrun a copy of a sub char table ARG. The elements except for a
+ nested sub char table are not copied. */
+static Lisp_Object
+copy_sub_char_table (arg)
+ Lisp_Object arg;
+{
+ Lisp_Object copy = make_sub_char_table (XCHAR_TABLE (arg)->defalt);
+ int i;
+
+ /* Copy all the contents. */
+ bcopy (XCHAR_TABLE (arg)->contents, XCHAR_TABLE (copy)->contents,
+ SUB_CHAR_TABLE_ORDINARY_SLOTS * sizeof (Lisp_Object));
+ /* Recursively copy any sub char-tables in the ordinary slots. */
+ for (i = 32; i < SUB_CHAR_TABLE_ORDINARY_SLOTS; i++)
+ if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg)->contents[i]))
+ XCHAR_TABLE (copy)->contents[i]
+ = copy_sub_char_table (XCHAR_TABLE (copy)->contents[i]);
+
+ return copy;
+}
+
+
DEFUN ("copy-sequence", Fcopy_sequence, Scopy_sequence, 1, 1, 0,
"Return a copy of a list, vector or string.\n\
The elements of a list or vector are not copied; they are shared\n\
Lisp_Object arg;
{
if (NILP (arg)) return arg;
+
+ if (CHAR_TABLE_P (arg))
+ {
+ int i;
+ Lisp_Object copy;
+
+ copy = Fmake_char_table (XCHAR_TABLE (arg)->purpose, Qnil);
+ /* Copy all the slots, including the extra ones. */
+ bcopy (XVECTOR (arg)->contents, XVECTOR (copy)->contents,
+ ((XCHAR_TABLE (arg)->size & PSEUDOVECTOR_SIZE_MASK)
+ * sizeof (Lisp_Object)));
+
+ /* Recursively copy any sub char tables in the ordinary slots
+ for multibyte characters. */
+ for (i = CHAR_TABLE_SINGLE_BYTE_SLOTS;
+ i < CHAR_TABLE_ORDINARY_SLOTS; i++)
+ if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg)->contents[i]))
+ XCHAR_TABLE (copy)->contents[i]
+ = copy_sub_char_table (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 - 1) / 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);
{
this = args[argnum];
len = Flength (this);
- leni += XFASTINT (len);
+ if (VECTORP (this) && target_type == Lisp_String)
+ {
+ /* We must pay attention to a multibyte character which
+ takes more than one byte in string. */
+ int i;
+ Lisp_Object ch;
+
+ for (i = 0; i < XFASTINT (len); i++)
+ {
+ ch = XVECTOR (this)->contents[i];
+ if (! INTEGERP (ch))
+ wrong_type_argument (Qintegerp, ch);
+ leni += Fchar_bytes (ch);
+ }
+ }
+ else
+ leni += XFASTINT (len);
}
XSETFASTINT (len, leni);
{
Lisp_Object thislen;
int thisleni;
- register int thisindex = 0;
+ register unsigned int thisindex = 0;
this = args[argnum];
if (!CONSP (this))
`this' is exhausted. */
if (NILP (this)) break;
if (CONSP (this))
- elt = Fcar (this), this = Fcdr (this);
+ elt = XCONS (this)->car, this = XCONS (this)->cdr;
else
{
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 - 1)
+ / BITS_PER_CHAR);
+ int byte;
+ byte = XBOOL_VECTOR (val)->data[thisindex / BITS_PER_CHAR];
+ if (byte & (1 << (thisindex % BITS_PER_CHAR)))
+ elt = Qt;
+ else
+ elt = Qnil;
+ }
else
elt = XVECTOR (this)->contents[thisindex++];
}
while (!INTEGERP (elt))
elt = wrong_type_argument (Qintegerp, elt);
{
+ int c = XINT (elt);
+ unsigned char work[4], *str;
+ int i = CHAR_STRING (c, work, str);
+
#ifdef MASSC_REGISTER_BUG
/* Even removing all "register"s doesn't disable this bug!
Nothing simpler than this seems to work. */
- unsigned char *p = & XSTRING (val)->data[toindex++];
- *p = XINT (elt);
+ unsigned char *p = & XSTRING (val)->data[toindex];
+ bcopy (str, p, i);
#else
- XSTRING (val)->data[toindex++] = XINT (elt);
+ bcopy (str, & XSTRING (val)->data[toindex], i);
#endif
+ toindex += i;
}
}
}
DEFUN ("substring", Fsubstring, Ssubstring, 2, 3, 0,
"Return a substring of STRING, starting at index FROM and ending before TO.\n\
TO may be nil or omitted; then the substring runs to the end of STRING.\n\
-If FROM or TO is negative, it counts from the end.")
+If FROM or TO is negative, it counts from the end.\n\
+\n\
+This function allows vectors as well as strings.")
(string, from, to)
Lisp_Object string;
register Lisp_Object from, to;
{
Lisp_Object res;
+ int size;
+
+ if (! (STRINGP (string) || VECTORP (string)))
+ wrong_type_argument (Qarrayp, string);
- CHECK_STRING (string, 0);
CHECK_NUMBER (from, 1);
+
+ if (STRINGP (string))
+ size = XSTRING (string)->size;
+ else
+ size = XVECTOR (string)->size;
+
if (NILP (to))
- to = Flength (string);
+ XSETINT (to, size);
else
CHECK_NUMBER (to, 2);
if (XINT (from) < 0)
- XSETINT (from, XINT (from) + XSTRING (string)->size);
+ XSETINT (from, XINT (from) + size);
if (XINT (to) < 0)
- XSETINT (to, XINT (to) + XSTRING (string)->size);
+ XSETINT (to, XINT (to) + size);
if (!(0 <= XINT (from) && XINT (from) <= XINT (to)
- && XINT (to) <= XSTRING (string)->size))
+ && XINT (to) <= size))
args_out_of_range_3 (string, from, to);
- res = make_string (XSTRING (string)->data + XINT (from),
- XINT (to) - XINT (from));
- copy_text_properties (from, to, string, make_number (0), res, Qnil);
+ if (STRINGP (string))
+ {
+ res = make_string (XSTRING (string)->data + XINT (from),
+ XINT (to) - XINT (from));
+ copy_text_properties (from, to, string, make_number (0), res, Qnil);
+ }
+ else
+ res = Fvector (XINT (to) - XINT (from),
+ XVECTOR (string)->contents + XINT (from));
+
return res;
}
\f
DEFUN ("elt", Felt, Selt, 2, 2, 0,
"Return element of SEQUENCE at index N.")
- (seq, n)
- register Lisp_Object seq, n;
+ (sequence, n)
+ register Lisp_Object sequence, n;
{
CHECK_NUMBER (n, 0);
while (1)
{
- if (CONSP (seq) || NILP (seq))
- return Fcar (Fnthcdr (n, seq));
- else if (STRINGP (seq) || VECTORP (seq))
- return Faref (seq, n);
+ if (CONSP (sequence) || NILP (sequence))
+ return Fcar (Fnthcdr (n, sequence));
+ else if (STRINGP (sequence) || VECTORP (sequence)
+ || BOOL_VECTOR_P (sequence) || CHAR_TABLE_P (sequence))
+ return Faref (sequence, n);
else
- seq = wrong_type_argument (Qsequencep, seq);
+ sequence = wrong_type_argument (Qsequencep, sequence);
}
}
Lisp_Object list;
{
register Lisp_Object tail;
- for (tail = list; !NILP (tail); tail = Fcdr (tail))
+ for (tail = list; !NILP (tail); tail = XCONS (tail)->cdr)
{
register Lisp_Object tem;
tem = Fcar (tail);
Lisp_Object list;
{
register Lisp_Object tail;
- for (tail = list; !NILP (tail); tail = Fcdr (tail))
+ for (tail = list; !NILP (tail); tail = XCONS (tail)->cdr)
{
register Lisp_Object tem;
tem = Fcar (tail);
Lisp_Object list;
{
register Lisp_Object tail;
- for (tail = list; !NILP (tail); tail = Fcdr (tail))
+ for (tail = list; !NILP (tail); tail = XCONS (tail)->cdr)
{
register Lisp_Object elt, tem;
elt = Fcar (tail);
if (!CONSP (elt)) continue;
- tem = Fcar (elt);
+ tem = XCONS (elt)->car;
if (EQ (key, tem)) return elt;
QUIT;
}
Lisp_Object list;
{
register Lisp_Object tail;
- for (tail = list; CONSP (tail); tail = Fcdr (tail))
+ for (tail = list; CONSP (tail); tail = XCONS (tail)->cdr)
{
register Lisp_Object elt, tem;
elt = Fcar (tail);
if (!CONSP (elt)) continue;
- tem = Fcar (elt);
+ tem = XCONS (elt)->car;
if (EQ (key, tem)) return elt;
}
return Qnil;
Lisp_Object list;
{
register Lisp_Object tail;
- for (tail = list; !NILP (tail); tail = Fcdr (tail))
+ for (tail = list; !NILP (tail); tail = XCONS (tail)->cdr)
{
register Lisp_Object elt, tem;
elt = Fcar (tail);
if (!CONSP (elt)) continue;
- tem = Fequal (Fcar (elt), key);
+ tem = Fequal (XCONS (elt)->car, key);
if (!NILP (tem)) return elt;
QUIT;
}
Lisp_Object list;
{
register Lisp_Object tail;
- for (tail = list; !NILP (tail); tail = Fcdr (tail))
+ for (tail = list; !NILP (tail); tail = XCONS (tail)->cdr)
{
register Lisp_Object elt, tem;
elt = Fcar (tail);
if (!CONSP (elt)) continue;
- tem = Fcdr (elt);
+ tem = XCONS (elt)->cdr;
if (EQ (key, tem)) return elt;
QUIT;
}
Lisp_Object list;
{
register Lisp_Object tail;
- for (tail = list; !NILP (tail); tail = Fcdr (tail))
+ for (tail = list; !NILP (tail); tail = XCONS (tail)->cdr)
{
register Lisp_Object elt, tem;
elt = Fcar (tail);
if (!CONSP (elt)) continue;
- tem = Fequal (Fcdr (elt), key);
+ tem = Fequal (XCONS (elt)->cdr, key);
if (!NILP (tem)) return elt;
QUIT;
}
if (EQ (elt, tem))
{
if (NILP (prev))
- list = Fcdr (tail);
+ list = XCONS (tail)->cdr;
else
- Fsetcdr (prev, Fcdr (tail));
+ Fsetcdr (prev, XCONS (tail)->cdr);
}
else
prev = tail;
- tail = Fcdr (tail);
+ tail = XCONS (tail)->cdr;
QUIT;
}
return list;
if (! NILP (Fequal (elt, tem)))
{
if (NILP (prev))
- list = Fcdr (tail);
+ list = XCONS (tail)->cdr;
else
- Fsetcdr (prev, Fcdr (tail));
+ Fsetcdr (prev, XCONS (tail)->cdr);
}
else
prev = tail;
- tail = Fcdr (tail);
+ tail = XCONS (tail)->cdr;
QUIT;
}
return list;
(list)
Lisp_Object list;
{
- Lisp_Object length;
- register Lisp_Object *vec;
- register Lisp_Object tail;
- register int i;
-
- length = Flength (list);
- vec = (Lisp_Object *) alloca (XINT (length) * sizeof (Lisp_Object));
- for (i = XINT (length) - 1, tail = list; i >= 0; i--, tail = Fcdr (tail))
- vec[i] = Fcar (tail);
+ Lisp_Object new;
- return Flist (XINT (length), vec);
+ for (new = Qnil; CONSP (list); list = XCONS (list)->cdr)
+ new = Fcons (XCONS (list)->car, new);
+ if (!NILP (list))
+ wrong_type_argument (Qconsp, list);
+ return new;
}
\f
Lisp_Object merge ();
Returns the sorted list. LIST is modified by side effects.\n\
PREDICATE is called with two elements of LIST, and should return T\n\
if the first element is \"less\" than the second.")
- (list, pred)
- Lisp_Object list, pred;
+ (list, predicate)
+ Lisp_Object list, predicate;
{
Lisp_Object front, back;
register Lisp_Object len, tem;
Fsetcdr (tem, Qnil);
GCPRO2 (front, back);
- front = Fsort (front, pred);
- back = Fsort (back, pred);
+ front = Fsort (front, predicate);
+ back = Fsort (back, predicate);
UNGCPRO;
- return merge (front, back, pred);
+ return merge (front, back, predicate);
}
Lisp_Object
\f
DEFUN ("plist-get", Fplist_get, Splist_get, 2, 2, 0,
- "Extract a value from a property list.\n\
+ "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;
+ (plist, prop)
+ Lisp_Object plist;
register Lisp_Object prop;
{
register Lisp_Object tail;
- for (tail = val; !NILP (tail); tail = Fcdr (Fcdr (tail)))
+ for (tail = plist; !NILP (tail); tail = Fcdr (XCONS (tail)->cdr))
{
register Lisp_Object tem;
tem = Fcar (tail);
if (EQ (prop, tem))
- return Fcar (Fcdr (tail));
+ return Fcar (XCONS (tail)->cdr);
}
return Qnil;
}
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 - 1) / 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;
}
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 0;
}
\f
+extern Lisp_Object Fmake_char_internal ();
+
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 - 1) / 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.")
+ (char_table)
+ Lisp_Object char_table;
+{
+ CHECK_CHAR_TABLE (char_table, 0);
+
+ return XCHAR_TABLE (char_table)->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).")
+ (char_table)
+ Lisp_Object char_table;
+{
+ CHECK_CHAR_TABLE (char_table, 0);
+
+ return XCHAR_TABLE (char_table)->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.")
+ (char_table, parent)
+ Lisp_Object char_table, parent;
+{
+ Lisp_Object temp;
+
+ CHECK_CHAR_TABLE (char_table, 0);
+
+ if (!NILP (parent))
+ {
+ CHECK_CHAR_TABLE (parent, 0);
+
+ for (temp = parent; !NILP (temp); temp = XCHAR_TABLE (temp)->parent)
+ if (EQ (temp, char_table))
+ error ("Attempt to make a chartable be its own parent");
+ }
+
+ XCHAR_TABLE (char_table)->parent = parent;
+
+ return parent;
+}
+
+DEFUN ("char-table-extra-slot", Fchar_table_extra_slot, Schar_table_extra_slot,
+ 2, 2, 0,
+ "Return the value of CHAR-TABLE's extra-slot number N.")
+ (char_table, n)
+ Lisp_Object char_table, n;
+{
+ CHECK_CHAR_TABLE (char_table, 1);
+ CHECK_NUMBER (n, 2);
+ if (XINT (n) < 0
+ || XINT (n) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table)))
+ args_out_of_range (char_table, n);
+
+ return XCHAR_TABLE (char_table)->extras[XINT (n)];
+}
+
+DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot,
+ Sset_char_table_extra_slot,
+ 3, 3, 0,
+ "Set CHAR-TABLE's extra-slot number N to VALUE.")
+ (char_table, n, value)
+ Lisp_Object char_table, n, value;
+{
+ CHECK_CHAR_TABLE (char_table, 1);
+ CHECK_NUMBER (n, 2);
+ if (XINT (n) < 0
+ || XINT (n) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table)))
+ args_out_of_range (char_table, n);
+
+ return XCHAR_TABLE (char_table)->extras[XINT (n)] = value;
+}
+
+DEFUN ("char-table-range", Fchar_table_range, Schar_table_range,
+ 2, 2, 0,
+ "Return the value in CHAR-TABLE 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.")
+ (char_table, range)
+ Lisp_Object char_table, range;
+{
+ int i;
+
+ CHECK_CHAR_TABLE (char_table, 0);
+
+ if (EQ (range, Qnil))
+ return XCHAR_TABLE (char_table)->defalt;
+ else if (INTEGERP (range))
+ return Faref (char_table, range);
+ else if (VECTORP (range))
+ {
+ if (XVECTOR (range)->size == 1)
+ return Faref (char_table, XVECTOR (range)->contents[0]);
+ else
+ {
+ int size = XVECTOR (range)->size;
+ Lisp_Object *val = XVECTOR (range)->contents;
+ Lisp_Object ch = Fmake_char_internal (size <= 0 ? Qnil : val[0],
+ size <= 1 ? Qnil : val[1],
+ size <= 2 ? Qnil : val[2]);
+ return Faref (char_table, ch);
+ }
+ }
+ 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 CHAR-TABLE 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.")
+ (char_table, range, value)
+ Lisp_Object char_table, range, value;
+{
+ int i;
+
+ CHECK_CHAR_TABLE (char_table, 0);
+
+ if (EQ (range, Qt))
+ for (i = 0; i < CHAR_TABLE_ORDINARY_SLOTS; i++)
+ XCHAR_TABLE (char_table)->contents[i] = value;
+ else if (EQ (range, Qnil))
+ XCHAR_TABLE (char_table)->defalt = value;
+ else if (INTEGERP (range))
+ Faset (char_table, range, value);
+ else if (VECTORP (range))
+ {
+ if (XVECTOR (range)->size == 1)
+ return Faset (char_table, XVECTOR (range)->contents[0], value);
+ else
+ {
+ int size = XVECTOR (range)->size;
+ Lisp_Object *val = XVECTOR (range)->contents;
+ Lisp_Object ch = Fmake_char_internal (size <= 0 ? Qnil : val[0],
+ size <= 1 ? Qnil : val[1],
+ size <= 2 ? Qnil : val[2]);
+ return Faset (char_table, ch, value);
+ }
+ }
+ else
+ error ("Invalid RANGE argument to `set-char-table-range'");
+
+ return value;
+}
+
+DEFUN ("set-char-table-default", Fset_char_table_default,
+ Sset_char_table_default, 3, 3, 0,
+ "Set the default value in CHAR-TABLE for a generic character CHAR to VALUE.\n\
+The generic character specifies the group of characters.\n\
+See also the documentation of make-char.")
+ (char_table, ch, value)
+ Lisp_Object char_table, ch, value;
+{
+ int c, i, charset, code1, code2;
+ Lisp_Object temp;
+
+ CHECK_CHAR_TABLE (char_table, 0);
+ CHECK_NUMBER (ch, 1);
+
+ c = XINT (ch);
+ SPLIT_NON_ASCII_CHAR (c, charset, code1, code2);
+ if (! CHARSET_DEFINED_P (charset))
+ error ("Invalid character: %d", c);
+
+ if (charset == CHARSET_ASCII)
+ return (XCHAR_TABLE (char_table)->defalt = value);
+
+ /* Even if C is not a generic char, we had better behave as if a
+ generic char is specified. */
+ if (CHARSET_DIMENSION (charset) == 1)
+ code1 = 0;
+ temp = XCHAR_TABLE (char_table)->contents[charset + 128];
+ if (!code1)
+ {
+ if (SUB_CHAR_TABLE_P (temp))
+ XCHAR_TABLE (temp)->defalt = value;
+ else
+ XCHAR_TABLE (char_table)->contents[charset + 128] = value;
+ return value;
+ }
+ char_table = temp;
+ if (! SUB_CHAR_TABLE_P (char_table))
+ char_table = (XCHAR_TABLE (char_table)->contents[charset + 128]
+ = make_sub_char_table (temp));
+ temp = XCHAR_TABLE (char_table)->contents[code1];
+ if (SUB_CHAR_TABLE_P (temp))
+ XCHAR_TABLE (temp)->defalt = value;
+ else
+ XCHAR_TABLE (char_table)->contents[code1] = value;
+ return value;
+}
+
+\f
+/* Map C_FUNCTION or FUNCTION over SUBTABLE, 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.
+
+ ARG is passed to C_FUNCTION when that is called. */
+
+void
+map_char_table (c_function, function, subtable, arg, depth, indices)
+ Lisp_Object (*c_function) (), function, subtable, arg, *indices;
+ int depth;
+{
+ int i, to;
+
+ if (depth == 0)
+ {
+ /* At first, handle ASCII and 8-bit European characters. */
+ for (i = 0; i < CHAR_TABLE_SINGLE_BYTE_SLOTS; i++)
+ {
+ Lisp_Object elt = XCHAR_TABLE (subtable)->contents[i];
+ if (c_function)
+ (*c_function) (arg, make_number (i), elt);
+ else
+ call2 (function, make_number (i), elt);
+ }
+ to = CHAR_TABLE_ORDINARY_SLOTS;
+ }
+ else
+ {
+ i = 0;
+ to = SUB_CHAR_TABLE_ORDINARY_SLOTS;
+ }
+
+ for (; i < to; i++)
+ {
+ Lisp_Object elt = XCHAR_TABLE (subtable)->contents[i];
+
+ XSETFASTINT (indices[depth], i);
+
+ if (SUB_CHAR_TABLE_P (elt))
+ {
+ if (depth >= 3)
+ error ("Too deep char table");
+ map_char_table (c_function, function, elt, arg, depth + 1, indices);
+ }
+ else
+ {
+ int charset = XFASTINT (indices[0]) - 128, c1, c2, c;
+
+ if (CHARSET_DEFINED_P (charset))
+ {
+ c1 = depth >= 1 ? XFASTINT (indices[1]) : 0;
+ c2 = depth >= 2 ? XFASTINT (indices[2]) : 0;
+ c = MAKE_NON_ASCII_CHAR (charset, c1, c2);
+ if (c_function)
+ (*c_function) (arg, make_number (c), elt);
+ else
+ call2 (function, make_number (c), elt);
+ }
+ }
+ }
+}
+
+DEFUN ("map-char-table", Fmap_char_table, Smap_char_table,
+ 2, 2, 0,
+ "Call FUNCTION for each (normal and generic) characters in CHAR-TABLE.\n\
+FUNCTION is called with two arguments--a key and a value.\n\
+The key is always a possible IDX argument to `aref'.")
+ (function, char_table)
+ Lisp_Object function, char_table;
+{
+ /* The depth of char table is at most 3. */
+ Lisp_Object indices[3];
+
+ CHECK_CHAR_TABLE (char_table, 1);
+
+ map_char_table (NULL, function, char_table, char_table, 0, indices);
+ return Qnil;
+}
+\f
/* ARGSUSED */
Lisp_Object
nconc2 (s1, s2)
for (i = 0; i < leni; i++)
{
vals[i] = call1 (fn, Fcar (tail));
- tail = Fcdr (tail);
+ tail = XCONS (tail)->cdr;
}
}
}
DEFUN ("mapconcat", Fmapconcat, Smapconcat, 3, 3, 0,
- "Apply FN to each element of SEQ, and concat the results as strings.\n\
-In between each pair of results, stick in SEP.\n\
-Thus, \" \" as SEP results in spaces between the values returned by FN.")
- (fn, seq, sep)
- Lisp_Object fn, seq, sep;
+ "Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.\n\
+In between each pair of results, stick in SEPARATOR. Thus, \" \" as\n\
+SEPARATOR results in spaces between the values returned by FUNCTION.")
+ (function, sequence, separator)
+ Lisp_Object function, sequence, separator;
{
Lisp_Object len;
register int leni;
register int i;
struct gcpro gcpro1;
- len = Flength (seq);
+ len = Flength (sequence);
leni = XINT (len);
nargs = leni + leni - 1;
if (nargs < 0) return build_string ("");
args = (Lisp_Object *) alloca (nargs * sizeof (Lisp_Object));
- GCPRO1 (sep);
- mapcar1 (leni, args, fn, seq);
+ GCPRO1 (separator);
+ mapcar1 (leni, args, function, sequence);
UNGCPRO;
for (i = leni - 1; i >= 0; i--)
args[i + i] = args[i];
for (i = 1; i < nargs; i += 2)
- args[i] = sep;
+ args[i] = separator;
return Fconcat (nargs, args);
}
"Apply FUNCTION to each element of SEQUENCE, and make a list of the results.\n\
The result is a list just as long as SEQUENCE.\n\
SEQUENCE may be a list, a vector or a string.")
- (fn, seq)
- Lisp_Object fn, seq;
+ (function, sequence)
+ Lisp_Object function, sequence;
{
register Lisp_Object len;
register int leni;
register Lisp_Object *args;
- len = Flength (seq);
+ len = Flength (sequence);
leni = XFASTINT (len);
args = (Lisp_Object *) alloca (leni * sizeof (Lisp_Object));
- mapcar1 (leni, args, fn, seq);
+ mapcar1 (leni, args, function, sequence);
return Flist (leni, args);
}
register int answer;
Lisp_Object xprompt;
Lisp_Object args[2];
- int ocech = cursor_in_echo_area;
struct gcpro gcpro1, gcpro2;
+ int count = specpdl_ptr - specpdl;
+
+ specbind (Qcursor_in_echo_area, Qt);
map = Fsymbol_value (intern ("query-replace-map"));
while (1)
{
-#ifdef HAVE_X_MENU
+
+
+#ifdef HAVE_MENUS
if ((NILP (last_nonmenu_event) || CONSP (last_nonmenu_event))
- && using_x_p ())
+ && use_dialog_box
+ && have_menus_p ())
{
Lisp_Object pane, menu;
redisplay_preserve_echo_area ();
answer = !NILP (obj);
break;
}
-#endif
+#endif /* HAVE_MENUS */
cursor_in_echo_area = 1;
+ choose_minibuf_frame ();
message_nolog ("%s(y or n) ", XSTRING (xprompt)->data);
+ if (minibuffer_auto_raise)
+ {
+ Lisp_Object mini_frame;
+
+ mini_frame = WINDOW_FRAME (XWINDOW (minibuf_window));
+
+ Fraise_frame (mini_frame);
+ }
+
obj = read_filtered_event (1, 0, 0);
cursor_in_echo_area = 0;
/* If we need to quit, quit with cursor_in_echo_area = 0. */
QUIT;
key = Fmake_vector (make_number (1), obj);
- def = Flookup_key (map, key);
+ def = Flookup_key (map, key, Qt);
answer_string = Fsingle_key_description (obj);
if (EQ (def, intern ("skip")))
cursor_in_echo_area = -1;
message_nolog ("%s(y or n) %c",
XSTRING (xprompt)->data, answer ? 'y' : 'n');
- cursor_in_echo_area = ocech;
}
+ unbind_to (count, Qnil);
return answer ? Qt : Qnil;
}
\f
CHECK_STRING (prompt, 0);
-#ifdef HAVE_X_MENU
- if ((NILP (last_nonmenu_event) || CONSP (last_nonmenu_event))
- && using_x_p ())
+#ifdef HAVE_MENUS
+ if ((NILP (last_nonmenu_event) || CONSP (last_nonmenu_event))
+ && use_dialog_box
+ && have_menus_p ())
{
Lisp_Object pane, menu, obj;
redisplay_preserve_echo_area ();
UNGCPRO;
return obj;
}
-#endif
+#endif /* HAVE_MENUS */
args[0] = prompt;
args[1] = build_string ("(yes or no) ");
while (1)
{
ans = Fdowncase (Fread_from_minibuffer (prompt, Qnil, Qnil, Qnil,
- Qyes_or_no_p_history));
+ Qyes_or_no_p_history, Qnil));
if (XSTRING (ans)->size == 3 && !strcmp (XSTRING (ans)->data, "yes"))
{
UNGCPRO;
Vautoload_queue = Qt;
Fload (NILP (file_name) ? Fsymbol_name (feature) : file_name,
- Qnil, Qt, Qnil);
+ Qnil, Qt, Qnil, Qt);
tem = Fmemq (feature, Vfeatures);
if (NILP (tem))
staticpro (&Qrequire);
Qyes_or_no_p_history = intern ("yes-or-no-p-history");
staticpro (&Qyes_or_no_p_history);
+ Qcursor_in_echo_area = intern ("cursor-in-echo-area");
+ staticpro (&Qcursor_in_echo_area);
+
+ Fset (Qyes_or_no_p_history, Qnil);
DEFVAR_LISP ("features", &Vfeatures,
"A list of symbols which are the features of the executing emacs.\n\
Used by `featurep' and `require', and altered by `provide'.");
Vfeatures = Qnil;
+ DEFVAR_BOOL ("use-dialog-box", &use_dialog_box,
+ "*Non-nil means mouse commands use dialog boxes to ask questions.\n\
+This applies to y-or-n and yes-or-no questions asked by commands\n\
+invoked by mouse clicks and mouse menu items.");
+ use_dialog_box = 1;
+
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 (&Sset_char_table_default);
+ defsubr (&Smap_char_table);
defsubr (&Snconc);
defsubr (&Smapcar);
defsubr (&Smapconcat);