X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/ec26e1b924b5c039cf944593acf9bff7405879b8..a03f91ada2cec963ec3e73e81dbc8fbd4e8e0cc9:/src/fns.c diff --git a/src/fns.c b/src/fns.c index fbed621b27..7474fc3b38 100644 --- a/src/fns.c +++ b/src/fns.c @@ -1,11 +1,11 @@ /* Random utility Lisp functions. - Copyright (C) 1985, 1986, 1987, 1993 Free Software Foundation, Inc. + Copyright (C) 1985, 86, 87, 93, 94, 95 Free Software Foundation, Inc. This file is part of GNU Emacs. GNU Emacs is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 1, or (at your option) +the Free Software Foundation; either version 2, or (at your option) any later version. GNU Emacs is distributed in the hope that it will be useful, @@ -32,10 +32,16 @@ the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #include "keyboard.h" #include "intervals.h" +#ifndef NULL +#define NULL (void *)0 +#endif + +extern Lisp_Object Flookup_key (); + Lisp_Object Qstring_lessp, Qprovide, Qrequire; Lisp_Object Qyes_or_no_p_history; -static Lisp_Object internal_equal (); +static int internal_equal (); DEFUN ("identity", Fidentity, Sidentity, 1, 1, 0, "Return the argument unchanged.") @@ -45,24 +51,26 @@ DEFUN ("identity", Fidentity, Sidentity, 1, 1, 0, return arg; } +extern long get_random (); +extern void seed_random (); +extern long time (); + DEFUN ("random", Frandom, Srandom, 0, 1, 0, "Return a pseudo-random number.\n\ -On most systems all integers representable in Lisp are equally likely.\n\ - This is 24 bits' worth.\n\ -With argument N, return random number in interval [0,N).\n\ +All integers representable in Lisp are equally likely.\n\ + On most systems, this is 28 bits' worth.\n\ +With positive integer argument N, return random number in interval [0,N).\n\ With argument t, set the random number seed from the current time and pid.") (limit) Lisp_Object limit; { - int val; + EMACS_INT val; + Lisp_Object lispy_val; unsigned long denominator; - extern long random (); - extern srandom (); - extern long time (); if (EQ (limit, Qt)) - srandom (getpid () + time (0)); - if (XTYPE (limit) == Lisp_Int && XINT (limit) > 0) + seed_random (getpid () + time (NULL)); + if (NATNUMP (limit) && XFASTINT (limit) != 0) { /* Try to take our random number from the higher bits of VAL, not the lower, since (says Gentzel) the low bits of `random' @@ -71,14 +79,15 @@ With argument t, set the random number seed from the current time and pid.") it's possible to get a quotient larger than limit; discarding these values eliminates the bias that would otherwise appear when using a large limit. */ - denominator = (unsigned long)0x80000000 / XFASTINT (limit); + denominator = ((unsigned long)1 << VALBITS) / XFASTINT (limit); do - val = (random () & 0x7fffffff) / denominator; - while (val >= limit); + val = get_random () / denominator; + while (val >= XFASTINT (limit)); } else - val = random (); - return make_number (val); + val = get_random (); + XSETINT (lispy_val, val); + return lispy_val; } /* Random data-structure functions */ @@ -93,43 +102,76 @@ A byte-code function object is also allowed.") register int i; retry: - if (XTYPE (obj) == Lisp_Vector || XTYPE (obj) == Lisp_String - || XTYPE (obj) == Lisp_Compiled) - return Farray_length (obj); + if (STRINGP (obj)) + XSETFASTINT (val, XSTRING (obj)->size); + else if (VECTORP (obj)) + XSETFASTINT (val, XVECTOR (obj)->size); + else if (CHAR_TABLE_P (obj)) + XSETFASTINT (val, CHAR_TABLE_ORDINARY_SLOTS); + else if (BOOL_VECTOR_P (obj)) + XSETFASTINT (val, XBOOL_VECTOR (obj)->size); + else if (COMPILEDP (obj)) + XSETFASTINT (val, XVECTOR (obj)->size & PSEUDOVECTOR_SIZE_MASK); else if (CONSP (obj)) { - for (i = 0, tail = obj; !NILP(tail); i++) + for (i = 0, tail = obj; !NILP (tail); i++) { QUIT; tail = Fcdr (tail); } - XFASTINT (val) = i; - return val; - } - else if (NILP(obj)) - { - XFASTINT (val) = 0; - return val; + XSETFASTINT (val, i); } + else if (NILP (obj)) + XSETFASTINT (val, 0); else { obj = wrong_type_argument (Qsequencep, obj); goto retry; } + return val; +} + +/* This does not check for quits. That is safe + since it must terminate. */ + +DEFUN ("safe-length", Fsafe_length, Ssafe_length, 1, 1, 0, + "Return the length of a list, but avoid error or infinite loop.\n\ +This function never gets an error. If LIST is not really a list,\n\ +it returns 0. If LIST is circular, it returns a finite value\n\ +which is at least the number of distinct elements.") + (list) + Lisp_Object list; +{ + Lisp_Object tail, halftail, length; + int len = 0; + + /* halftail is used to detect circular lists. */ + halftail = list; + for (tail = list; CONSP (tail); tail = XCONS (tail)->cdr) + { + if (EQ (tail, halftail) && len != 0) + break; + len++; + if ((len & 1) == 0) + halftail = XCONS (halftail)->cdr; + } + + XSETINT (length, len); + return length; } DEFUN ("string-equal", Fstring_equal, Sstring_equal, 2, 2, 0, "T if two strings have identical contents.\n\ -Case is significant.\n\ +Case is significant, but text properties are ignored.\n\ Symbols are also allowed; their print names are used instead.") (s1, s2) register Lisp_Object s1, s2; { - if (XTYPE (s1) == Lisp_Symbol) - XSETSTRING (s1, XSYMBOL (s1)->name), XSETTYPE (s1, Lisp_String); - if (XTYPE (s2) == Lisp_Symbol) - XSETSTRING (s2, XSYMBOL (s2)->name), XSETTYPE (s2, Lisp_String); + if (SYMBOLP (s1)) + XSETSTRING (s1, XSYMBOL (s1)->name); + if (SYMBOLP (s2)) + XSETSTRING (s2, XSYMBOL (s2)->name); CHECK_STRING (s1, 0); CHECK_STRING (s2, 1); @@ -150,10 +192,10 @@ Symbols are also allowed; their print names are used instead.") register unsigned char *p1, *p2; register int end; - if (XTYPE (s1) == Lisp_Symbol) - XSETSTRING (s1, XSYMBOL (s1)->name), XSETTYPE (s1, Lisp_String); - if (XTYPE (s2) == Lisp_Symbol) - XSETSTRING (s2, XSYMBOL (s2)->name), XSETTYPE (s2, Lisp_String); + if (SYMBOLP (s1)) + XSETSTRING (s1, XSYMBOL (s1)->name); + if (SYMBOLP (s2)) + XSETSTRING (s2, XSYMBOL (s2)->name); CHECK_STRING (s1, 0); CHECK_STRING (s2, 1); @@ -188,6 +230,22 @@ concat2 (s1, s2) #endif /* NO_ARG_ARRAY */ } +/* ARGSUSED */ +Lisp_Object +concat3 (s1, s2, s3) + Lisp_Object s1, s2, s3; +{ +#ifdef NO_ARG_ARRAY + Lisp_Object args[3]; + args[0] = s1; + args[1] = s2; + args[2] = s3; + return concat (3, args, Lisp_String, 0); +#else + return concat (3, &s1, Lisp_String, 0); +#endif /* NO_ARG_ARRAY */ +} + DEFUN ("append", Fappend, Sappend, 0, MANY, 0, "Concatenate all the arguments and make the result a list.\n\ The result is a list whose elements are the elements of all the arguments.\n\ @@ -203,8 +261,12 @@ The last argument is not copied, just used as the tail of the new list.") DEFUN ("concat", Fconcat, Sconcat, 0, MANY, 0, "Concatenate all the arguments and make the result a string.\n\ The result is a string whose elements are the elements of all the arguments.\n\ -Each argument may be a string, a list of characters (integers),\n\ -or a vector of characters (integers).") +Each argument may be a string or a list or vector of characters (integers).\n\ +\n\ +Do not use individual integers as arguments!\n\ +The behavior of `concat' in that case will be changed later!\n\ +If your program passes an integer as an argument to `concat',\n\ +you should change it right away not to do so.") (nargs, args) int nargs; Lisp_Object *args; @@ -220,7 +282,7 @@ Each argument may be a list, vector or string.") int nargs; Lisp_Object *args; { - return concat (nargs, args, Lisp_Vector, 0); + return concat (nargs, args, Lisp_Vectorlike, 0); } DEFUN ("copy-sequence", Fcopy_sequence, Scopy_sequence, 1, 1, 0, @@ -231,7 +293,41 @@ with the original.") Lisp_Object arg; { if (NILP (arg)) return arg; - if (!CONSP (arg) && XTYPE (arg) != Lisp_Vector && XTYPE (arg) != Lisp_String) + + 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); } @@ -265,11 +361,10 @@ concat (nargs, args, target_type, last_special) for (argnum = 0; argnum < nargs; argnum++) { this = args[argnum]; - if (!(CONSP (this) || NILP (this) - || XTYPE (this) == Lisp_Vector || XTYPE (this) == Lisp_String - || XTYPE (this) == Lisp_Compiled)) + if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this) + || COMPILEDP (this) || BOOL_VECTOR_P (this))) { - if (XTYPE (this) == Lisp_Int) + if (INTEGERP (this)) args[argnum] = Fnumber_to_string (this); else args[argnum] = wrong_type_argument (Qsequencep, this); @@ -283,11 +378,11 @@ concat (nargs, args, target_type, last_special) leni += XFASTINT (len); } - XFASTINT (len) = leni; + XSETFASTINT (len, leni); if (target_type == Lisp_Cons) val = Fmake_list (len, Qnil); - else if (target_type == Lisp_Vector) + else if (target_type == Lisp_Vectorlike) val = Fmake_vector (len, Qnil); else val = Fmake_string (len, len); @@ -313,7 +408,7 @@ concat (nargs, args, target_type, last_special) if (!CONSP (this)) thislen = Flength (this), thisleni = XINT (thislen); - if (XTYPE (this) == Lisp_String && XTYPE (val) == Lisp_String + if (STRINGP (this) && STRINGP (val) && ! NULL_INTERVAL_P (XSTRING (this)->intervals)) { copy_text_properties (make_number (0), thislen, this, @@ -332,8 +427,20 @@ concat (nargs, args, target_type, last_special) else { if (thisindex >= thisleni) break; - if (XTYPE (this) == Lisp_String) - XFASTINT (elt) = XSTRING (this)->data[thisindex++]; + 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++]; } @@ -345,11 +452,11 @@ concat (nargs, args, target_type, last_special) prev = tail; tail = XCONS (tail)->cdr; } - else if (XTYPE (val) == Lisp_Vector) + else if (VECTORP (val)) XVECTOR (val)->contents[toindex++] = elt; else { - while (XTYPE (elt) != Lisp_Int) + while (!INTEGERP (elt)) elt = wrong_type_argument (Qintegerp, elt); { #ifdef MASSC_REGISTER_BUG @@ -462,10 +569,10 @@ DEFUN ("elt", Felt, Selt, 2, 2, 0, CHECK_NUMBER (n, 0); while (1) { - if (XTYPE (seq) == Lisp_Cons || NILP (seq)) + if (CONSP (seq) || NILP (seq)) return Fcar (Fnthcdr (n, seq)); - else if (XTYPE (seq) == Lisp_String - || XTYPE (seq) == Lisp_Vector) + 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); @@ -473,7 +580,7 @@ DEFUN ("elt", Felt, Selt, 2, 2, 0, } DEFUN ("member", Fmember, Smember, 2, 2, 0, - "Return non-nil if ELT is an element of LIST. Comparison done with EQUAL.\n\ + "Return non-nil if ELT is an element of LIST. Comparison done with `equal'.\n\ The value is actually the tail of LIST whose car is ELT.") (elt, list) register Lisp_Object elt; @@ -552,7 +659,7 @@ assq_no_quit (key, list) DEFUN ("assoc", Fassoc, Sassoc, 2, 2, 0, "Return non-nil if KEY is `equal' to the car of an element of LIST.\n\ -The value is actually the element of LIST whose car is KEY.") +The value is actually the element of LIST whose car equals KEY.") (key, list) register Lisp_Object key; Lisp_Object list; @@ -589,6 +696,26 @@ The value is actually the element of LIST whose cdr is ELT.") } return Qnil; } + +DEFUN ("rassoc", Frassoc, Srassoc, 2, 2, 0, + "Return non-nil if KEY is `equal' to the cdr of an element of LIST.\n\ +The value is actually the element of LIST whose cdr equals KEY.") + (key, list) + register Lisp_Object key; + Lisp_Object list; +{ + register Lisp_Object tail; + for (tail = list; !NILP (tail); tail = Fcdr (tail)) + { + register Lisp_Object elt, tem; + elt = Fcar (tail); + if (!CONSP (elt)) continue; + tem = Fequal (Fcdr (elt), key); + if (!NILP (tem)) return elt; + QUIT; + } + return Qnil; +} DEFUN ("delq", Fdelq, Sdelq, 2, 2, 0, "Delete by side effect any occurrences of ELT as a member of LIST.\n\ @@ -626,8 +753,9 @@ to be sure of changing the value of `foo'.") DEFUN ("delete", Fdelete, Sdelete, 2, 2, 0, "Delete by side effect any occurrences of ELT as a member of LIST.\n\ The modified LIST is returned. Comparison is done with `equal'.\n\ -If the first member of LIST is ELT, there is no way to remove it by side effect;\n\ -therefore, write `(setq foo (delete element foo))'\n\ +If the first member of LIST is ELT, deleting it is not a side effect;\n\ +it is simply using a different list.\n\ +Therefore, write `(setq foo (delete element foo))'\n\ to be sure of changing the value of `foo'.") (elt, list) register Lisp_Object elt; @@ -790,15 +918,19 @@ merge (org_l1, org_l2, pred) } } -DEFUN ("get", Fget, Sget, 2, 2, 0, - "Return the value of SYMBOL's PROPNAME property.\n\ -This is the last VALUE stored with `(put SYMBOL PROPNAME VALUE)'.") - (sym, prop) - Lisp_Object sym; + +DEFUN ("plist-get", Fplist_get, Splist_get, 2, 2, 0, + "Extract a value from a property list.\n\ +PLIST is a property list, which is a list of the form\n\ +\(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value\n\ +corresponding to the given PROP, or nil if PROP is not\n\ +one of the properties on the list.") + (val, prop) + Lisp_Object val; register Lisp_Object prop; { register Lisp_Object tail; - for (tail = Fsymbol_plist (sym); !NILP (tail); tail = Fcdr (Fcdr (tail))) + for (tail = val; !NILP (tail); tail = Fcdr (Fcdr (tail))) { register Lisp_Object tem; tem = Fcar (tail); @@ -808,31 +940,60 @@ This is the last VALUE stored with `(put SYMBOL PROPNAME VALUE)'.") return Qnil; } -DEFUN ("put", Fput, Sput, 3, 3, 0, - "Store SYMBOL's PROPNAME property with value VALUE.\n\ -It can be retrieved with `(get SYMBOL PROPNAME)'.") - (sym, prop, val) - Lisp_Object sym; - register Lisp_Object prop; - Lisp_Object val; +DEFUN ("get", Fget, Sget, 2, 2, 0, + "Return the value of SYMBOL's PROPNAME property.\n\ +This is the last value stored with `(put SYMBOL PROPNAME VALUE)'.") + (symbol, propname) + Lisp_Object symbol, propname; +{ + CHECK_SYMBOL (symbol, 0); + return Fplist_get (XSYMBOL (symbol)->plist, propname); +} + +DEFUN ("plist-put", Fplist_put, Splist_put, 3, 3, 0, + "Change value in PLIST of PROP to VAL.\n\ +PLIST is a property list, which is a list of the form\n\ +\(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.\n\ +If PROP is already a property on the list, its value is set to VAL,\n\ +otherwise the new PROP VAL pair is added. The new plist is returned;\n\ +use `(setq x (plist-put x prop val))' to be sure to use the new value.\n\ +The PLIST is modified by side effects.") + (plist, prop, val) + Lisp_Object plist; + register Lisp_Object prop; + Lisp_Object val; { register Lisp_Object tail, prev; Lisp_Object newcell; prev = Qnil; - for (tail = Fsymbol_plist (sym); !NILP (tail); tail = Fcdr (Fcdr (tail))) + for (tail = plist; CONSP (tail) && CONSP (XCONS (tail)->cdr); + tail = XCONS (XCONS (tail)->cdr)->cdr) { - register Lisp_Object tem; - tem = Fcar (tail); - if (EQ (prop, tem)) - return Fsetcar (Fcdr (tail), val); + if (EQ (prop, XCONS (tail)->car)) + { + Fsetcar (XCONS (tail)->cdr, val); + return plist; + } prev = tail; } newcell = Fcons (prop, Fcons (val, Qnil)); if (NILP (prev)) - Fsetplist (sym, newcell); + return newcell; else - Fsetcdr (Fcdr (prev), newcell); - return val; + Fsetcdr (XCONS (prev)->cdr, newcell); + return plist; +} + +DEFUN ("put", Fput, Sput, 3, 3, 0, + "Store SYMBOL's PROPNAME property with value VALUE.\n\ +It can be retrieved with `(get SYMBOL PROPNAME)'.") + (symbol, propname, value) + Lisp_Object symbol, propname, value; +{ + CHECK_SYMBOL (symbol, 0); + XSYMBOL (symbol)->plist + = Fplist_put (XSYMBOL (symbol)->plist, propname, value); + return value; } DEFUN ("equal", Fequal, Sequal, 2, 2, 0, @@ -846,83 +1007,145 @@ Symbols must match exactly.") (o1, o2) register Lisp_Object o1, o2; { - return internal_equal (o1, o2, 0); + return internal_equal (o1, o2, 0) ? Qt : Qnil; } -static Lisp_Object +static int internal_equal (o1, o2, depth) register Lisp_Object o1, o2; int depth; { if (depth > 200) error ("Stack overflow in equal"); -do_cdr: + + tail_recurse: QUIT; - if (EQ (o1, o2)) return Qt; + if (EQ (o1, o2)) + return 1; + if (XTYPE (o1) != XTYPE (o2)) + return 0; + + switch (XTYPE (o1)) + { #ifdef LISP_FLOAT_TYPE - if (FLOATP (o1) && FLOATP (o2)) - return (extract_float (o1) == extract_float (o2)) ? Qt : Qnil; + case Lisp_Float: + return (extract_float (o1) == extract_float (o2)); #endif - if (XTYPE (o1) != XTYPE (o2)) return Qnil; - if (XTYPE (o1) == Lisp_Cons - || XTYPE (o1) == Lisp_Overlay) - { - Lisp_Object v1; - v1 = internal_equal (Fcar (o1), Fcar (o2), depth + 1); - if (NILP (v1)) - return v1; - o1 = Fcdr (o1), o2 = Fcdr (o2); - goto do_cdr; - } - if (XTYPE (o1) == Lisp_Marker) - { - return ((XMARKER (o1)->buffer == XMARKER (o2)->buffer - && (XMARKER (o1)->buffer == 0 - || XMARKER (o1)->bufpos == XMARKER (o2)->bufpos)) - ? Qt : Qnil); - } - if (XTYPE (o1) == Lisp_Vector - || XTYPE (o1) == Lisp_Compiled) - { - register int index; - if (XVECTOR (o1)->size != XVECTOR (o2)->size) - return Qnil; - for (index = 0; index < XVECTOR (o1)->size; index++) + + case Lisp_Cons: + if (!internal_equal (XCONS (o1)->car, XCONS (o2)->car, depth + 1)) + return 0; + o1 = XCONS (o1)->cdr; + o2 = XCONS (o2)->cdr; + goto tail_recurse; + + case Lisp_Misc: + if (XMISCTYPE (o1) != XMISCTYPE (o2)) + return 0; + if (OVERLAYP (o1)) { - Lisp_Object v, v1, v2; - v1 = XVECTOR (o1)->contents [index]; - v2 = XVECTOR (o2)->contents [index]; - v = internal_equal (v1, v2, depth + 1); - if (NILP (v)) return v; + if (!internal_equal (OVERLAY_START (o1), OVERLAY_START (o1), + depth + 1) + || !internal_equal (OVERLAY_END (o1), OVERLAY_END (o1), + depth + 1)) + return 0; + o1 = XOVERLAY (o1)->plist; + o2 = XOVERLAY (o2)->plist; + goto tail_recurse; } - return Qt; - } - if (XTYPE (o1) == Lisp_String) - { + if (MARKERP (o1)) + { + return (XMARKER (o1)->buffer == XMARKER (o2)->buffer + && (XMARKER (o1)->buffer == 0 + || XMARKER (o1)->bufpos == XMARKER (o2)->bufpos)); + } + break; + + case Lisp_Vectorlike: + { + register int i, size; + size = XVECTOR (o1)->size; + /* Pseudovectors have the type encoded in the size field, so this test + actually checks that the objects have the same type as well as the + same size. */ + if (XVECTOR (o2)->size != size) + return 0; + /* Boolvectors are compared much like strings. */ + if (BOOL_VECTOR_P (o1)) + { + int size_in_chars + = (XBOOL_VECTOR (o1)->size + BITS_PER_CHAR) / BITS_PER_CHAR; + + if (XBOOL_VECTOR (o1)->size != XBOOL_VECTOR (o2)->size) + return 0; + if (bcmp (XBOOL_VECTOR (o1)->data, XBOOL_VECTOR (o2)->data, + size_in_chars)) + return 0; + return 1; + } + + /* Aside from them, only true vectors, char-tables, and compiled + functions are sensible to compare, so eliminate the others now. */ + if (size & PSEUDOVECTOR_FLAG) + { + if (!(size & (PVEC_COMPILED | PVEC_CHAR_TABLE))) + return 0; + size &= PSEUDOVECTOR_SIZE_MASK; + } + for (i = 0; i < size; i++) + { + Lisp_Object v1, v2; + v1 = XVECTOR (o1)->contents [i]; + v2 = XVECTOR (o2)->contents [i]; + if (!internal_equal (v1, v2, depth + 1)) + return 0; + } + return 1; + } + break; + + case Lisp_String: if (XSTRING (o1)->size != XSTRING (o2)->size) - return Qnil; - if (bcmp (XSTRING (o1)->data, XSTRING (o2)->data, XSTRING (o1)->size)) - return Qnil; - return Qt; + return 0; + if (bcmp (XSTRING (o1)->data, XSTRING (o2)->data, + XSTRING (o1)->size)) + return 0; +#ifdef USE_TEXT_PROPERTIES + /* If the strings have intervals, verify they match; + if not, they are unequal. */ + if ((XSTRING (o1)->intervals != 0 || XSTRING (o2)->intervals != 0) + && ! compare_string_intervals (o1, o2)) + return 0; +#endif + return 1; } - return Qnil; + return 0; } 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; { register int size, index, charval; retry: - if (XTYPE (array) == Lisp_Vector) + if (VECTORP (array)) { register Lisp_Object *p = XVECTOR (array)->contents; size = XVECTOR (array)->size; for (index = 0; index < size; index++) p[index] = item; } - else if (XTYPE (array) == Lisp_String) + 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; CHECK_NUMBER (item, 1); @@ -931,6 +1154,16 @@ DEFUN ("fillarray", Ffillarray, Sfillarray, 2, 2, 0, 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); @@ -939,6 +1172,211 @@ DEFUN ("fillarray", Ffillarray, Sfillarray, 2, 2, 0, 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; +} + +/* 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; +} + /* ARGSUSED */ Lisp_Object nconc2 (s1, s2) @@ -1021,7 +1459,7 @@ mapcar1 (leni, vals, 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 */ - if (XTYPE (seq) == Lisp_Vector) + if (VECTORP (seq)) { for (i = 0; i < leni; i++) { @@ -1029,11 +1467,11 @@ mapcar1 (leni, vals, fn, seq) vals[i] = call1 (fn, dummy); } } - else if (XTYPE (seq) == Lisp_String) + else if (STRINGP (seq)) { for (i = 0; i < leni; i++) { - XFASTINT (dummy) = XSTRING (seq)->data[i]; + XSETFASTINT (dummy, XSTRING (seq)->data[i]); vals[i] = call1 (fn, dummy); } } @@ -1130,9 +1568,12 @@ Also accepts Space to mean yes, or Delete to mean no.") while (1) { - 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; + redisplay_preserve_echo_area (); pane = Fcons (Fcons (build_string ("Yes"), Qt), Fcons (Fcons (build_string ("No"), Qnil), Qnil)); @@ -1141,16 +1582,14 @@ Also accepts Space to mean yes, or Delete to mean no.") answer = !NILP (obj); break; } - else - { - cursor_in_echo_area = 1; - message ("%s(y or n) ", XSTRING (xprompt)->data); +#endif + cursor_in_echo_area = 1; + message_nolog ("%s(y or n) ", XSTRING (xprompt)->data); - 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; - } + 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); @@ -1174,6 +1613,10 @@ Also accepts Space to mean yes, or Delete to mean no.") } else if (EQ (def, intern ("quit"))) Vquit_flag = Qt; + /* We want to exit this command for exit-prefix, + and this is the only way to do it. */ + else if (EQ (def, intern ("exit-prefix"))) + Vquit_flag = Qt; QUIT; @@ -1195,7 +1638,8 @@ Also accepts Space to mean yes, or Delete to mean no.") 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; } @@ -1221,7 +1665,7 @@ DEFUN ("yes-or-no-p", Fyes_or_no_p, Syes_or_no_p, 1, 1, 0, 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; { @@ -1232,9 +1676,12 @@ and can edit it until it as been confirmed.") CHECK_STRING (prompt, 0); - 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; + redisplay_preserve_echo_area (); pane = Fcons (Fcons (build_string ("Yes"), Qt), Fcons (Fcons (build_string ("No"), Qnil), Qnil)); @@ -1244,6 +1691,7 @@ and can edit it until it as been confirmed.") UNGCPRO; return obj; } +#endif args[0] = prompt; args[1] = build_string ("(yes or no) "); @@ -1382,6 +1830,7 @@ Used by `featurep' and `require', and altered by `provide'."); defsubr (&Sidentity); defsubr (&Srandom); defsubr (&Slength); + defsubr (&Ssafe_length); defsubr (&Sstring_equal); defsubr (&Sstring_lessp); defsubr (&Sappend); @@ -1398,15 +1847,26 @@ Used by `featurep' and `require', and altered by `provide'."); defsubr (&Sassq); defsubr (&Sassoc); defsubr (&Srassq); + defsubr (&Srassoc); defsubr (&Sdelq); defsubr (&Sdelete); defsubr (&Snreverse); defsubr (&Sreverse); defsubr (&Ssort); + defsubr (&Splist_get); defsubr (&Sget); + defsubr (&Splist_put); defsubr (&Sput); defsubr (&Sequal); defsubr (&Sfillarray); + defsubr (&Schar_table_subtype); + defsubr (&Schar_table_parent); + defsubr (&Sset_char_table_parent); + defsubr (&Schar_table_extra_slot); + defsubr (&Sset_char_table_extra_slot); + defsubr (&Schar_table_range); + defsubr (&Sset_char_table_range); + defsubr (&Smap_char_table); defsubr (&Snconc); defsubr (&Smapcar); defsubr (&Smapconcat);