#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;
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\
if (CHAR_TABLE_P (arg))
{
- int i, size;
+ int i;
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]))
+ 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]
- = Fcopy_sequence (XCHAR_TABLE (copy)->contents[i]);
+ = copy_sub_char_table (XCHAR_TABLE (copy)->contents[i]);
return copy;
}
{
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);
`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;
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;
}
}
}
size = XVECTOR (string)->size;
if (NILP (to))
- to = size;
+ XSETINT (to, size);
else
CHECK_NUMBER (to, 2);
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 ();
register Lisp_Object prop;
{
register Lisp_Object tail;
- for (tail = plist; !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;
}
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.\n\
ARRAY is a vector, string, char-table, or bool-vector.")
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.")
+ "Return the value of CHAR-TABLE's extra-slot number N.")
(char_table, n)
Lisp_Object char_table, 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.")
+ "Set CHAR-TABLE's extra-slot number N to VALUE.")
(char_table, n, value)
Lisp_Object char_table, n, value;
{
return Faref (char_table, range);
else if (VECTORP (range))
{
- for (i = 0; i < XVECTOR (range)->size - 1; i++)
- char_table = Faref (char_table, XVECTOR (range)->contents[i]);
-
- if (EQ (XVECTOR (range)->contents[i], Qnil))
- return XCHAR_TABLE (char_table)->defalt;
+ if (XVECTOR (range)->size == 1)
+ return Faref (char_table, XVECTOR (range)->contents[0]);
else
- return Faref (char_table, XVECTOR (range)->contents[i]);
+ {
+ 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'");
Faset (char_table, range, value);
else if (VECTORP (range))
{
- for (i = 0; i < XVECTOR (range)->size - 1; i++)
+ if (XVECTOR (range)->size == 1)
+ return Faset (char_table, XVECTOR (range)->contents[0], value);
+ else
{
- Lisp_Object tmp = Faref (char_table, XVECTOR (range)->contents[i]);
- if (NILP (tmp))
- {
- /* Make this char-table deeper. */
- XVECTOR (char_table)->contents[XVECTOR (range)->contents[i]]
- = tmp = Fmake_char_table (Qnil, Qnil);
- }
- char_table = tmp;
+ 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);
}
-
- if (EQ (XVECTOR (range)->contents[i], Qnil))
- XCHAR_TABLE (char_table)->defalt = value;
- else
- Faset (char_table, XVECTOR (range)->contents[i], 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 CHARTABLE, calling it for each
+/* 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. */
+ for the levels our callers have descended.
+
+ ARG is passed to C_FUNCTION when that is called. */
void
-map_char_table (c_function, function, chartable, depth, indices)
- Lisp_Object (*c_function) (), function, chartable, *indices;
+map_char_table (c_function, function, subtable, arg, depth, indices)
+ Lisp_Object (*c_function) (), function, subtable, arg, *indices;
int depth;
{
- int i;
- int from, to;
+ int i, to;
if (depth == 0)
- from = 0, to = CHAR_TABLE_ORDINARY_SLOTS;
+ {
+ /* 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
- from = 32, to = 128;
- /* 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;
+ i = 0;
+ to = SUB_CHAR_TABLE_ORDINARY_SLOTS;
}
- for (i = from; i < to; i++)
+ for (; i < to; i++)
{
- Lisp_Object elt;
- indices[depth] = i;
- elt = XCHAR_TABLE (chartable)->contents[i];
- if (CHAR_TABLE_P (elt))
- map_char_table (c_function, function, elt, depth + 1, indices);
- else if (c_function)
- (*c_function) (depth + 1, indices, elt);
- else if (depth == 0 && i < 256)
- /* This is an ASCII or 8-bit European character. */
- call2 (function, make_number (i), elt);
+ 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
{
- /* This is an entry for multibyte characters. */
- unsigned int charset = XFASTINT (indices[0]) - 128, c1, c2, c;
+ int charset = XFASTINT (indices[0]) - 128, c1, c2, c;
+
if (CHARSET_DEFINED_P (charset))
{
- c1 = depth < 1 ? 0 : XFASTINT (indices[1]);
- c2 = depth < 2 ? 0 : XFASTINT (indices[2]);
+ c1 = depth >= 1 ? XFASTINT (indices[1]) : 0;
+ c2 = depth >= 2 ? XFASTINT (indices[2]) : 0;
c = MAKE_NON_ASCII_CHAR (charset, c1, c2);
- call2 (function, make_number (c), elt);
+ 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 range of like characters in CHAR-TABLE.\n\
+ "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 RANGE argument to `set-char-table-range'.")
+The key is always a possible IDX argument to `aref'.")
(function, char_table)
Lisp_Object function, char_table;
{
- Lisp_Object keyvec;
- Lisp_Object *indices = (Lisp_Object *) alloca (10 * sizeof (Lisp_Object));
+ /* The depth of char table is at most 3. */
+ Lisp_Object indices[3];
- map_char_table (NULL, function, char_table, 0, indices);
+ CHECK_CHAR_TABLE (char_table, 1);
+
+ map_char_table (NULL, function, char_table, char_table, 0, indices);
return Qnil;
}
\f
for (i = 0; i < leni; i++)
{
vals[i] = call1 (fn, Fcar (tail));
- tail = Fcdr (tail);
+ tail = XCONS (tail)->cdr;
}
}
#ifdef HAVE_MENUS
if ((NILP (last_nonmenu_event) || CONSP (last_nonmenu_event))
+ && use_dialog_box
&& have_menus_p ())
{
Lisp_Object pane, menu;
#ifdef HAVE_MENUS
if ((NILP (last_nonmenu_event) || CONSP (last_nonmenu_event))
+ && use_dialog_box
&& have_menus_p ())
{
Lisp_Object pane, menu, obj;
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))
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 (&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);