/* Random utility Lisp functions.
- Copyright (C) 1985, 1986, 1987, 1993, 1994, 1995, 1997, 1998, 1999, 2000,
- 2001, 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
+ Copyright (C) 1985, 1986, 1987, 1993, 1994, 1995, 1997,
+ 1998, 1999, 2000, 2001, 2002, 2003, 2004,
+ 2005, 2006 Free Software Foundation, Inc.
This file is part of GNU Emacs.
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, Inc., 59 Temple Place - Suite 330,
-Boston, MA 02111-1307, USA. */
+the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+Boston, MA 02110-1301, USA. */
#include <config.h>
#include "frame.h"
#include "window.h"
#include "blockinput.h"
-#if defined (HAVE_MENUS) && defined (HAVE_X_WINDOWS)
+#ifdef HAVE_MENUS
+#if defined (HAVE_X_WINDOWS)
#include "xterm.h"
+#elif defined (MAC_OS)
+#include "macterm.h"
+#endif
#endif
#ifndef NULL
extern int minibuffer_auto_raise;
extern Lisp_Object minibuf_window;
extern Lisp_Object Vlocale_coding_system;
-extern Lisp_Object Vloads_in_progress;
+extern int load_in_progress;
Lisp_Object Qstring_lessp, Qprovide, Qrequire;
Lisp_Object Qyes_or_no_p_history;
extern Lisp_Object Qinput_method_function;
-static int internal_equal ();
+static int internal_equal P_ ((Lisp_Object , Lisp_Object, int, int));
extern long get_random ();
-extern void seed_random ();
+extern void seed_random P_ ((long));
#ifndef HAVE_UNISTD_H
extern long time ();
All integers representable in Lisp are equally likely.
On most systems, this is 29 bits' worth.
With positive integer argument N, return random number in interval [0,N).
-With argument t, set the random number seed from the current time and pid. */)
+With argument t, set the random number seed from the current time and pid. */)
(n)
Lisp_Object n;
{
A byte-code function object is also allowed.
If the string contains multibyte characters, this is not necessarily
the number of bytes in the string; it is the number of characters.
-To get the number of bytes, use `string-bytes'. */)
+To get the number of bytes, use `string-bytes'. */)
(sequence)
register Lisp_Object sequence;
{
register Lisp_Object val;
register int i;
- retry:
if (STRINGP (sequence))
XSETFASTINT (val, SCHARS (sequence));
else if (VECTORP (sequence))
- XSETFASTINT (val, XVECTOR (sequence)->size);
+ XSETFASTINT (val, ASIZE (sequence));
else if (SUB_CHAR_TABLE_P (sequence))
XSETFASTINT (val, SUB_CHAR_TABLE_ORDINARY_SLOTS);
else if (CHAR_TABLE_P (sequence))
else if (BOOL_VECTOR_P (sequence))
XSETFASTINT (val, XBOOL_VECTOR (sequence)->size);
else if (COMPILEDP (sequence))
- XSETFASTINT (val, XVECTOR (sequence)->size & PSEUDOVECTOR_SIZE_MASK);
+ XSETFASTINT (val, ASIZE (sequence) & PSEUDOVECTOR_SIZE_MASK);
else if (CONSP (sequence))
{
i = 0;
QUIT;
}
- if (!NILP (sequence))
- wrong_type_argument (Qlistp, sequence);
+ CHECK_LIST_END (sequence, sequence);
val = make_number (i);
}
else if (NILP (sequence))
XSETFASTINT (val, 0);
else
- {
- sequence = wrong_type_argument (Qsequencep, sequence);
- goto retry;
- }
+ wrong_type_argument (Qsequencep, sequence);
+
return val;
}
-/* This does not check for quits. That is safe
- since it must terminate. */
+/* This does not check for quits. That is safe since it must terminate. */
DEFUN ("safe-length", Fsafe_length, Ssafe_length, 1, 1, 0,
doc: /* Return the length of a list, but avoid error or infinite loop.
This function never gets an error. If LIST is not really a list,
it returns 0. If LIST is circular, it returns a finite value
-which is at least the number of distinct elements. */)
+which is at least the number of distinct elements. */)
(list)
Lisp_Object list;
{
DEFUN ("string-bytes", Fstring_bytes, Sstring_bytes, 1, 1, 0,
doc: /* Return the number of bytes in STRING.
-If STRING is a multibyte string, this is greater than the length of STRING. */)
+If STRING is a multibyte string, this is greater than the length of STRING. */)
(string)
Lisp_Object string;
{
DEFUN ("string-equal", Fstring_equal, Sstring_equal, 2, 2, 0,
doc: /* Return t if two strings have identical contents.
Case is significant, but text properties are ignored.
-Symbols are also allowed; their print names are used instead. */)
+Symbols are also allowed; their print names are used instead. */)
(s1, s2)
register Lisp_Object s1, s2;
{
If string STR1 is less, the value is a negative number N;
- 1 - N is the number of characters that match at the beginning.
If string STR1 is greater, the value is a positive number N;
- N - 1 is the number of characters that match at the beginning. */)
+ N - 1 is the number of characters that match at the beginning. */)
(str1, start1, end1, str2, start2, end2, ignore_case)
Lisp_Object str1, start1, end1, start2, str2, end2, ignore_case;
{
DEFUN ("string-lessp", Fstring_lessp, Sstring_lessp, 2, 2, 0,
doc: /* Return t if first arg string is less than second in lexicographic order.
Case is significant.
-Symbols are also allowed; their print names are used instead. */)
+Symbols are also allowed; their print names are used instead. */)
(s1, s2)
register Lisp_Object s1, s2;
{
return i1 < SCHARS (s2) ? Qt : Qnil;
}
\f
-static Lisp_Object concat ();
+#if __GNUC__
+/* "gcc -O3" enables automatic function inlining, which optimizes out
+ the arguments for the invocations of this function, whereas it
+ expects these values on the stack. */
+static Lisp_Object concat P_ ((int nargs, Lisp_Object *args, enum Lisp_Type target_type, int last_special)) __attribute__((noinline));
+#else /* !__GNUC__ */
+static Lisp_Object concat P_ ((int nargs, Lisp_Object *args, enum Lisp_Type target_type, int last_special));
+#endif
/* ARGSUSED */
Lisp_Object
copy_sub_char_table (arg)
Lisp_Object arg;
{
- Lisp_Object copy = make_sub_char_table (XCHAR_TABLE (arg)->defalt);
+ Lisp_Object copy = make_sub_char_table (Qnil);
int i;
+ XCHAR_TABLE (copy)->defalt = XCHAR_TABLE (arg)->defalt;
/* Copy all the contents. */
bcopy (XCHAR_TABLE (arg)->contents, XCHAR_TABLE (copy)->contents,
SUB_CHAR_TABLE_ORDINARY_SLOTS * sizeof (Lisp_Object));
DEFUN ("copy-sequence", Fcopy_sequence, Scopy_sequence, 1, 1, 0,
doc: /* Return a copy of a list, vector, string or char-table.
The elements of a list or vector are not copied; they are shared
-with the original. */)
+with the original. */)
(arg)
Lisp_Object arg;
{
}
if (!CONSP (arg) && !VECTORP (arg) && !STRINGP (arg))
- arg = wrong_type_argument (Qsequencep, arg);
+ wrong_type_argument (Qsequencep, arg);
+
return concat (1, &arg, CONSP (arg) ? Lisp_Cons : XTYPE (arg), 0);
}
else
last_tail = Qnil;
- /* Canonicalize each argument. */
+ /* Check each argument. */
for (argnum = 0; argnum < nargs; argnum++)
{
this = args[argnum];
if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
|| COMPILEDP (this) || BOOL_VECTOR_P (this)))
- {
- args[argnum] = wrong_type_argument (Qsequencep, this);
- }
+ wrong_type_argument (Qsequencep, this);
}
/* Compute total length in chars of arguments in RESULT_LEN.
if (VECTORP (this))
for (i = 0; i < len; i++)
{
- ch = XVECTOR (this)->contents[i];
- if (! INTEGERP (ch))
- wrong_type_argument (Qintegerp, ch);
+ ch = AREF (this, i);
+ CHECK_NUMBER (ch);
this_len_byte = CHAR_BYTES (XINT (ch));
result_len_byte += this_len_byte;
if (!SINGLE_BYTE_CHAR_P (XINT (ch)))
for (; CONSP (this); this = XCDR (this))
{
ch = XCAR (this);
- if (! INTEGERP (ch))
- wrong_type_argument (Qintegerp, ch);
+ CHECK_NUMBER (ch);
this_len_byte = CHAR_BYTES (XINT (ch));
result_len_byte += this_len_byte;
if (!SINGLE_BYTE_CHAR_P (XINT (ch)))
thisindex++;
}
else
- elt = XVECTOR (this)->contents[thisindex++];
+ elt = AREF (this, thisindex++);
/* Store this element into the result. */
if (toindex < 0)
tail = XCDR (tail);
}
else if (VECTORP (val))
- XVECTOR (val)->contents[toindex++] = elt;
+ AREF (val, toindex++) = elt;
else
{
CHECK_NUMBER (elt);
Multibyte character codes are converted to unibyte according to
`nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
If the lookup in the translation table fails, this function takes just
-the low 8 bits of each character. */)
+the low 8 bits of each character. */)
(string)
Lisp_Object string;
{
It is similar to (decode-coding-string STRING 'emacs-mule-unix).
If you're not sure, whether to use `string-as-multibyte' or
`string-to-multibyte', use `string-to-multibyte'. Beware:
- (aref (string-as-multibyte "\201") 0) -> 129 (aka ?\201)
- (aref (string-as-multibyte "\300") 0) -> 192 (aka ?\300)
- (aref (string-as-multibyte "\300\201") 0) -> 192 (aka ?\300)
- (aref (string-as-multibyte "\300\201") 1) -> 129 (aka ?\201)
+ (aref (string-as-multibyte "\\201") 0) -> 129 (aka ?\\201)
+ (aref (string-as-multibyte "\\300") 0) -> 192 (aka ?\\300)
+ (aref (string-as-multibyte "\\300\\201") 0) -> 192 (aka ?\\300)
+ (aref (string-as-multibyte "\\300\\201") 1) -> 129 (aka ?\\201)
but
- (aref (string-as-multibyte "\201\300") 0) -> 2240
- (aref (string-as-multibyte "\201\300") 1) -> <error> */)
+ (aref (string-as-multibyte "\\201\\300") 0) -> 2240
+ (aref (string-as-multibyte "\\201\\300") 1) -> <error> */)
(string)
Lisp_Object string;
{
int from_char, to_char;
int from_byte = 0, to_byte = 0;
- if (! (STRINGP (string) || VECTORP (string)))
- wrong_type_argument (Qarrayp, string);
-
+ CHECK_VECTOR_OR_STRING (string);
CHECK_NUMBER (from);
if (STRINGP (string))
size_byte = SBYTES (string);
}
else
- size = XVECTOR (string)->size;
+ size = ASIZE (string);
if (NILP (to))
{
string, make_number (0), res, Qnil);
}
else
- res = Fvector (to_char - from_char,
- XVECTOR (string)->contents + from_char);
+ res = Fvector (to_char - from_char, &AREF (string, from_char));
return res;
}
int size;
int size_byte;
- if (! (STRINGP (string) || VECTORP (string)))
- wrong_type_argument (Qarrayp, string);
+ CHECK_VECTOR_OR_STRING (string);
if (STRINGP (string))
{
size_byte = SBYTES (string);
}
else
- size = XVECTOR (string)->size;
+ size = ASIZE (string);
if (!(0 <= from && from <= to && to <= size))
args_out_of_range_3 (string, make_number (from), make_number (to));
string, make_number (0), res, Qnil);
}
else
- res = Fvector (to - from,
- XVECTOR (string)->contents + from);
+ res = Fvector (to - from, &AREF (string, from));
return res;
}
for (i = 0; i < num && !NILP (list); i++)
{
QUIT;
- if (! CONSP (list))
- wrong_type_argument (Qlistp, list);
+ CHECK_LIST_CONS (list, list);
list = XCDR (list);
}
return list;
register Lisp_Object sequence, n;
{
CHECK_NUMBER (n);
- while (1)
- {
- 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
- sequence = wrong_type_argument (Qsequencep, sequence);
- }
+ if (CONSP (sequence) || NILP (sequence))
+ return Fcar (Fnthcdr (n, sequence));
+
+ /* Faref signals a "not array" error, so check here. */
+ CHECK_ARRAY (sequence, Qsequencep);
+ return Faref (sequence, n);
}
DEFUN ("member", Fmember, Smember, 2, 2, 0,
for (tail = list; !NILP (tail); tail = XCDR (tail))
{
register Lisp_Object tem;
- if (! CONSP (tail))
- wrong_type_argument (Qlistp, list);
+ CHECK_LIST_CONS (tail, list);
tem = XCAR (tail);
if (! NILP (Fequal (elt, tem)))
return tail;
}
DEFUN ("memq", Fmemq, Smemq, 2, 2, 0,
- doc: /* Return non-nil if ELT is an element of LIST.
-Comparison done with EQ. The value is actually the tail of LIST
-whose car is ELT. */)
+doc: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
+The value is actually the tail of LIST whose car is ELT. */)
(elt, list)
- Lisp_Object elt, list;
+ register Lisp_Object elt, list;
{
while (1)
{
QUIT;
}
- if (!CONSP (list) && !NILP (list))
- list = wrong_type_argument (Qlistp, list);
-
+ CHECK_LIST (list);
return list;
}
+DEFUN ("memql", Fmemql, Smemql, 2, 2, 0,
+doc: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
+The value is actually the tail of LIST whose car is ELT. */)
+ (elt, list)
+ register Lisp_Object elt;
+ Lisp_Object list;
+{
+ register Lisp_Object tail;
+
+ if (!FLOATP (elt))
+ return Fmemq (elt, list);
+
+ for (tail = list; !NILP (tail); tail = XCDR (tail))
+ {
+ register Lisp_Object tem;
+ CHECK_LIST_CONS (tail, list);
+ tem = XCAR (tail);
+ if (FLOATP (tem) && internal_equal (elt, tem, 0, 0))
+ return tail;
+ QUIT;
+ }
+ return Qnil;
+}
+
DEFUN ("assq", Fassq, Sassq, 2, 2, 0,
doc: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
The value is actually the first element of LIST whose car is KEY.
(key, list)
Lisp_Object key, list;
{
- Lisp_Object result;
-
while (1)
{
if (!CONSP (list)
QUIT;
}
- if (CONSP (list))
- result = XCAR (list);
- else if (NILP (list))
- result = Qnil;
- else
- result = wrong_type_argument (Qlistp, list);
-
- return result;
+ return CAR (list);
}
/* Like Fassq but never report an error and do not allow quits.
|| !EQ (XCAR (XCAR (list)), key)))
list = XCDR (list);
- return CONSP (list) ? XCAR (list) : Qnil;
+ return CAR_SAFE (list);
}
DEFUN ("assoc", Fassoc, Sassoc, 2, 2, 0,
(key, list)
Lisp_Object key, list;
{
- Lisp_Object result, car;
+ Lisp_Object car;
while (1)
{
QUIT;
}
- if (CONSP (list))
- result = XCAR (list);
- else if (NILP (list))
- result = Qnil;
- else
- result = wrong_type_argument (Qlistp, list);
-
- return result;
+ return CAR (list);
}
DEFUN ("rassq", Frassq, Srassq, 2, 2, 0,
register Lisp_Object key;
Lisp_Object list;
{
- Lisp_Object result;
-
while (1)
{
if (!CONSP (list)
QUIT;
}
- if (NILP (list))
- result = Qnil;
- else if (CONSP (list))
- result = XCAR (list);
- else
- result = wrong_type_argument (Qlistp, list);
-
- return result;
+ return CAR (list);
}
DEFUN ("rassoc", Frassoc, Srassoc, 2, 2, 0,
(key, list)
Lisp_Object key, list;
{
- Lisp_Object result, cdr;
+ Lisp_Object cdr;
while (1)
{
QUIT;
}
- if (CONSP (list))
- result = XCAR (list);
- else if (NILP (list))
- result = Qnil;
- else
- result = wrong_type_argument (Qlistp, list);
-
- return result;
+ return CAR (list);
}
\f
DEFUN ("delq", Fdelq, Sdelq, 2, 2, 0,
prev = Qnil;
while (!NILP (tail))
{
- if (! CONSP (tail))
- wrong_type_argument (Qlistp, list);
+ CHECK_LIST_CONS (tail, list);
tem = XCAR (tail);
if (EQ (elt, tem))
{
for (tail = seq, prev = Qnil; !NILP (tail); tail = XCDR (tail))
{
- if (!CONSP (tail))
- wrong_type_argument (Qlistp, seq);
+ CHECK_LIST_CONS (tail, seq);
if (!NILP (Fequal (elt, XCAR (tail))))
{
while (!NILP (tail))
{
QUIT;
- if (! CONSP (tail))
- wrong_type_argument (Qlistp, list);
+ CHECK_LIST_CONS (tail, list);
next = XCDR (tail);
Fsetcdr (tail, prev);
prev = tail;
QUIT;
new = Fcons (XCAR (list), new);
}
- if (!NILP (list))
- wrong_type_argument (Qconsp, list);
+ CHECK_LIST_END (list, list);
return new;
}
\f
DEFUN ("sort", Fsort, Ssort, 2, 2, 0,
doc: /* Sort LIST, stably, comparing elements using PREDICATE.
Returns the sorted list. LIST is modified by side effects.
-PREDICATE is called with two elements of LIST, and should return t
-if the first element is "less" than the second. */)
+PREDICATE is called with two elements of LIST, and should return non-nil
+if the first element should sort before the second. */)
(list, predicate)
Lisp_Object list, predicate;
{
}
\f
+#if 0 /* Unsafe version. */
DEFUN ("plist-get", Fplist_get, Splist_get, 2, 2, 0,
doc: /* Extract a value from a property list.
PLIST is a property list, which is a list of the form
QUIT;
}
- if (!NILP (tail))
- wrong_type_argument (Qlistp, prop);
+ CHECK_LIST_END (tail, prop);
return Qnil;
}
+#endif
+
+/* This does not check for quits. That is safe since it must terminate. */
-DEFUN ("safe-plist-get", Fsafe_plist_get, Ssafe_plist_get, 2, 2, 0,
+DEFUN ("plist-get", Fplist_get, Splist_get, 2, 2, 0,
doc: /* Extract a value from a property list.
PLIST is a property list, which is a list of the form
\(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
-corresponding to the given PROP, or nil if PROP is not
-one of the properties on the list.
-This function never signals an error. */)
+corresponding to the given PROP, or nil if PROP is not one of the
+properties on the list. This function never signals an error. */)
(plist, prop)
Lisp_Object plist;
Lisp_Object prop;
QUIT;
}
- if (!NILP (tail))
- wrong_type_argument (Qlistp, prop);
+ CHECK_LIST_END (tail, prop);
return Qnil;
}
if (!internal_equal (OVERLAY_START (o1), OVERLAY_START (o2),
depth + 1, props)
|| !internal_equal (OVERLAY_END (o1), OVERLAY_END (o2),
- depth + 1))
+ depth + 1, props))
return 0;
o1 = XOVERLAY (o1)->plist;
o2 = XOVERLAY (o2)->plist;
case Lisp_Vectorlike:
{
register int i;
- EMACS_INT size = XVECTOR (o1)->size;
+ EMACS_INT size = ASIZE (o1);
/* 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)
+ if (ASIZE (o2) != size)
return 0;
/* Boolvectors are compared much like strings. */
if (BOOL_VECTOR_P (o1))
for (i = 0; i < size; i++)
{
Lisp_Object v1, v2;
- v1 = XVECTOR (o1)->contents [i];
- v2 = XVECTOR (o2)->contents [i];
+ v1 = AREF (o1, i);
+ v2 = AREF (o2, i);
if (!internal_equal (v1, v2, depth + 1, props))
return 0;
}
Lisp_Object array, item;
{
register int size, index, charval;
- retry:
if (VECTORP (array))
{
register Lisp_Object *p = XVECTOR (array)->contents;
- size = XVECTOR (array)->size;
+ size = ASIZE (array);
for (index = 0; index < size; index++)
p[index] = item;
}
}
}
else
- {
- array = wrong_type_argument (Qarrayp, array);
- goto retry;
- }
+ wrong_type_argument (Qarrayp, array);
return array;
}
return XCHAR_TABLE (char_table)->extras[XINT (n)] = value;
}
\f
+static Lisp_Object
+char_table_range (table, from, to, defalt)
+ Lisp_Object table;
+ int from, to;
+ Lisp_Object defalt;
+{
+ Lisp_Object val;
+
+ if (! NILP (XCHAR_TABLE (table)->defalt))
+ defalt = XCHAR_TABLE (table)->defalt;
+ val = XCHAR_TABLE (table)->contents[from];
+ if (SUB_CHAR_TABLE_P (val))
+ val = char_table_range (val, 32, 127, defalt);
+ else if (NILP (val))
+ val = defalt;
+ for (from++; from <= to; from++)
+ {
+ Lisp_Object this_val;
+
+ this_val = XCHAR_TABLE (table)->contents[from];
+ if (SUB_CHAR_TABLE_P (this_val))
+ this_val = char_table_range (this_val, 32, 127, defalt);
+ else if (NILP (this_val))
+ this_val = defalt;
+ if (! EQ (val, this_val))
+ error ("Characters in the range have inconsistent values");
+ }
+ return val;
+}
+
+
DEFUN ("char-table-range", Fchar_table_range, Schar_table_range,
2, 2, 0,
doc: /* Return the value in CHAR-TABLE for a range of characters RANGE.
-RANGE should be nil (for the default value)
+RANGE should be nil (for the default value),
a vector which identifies a character set or a row of a character set,
-a character set name, or a character code. */)
+a character set name, or a character code.
+If the characters in the specified range have different values,
+an error is signaled.
+
+Note that this function doesn't check the parent of CHAR-TABLE. */)
(char_table, range)
Lisp_Object char_table, range;
{
+ int charset_id, c1 = 0, c2 = 0;
+ int size;
+ Lisp_Object ch, val, current_default;
+
CHECK_CHAR_TABLE (char_table);
if (EQ (range, Qnil))
return XCHAR_TABLE (char_table)->defalt;
- else if (INTEGERP (range))
- return Faref (char_table, range);
+ if (INTEGERP (range))
+ {
+ int c = XINT (range);
+ if (! CHAR_VALID_P (c, 0))
+ error ("Invalid character code: %d", c);
+ ch = range;
+ SPLIT_CHAR (c, charset_id, c1, c2);
+ }
else if (SYMBOLP (range))
{
Lisp_Object charset_info;
charset_info = Fget (range, Qcharset);
CHECK_VECTOR (charset_info);
-
- return Faref (char_table,
- make_number (XINT (XVECTOR (charset_info)->contents[0])
- + 128));
+ charset_id = XINT (AREF (charset_info, 0));
+ ch = Fmake_char_internal (make_number (charset_id),
+ make_number (0), make_number (0));
}
else if (VECTORP (range))
{
- if (XVECTOR (range)->size == 1)
- return Faref (char_table,
- make_number (XINT (XVECTOR (range)->contents[0]) + 128));
- else
+ size = ASIZE (range);
+ if (size == 0)
+ args_out_of_range (range, make_number (0));
+ CHECK_NUMBER (AREF (range, 0));
+ charset_id = XINT (AREF (range, 0));
+ if (size > 1)
{
- 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);
+ CHECK_NUMBER (AREF (range, 1));
+ c1 = XINT (AREF (range, 1));
+ if (size > 2)
+ {
+ CHECK_NUMBER (AREF (range, 2));
+ c2 = XINT (AREF (range, 2));
+ }
}
+
+ /* This checks if charset_id, c0, and c1 are all valid or not. */
+ ch = Fmake_char_internal (make_number (charset_id),
+ make_number (c1), make_number (c2));
}
else
error ("Invalid RANGE argument to `char-table-range'");
- return Qt;
+
+ if (c1 > 0 && (CHARSET_DIMENSION (charset_id) == 1 || c2 > 0))
+ {
+ /* Fully specified character. */
+ Lisp_Object parent = XCHAR_TABLE (char_table)->parent;
+
+ XCHAR_TABLE (char_table)->parent = Qnil;
+ val = Faref (char_table, ch);
+ XCHAR_TABLE (char_table)->parent = parent;
+ return val;
+ }
+
+ current_default = XCHAR_TABLE (char_table)->defalt;
+ if (charset_id == CHARSET_ASCII
+ || charset_id == CHARSET_8_BIT_CONTROL
+ || charset_id == CHARSET_8_BIT_GRAPHIC)
+ {
+ int from, to, defalt;
+
+ if (charset_id == CHARSET_ASCII)
+ from = 0, to = 127, defalt = CHAR_TABLE_DEFAULT_SLOT_ASCII;
+ else if (charset_id == CHARSET_8_BIT_CONTROL)
+ from = 128, to = 159, defalt = CHAR_TABLE_DEFAULT_SLOT_8_BIT_CONTROL;
+ else
+ from = 160, to = 255, defalt = CHAR_TABLE_DEFAULT_SLOT_8_BIT_GRAPHIC;
+ if (! NILP (XCHAR_TABLE (char_table)->contents[defalt]))
+ current_default = XCHAR_TABLE (char_table)->contents[defalt];
+ return char_table_range (char_table, from, to, current_default);
+ }
+
+ val = XCHAR_TABLE (char_table)->contents[128 + charset_id];
+ if (! SUB_CHAR_TABLE_P (val))
+ return (NILP (val) ? current_default : val);
+ if (! NILP (XCHAR_TABLE (val)->defalt))
+ current_default = XCHAR_TABLE (val)->defalt;
+ if (c1 == 0)
+ return char_table_range (val, 32, 127, current_default);
+ val = XCHAR_TABLE (val)->contents[c1];
+ if (! SUB_CHAR_TABLE_P (val))
+ return (NILP (val) ? current_default : val);
+ if (! NILP (XCHAR_TABLE (val)->defalt))
+ current_default = XCHAR_TABLE (val)->defalt;
+ return char_table_range (val, 32, 127, current_default);
}
DEFUN ("set-char-table-range", Fset_char_table_range, Sset_char_table_range,
if (EQ (range, Qt))
for (i = 0; i < CHAR_TABLE_ORDINARY_SLOTS; i++)
- XCHAR_TABLE (char_table)->contents[i] = value;
+ {
+ /* Don't set these special slots used for default values of
+ ascii, eight-bit-control, and eight-bit-graphic. */
+ if (i != CHAR_TABLE_DEFAULT_SLOT_ASCII
+ && i != CHAR_TABLE_DEFAULT_SLOT_8_BIT_CONTROL
+ && i != CHAR_TABLE_DEFAULT_SLOT_8_BIT_GRAPHIC)
+ XCHAR_TABLE (char_table)->contents[i] = value;
+ }
else if (EQ (range, Qnil))
XCHAR_TABLE (char_table)->defalt = value;
else if (SYMBOLP (range))
Faset (char_table, range, value);
else if (VECTORP (range))
{
- if (XVECTOR (range)->size == 1)
- return Faset (char_table,
- make_number (XINT (XVECTOR (range)->contents[0]) + 128),
- 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);
- }
+ int size = ASIZE (range);
+ 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]);
+ Faset (char_table, ch, value);
}
else
error ("Invalid RANGE argument to `set-char-table-range'");
Sset_char_table_default, 3, 3, 0,
doc: /* Set the default value in CHAR-TABLE for generic character CH to VALUE.
The generic character specifies the group of characters.
+If CH is a normal character, set the default value for a group of
+characters to which CH belongs.
See also the documentation of `make-char'. */)
(char_table, ch, value)
Lisp_Object char_table, ch, value;
if (! CHARSET_VALID_P (charset))
invalid_character (c);
- if (charset == CHARSET_ASCII)
- return (XCHAR_TABLE (char_table)->defalt = value);
+ if (SINGLE_BYTE_CHAR_P (c))
+ {
+ /* We use special slots for the default values of single byte
+ characters. */
+ int default_slot
+ = (c < 0x80 ? CHAR_TABLE_DEFAULT_SLOT_ASCII
+ : c < 0xA0 ? CHAR_TABLE_DEFAULT_SLOT_8_BIT_CONTROL
+ : CHAR_TABLE_DEFAULT_SLOT_8_BIT_GRAPHIC);
+
+ return (XCHAR_TABLE (char_table)->contents[default_slot] = value);
+ }
/* Even if C is not a generic char, we had better behave as if a
generic char is specified. */
if (!CHARSET_DEFINED_P (charset) || CHARSET_DIMENSION (charset) == 1)
code1 = 0;
temp = XCHAR_TABLE (char_table)->contents[charset + 128];
+ if (! SUB_CHAR_TABLE_P (temp))
+ {
+ temp = make_sub_char_table (temp);
+ XCHAR_TABLE (char_table)->contents[charset + 128] = temp;
+ }
if (!code1)
{
- if (SUB_CHAR_TABLE_P (temp))
- XCHAR_TABLE (temp)->defalt = value;
- else
- XCHAR_TABLE (char_table)->contents[charset + 128] = value;
+ XCHAR_TABLE (temp)->defalt = value;
return value;
}
- if (SUB_CHAR_TABLE_P (temp))
- char_table = temp;
- else
- char_table = (XCHAR_TABLE (char_table)->contents[charset + 128]
- = make_sub_char_table (temp));
+ char_table = temp;
temp = XCHAR_TABLE (char_table)->contents[code1];
if (SUB_CHAR_TABLE_P (temp))
XCHAR_TABLE (temp)->defalt = value;
else
from = 32, to = 128;
- if (!SUB_CHAR_TABLE_P (*table))
+ if (!SUB_CHAR_TABLE_P (*table)
+ || ! NILP (XCHAR_TABLE (*table)->defalt))
return;
elt = XCHAR_TABLE (*table)->contents[from++];
for (; from < to; from++)
Lisp_Object table;
{
Lisp_Object elt;
- int dim;
+ int dim, chars;
int i, j;
CHECK_CHAR_TABLE (table);
if (!SUB_CHAR_TABLE_P (elt))
continue;
dim = CHARSET_DIMENSION (i - 128);
+ chars = CHARSET_CHARS (i - 128);
if (dim == 2)
for (j = 32; j < SUB_CHAR_TABLE_ORDINARY_SLOTS; j++)
- optimize_sub_char_table (XCHAR_TABLE (elt)->contents + j, dim);
- optimize_sub_char_table (XCHAR_TABLE (table)->contents + i, dim);
+ optimize_sub_char_table (XCHAR_TABLE (elt)->contents + j, chars);
+ optimize_sub_char_table (XCHAR_TABLE (table)->contents + i, chars);
}
return Qnil;
}
if (argnum + 1 == nargs) break;
- if (!CONSP (tem))
- tem = wrong_type_argument (Qlistp, tem);
+ CHECK_LIST_CONS (tem, tem);
while (CONSP (tem))
{
else
GCPRO2 (fn, seq);
/* We need not explicitly protect `tail' because it is used only on lists, and
- 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
+ 1) lists are not relocated and 2) the list is marked via `seq' so will not
+ be freed */
if (VECTORP (seq))
{
for (i = 0; i < leni; i++)
{
- dummy = XVECTOR (seq)->contents[i];
- dummy = call1 (fn, dummy);
+ dummy = call1 (fn, AREF (seq, i));
if (vals)
vals[i] = dummy;
}
{
int byte;
byte = XBOOL_VECTOR (seq)->data[i / BOOL_VECTOR_BITS_PER_CHAR];
- if (byte & (1 << (i % BOOL_VECTOR_BITS_PER_CHAR)))
- dummy = Qt;
- else
- dummy = Qnil;
-
+ dummy = (byte & (1 << (i % BOOL_VECTOR_BITS_PER_CHAR))) ? Qt : Qnil;
dummy = call1 (fn, dummy);
if (vals)
vals[i] = dummy;
else /* Must be a list, since Flength did not get an error */
{
tail = seq;
- for (i = 0; i < leni; i++)
+ for (i = 0; i < leni && CONSP (tail); i++)
{
- dummy = call1 (fn, Fcar (tail));
+ dummy = call1 (fn, XCAR (tail));
if (vals)
vals[i] = dummy;
tail = XCDR (tail);
mapcar1 (leni, args, function, sequence);
UNGCPRO;
- for (i = leni - 1; i >= 0; i--)
+ for (i = leni - 1; i > 0; i--)
args[i + i] = args[i];
for (i = 1; i < nargs; i += 2)
Fcons (Fcons (build_string ("No"), Qnil),
Qnil));
menu = Fcons (prompt, pane);
- obj = Fx_popup_dialog (Qt, menu);
+ obj = Fx_popup_dialog (Qt, menu, Qnil);
answer = !NILP (obj);
break;
}
Fraise_frame (mini_frame);
}
- obj = read_filtered_event (1, 0, 0, 0);
+ obj = read_filtered_event (1, 0, 0, 0, Qnil);
cursor_in_echo_area = 0;
/* If we need to quit, quit with cursor_in_echo_area = 0. */
QUIT;
Qnil));
GCPRO1 (pane);
menu = Fcons (prompt, pane);
- obj = Fx_popup_dialog (Qt, menu);
+ obj = Fx_popup_dialog (Qt, menu, Qnil);
UNGCPRO;
return obj;
}
{
ans = Fdowncase (Fread_from_minibuffer (prompt, Qnil, Qnil, Qnil,
Qyes_or_no_p_history, Qnil,
- Qnil, Qnil));
+ Qnil));
if (SCHARS (ans) == 3 && !strcmp (SDATA (ans), "yes"))
{
UNGCPRO;
doc: /* Returns t if FEATURE is present in this Emacs.
Use this to conditionalize execution of lisp code based on the
-presence or absence of emacs or environment extensions.
+presence or absence of Emacs or environment extensions.
Use `provide' to declare that a feature is available. This function
looks at the value of the variable `features'. The optional argument
SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
CHECK_SYMBOL (feature);
CHECK_LIST (subfeatures);
if (!NILP (Vautoload_queue))
- Vautoload_queue = Fcons (Fcons (Vfeatures, Qnil), Vautoload_queue);
+ Vautoload_queue = Fcons (Fcons (make_number (0), Vfeatures),
+ Vautoload_queue);
tem = Fmemq (feature, Vfeatures);
if (NILP (tem))
Vfeatures = Fcons (feature, Vfeatures);
{
register Lisp_Object tem;
struct gcpro gcpro1, gcpro2;
+ int from_file = load_in_progress;
CHECK_SYMBOL (feature);
/* Record the presence of `require' in this file
even if the feature specified is already loaded.
But not more than once in any file,
- and not when we aren't loading a file. */
- if (! NILP (Vloads_in_progress))
+ and not when we aren't loading or reading from a file. */
+ if (!from_file)
+ for (tem = Vcurrent_load_list; CONSP (tem); tem = XCDR (tem))
+ if (NILP (XCDR (tem)) && STRINGP (XCAR (tem)))
+ from_file = 1;
+
+ if (from_file)
{
tem = Fcons (Qrequire, feature);
if (NILP (Fmember (tem, Vcurrent_load_list)))
int i, old_size;
xassert (VECTORP (vec));
- old_size = XVECTOR (vec)->size;
+ old_size = ASIZE (vec);
xassert (new_size >= old_size);
v = allocate_vector (new_size);
args[1] = key;
hash = Ffuncall (2, args);
if (!INTEGERP (hash))
- Fsignal (Qerror,
- list2 (build_string ("Invalid hash code returned from \
-user-supplied hash function"),
- hash));
+ signal_error ("Invalid hash code returned from user-supplied hash function", hash);
return XUINT (hash);
}
if (!NILP (HASH_HASH (h, i)))
{
unsigned hash_code = XUINT (HASH_HASH (h, i));
- int start_of_bucket = hash_code % XVECTOR (h->index)->size;
+ int start_of_bucket = hash_code % ASIZE (h->index);
HASH_NEXT (h, i) = HASH_INDEX (h, start_of_bucket);
HASH_INDEX (h, start_of_bucket) = make_number (i);
}
if (hash)
*hash = hash_code;
- start_of_bucket = hash_code % XVECTOR (h->index)->size;
+ start_of_bucket = hash_code % ASIZE (h->index);
idx = HASH_INDEX (h, start_of_bucket);
/* We need not gcpro idx since it's either an integer or nil. */
HASH_HASH (h, i) = make_number (hash);
/* Add new entry to its collision chain. */
- start_of_bucket = hash % XVECTOR (h->index)->size;
+ start_of_bucket = hash % ASIZE (h->index);
HASH_NEXT (h, i) = HASH_INDEX (h, start_of_bucket);
HASH_INDEX (h, start_of_bucket) = make_number (i);
return i;
Lisp_Object idx, prev;
hash_code = h->hashfn (h, key);
- start_of_bucket = hash_code % XVECTOR (h->index)->size;
+ start_of_bucket = hash_code % ASIZE (h->index);
idx = HASH_INDEX (h, start_of_bucket);
prev = Qnil;
HASH_HASH (h, i) = Qnil;
}
- for (i = 0; i < XVECTOR (h->index)->size; ++i)
- XVECTOR (h->index)->contents[i] = Qnil;
+ for (i = 0; i < ASIZE (h->index); ++i)
+ AREF (h->index, i) = Qnil;
h->next_free = make_number (0);
h->count = make_number (0);
{
int bucket, n, marked;
- n = XVECTOR (h->index)->size & ~ARRAY_MARK_FLAG;
+ n = ASIZE (h->index) & ~ARRAY_MARK_FLAG;
marked = 0;
for (bucket = 0; bucket < n; ++bucket)
c = *p++;
if (c >= 0140)
c -= 40;
- hash = ((hash << 3) + (hash >> 28) + c);
+ hash = ((hash << 4) + (hash >> 28) + c);
}
return hash & INTMASK;
hash = SXHASH_COMBINE (hash, hash2);
}
+ if (!NILP (list))
+ {
+ unsigned hash2 = sxhash (list, depth + 1);
+ hash = SXHASH_COMBINE (hash, hash2);
+ }
+
return hash;
}
Lisp_Object vec;
int depth;
{
- unsigned hash = XVECTOR (vec)->size;
+ unsigned hash = ASIZE (vec);
int i, n;
- n = min (SXHASH_MAX_LEN, XVECTOR (vec)->size);
+ n = min (SXHASH_MAX_LEN, ASIZE (vec));
for (i = 0; i < n; ++i)
{
- unsigned hash2 = sxhash (XVECTOR (vec)->contents[i], depth + 1);
+ unsigned hash2 = sxhash (AREF (vec, i), depth + 1);
hash = SXHASH_COMBINE (hash, hash2);
}
prop = Fget (test, Qhash_table_test);
if (!CONSP (prop) || !CONSP (XCDR (prop)))
- Fsignal (Qerror, list2 (build_string ("Invalid hash table test"),
- test));
+ signal_error ("Invalid hash table test", test);
user_test = XCAR (prop);
user_hash = XCAR (XCDR (prop));
}
if (NILP (size))
size = make_number (DEFAULT_HASH_SIZE);
else if (!INTEGERP (size) || XINT (size) < 0)
- Fsignal (Qerror,
- list2 (build_string ("Invalid hash table size"),
- size));
+ signal_error ("Invalid hash table size", size);
/* Look for `:rehash-size SIZE'. */
i = get_key_arg (QCrehash_size, nargs, args, used);
if (!NUMBERP (rehash_size)
|| (INTEGERP (rehash_size) && XINT (rehash_size) <= 0)
|| XFLOATINT (rehash_size) <= 1.0)
- Fsignal (Qerror,
- list2 (build_string ("Invalid hash table rehash size"),
- rehash_size));
+ signal_error ("Invalid hash table rehash size", rehash_size);
/* Look for `:rehash-threshold THRESHOLD'. */
i = get_key_arg (QCrehash_threshold, nargs, args, used);
if (!FLOATP (rehash_threshold)
|| XFLOATINT (rehash_threshold) <= 0.0
|| XFLOATINT (rehash_threshold) > 1.0)
- Fsignal (Qerror,
- list2 (build_string ("Invalid hash table rehash threshold"),
- rehash_threshold));
+ signal_error ("Invalid hash table rehash threshold", rehash_threshold);
/* Look for `:weakness WEAK'. */
i = get_key_arg (QCweakness, nargs, args, used);
&& !EQ (weak, Qvalue)
&& !EQ (weak, Qkey_or_value)
&& !EQ (weak, Qkey_and_value))
- Fsignal (Qerror, list2 (build_string ("Invalid hash table weakness"),
- weak));
+ signal_error ("Invalid hash table weakness", weak);
/* Now, all args should have been used up, or there's a problem. */
for (i = 0; i < nargs; ++i)
if (!used[i])
- Fsignal (Qerror,
- list2 (build_string ("Invalid argument list"), args[i]));
+ signal_error ("Invalid argument list", args[i]);
return make_hash_table (test, size, rehash_size, rehash_threshold, weak,
user_test, user_hash);
DEFUN ("maphash", Fmaphash, Smaphash, 2, 2, 0,
doc: /* Call FUNCTION for all entries in hash table TABLE.
-FUNCTION is called with 2 arguments KEY and VALUE. */)
+FUNCTION is called with two arguments, KEY and VALUE. */)
(function, table)
Lisp_Object function, table;
{
if (!NILP (noerror))
coding_system = Qraw_text;
else
- while (1)
- Fsignal (Qcoding_system_error, Fcons (coding_system, Qnil));
+ xsignal1 (Qcoding_system_error, coding_system);
}
if (STRING_MULTIBYTE (object))
if (!NILP (noerror))
coding_system = Qraw_text;
else
- while (1)
- Fsignal (Qcoding_system_error, Fcons (coding_system, Qnil));
+ xsignal1 (Qcoding_system_error, coding_system);
}
}
Fset (Qyes_or_no_p_history, Qnil);
DEFVAR_LISP ("features", &Vfeatures,
- doc: /* A list of symbols which are the features of the executing emacs.
+ doc: /* A list of symbols which are the features of the executing Emacs.
Used by `featurep' and `require', and altered by `provide'. */);
- Vfeatures = Qnil;
+ Vfeatures = Fcons (intern ("emacs"), Qnil);
Qsubfeatures = intern ("subfeatures");
staticpro (&Qsubfeatures);
defsubr (&Selt);
defsubr (&Smember);
defsubr (&Smemq);
+ defsubr (&Smemql);
defsubr (&Sassq);
defsubr (&Sassoc);
defsubr (&Srassq);
defsubr (&Sreverse);
defsubr (&Ssort);
defsubr (&Splist_get);
- defsubr (&Ssafe_plist_get);
defsubr (&Sget);
defsubr (&Splist_put);
defsubr (&Sput);
HCoop / bpt / emacs.git / blobdiff