X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/eb7a410c147507ffdf0e84d163a014acb82b19a2..2bfa3d3e1fb347ba76bddf77f3e288049635821d:/src/fns.c diff --git a/src/fns.c b/src/fns.c index 08c6f055f3..015fc8cbf5 100644 --- a/src/fns.c +++ b/src/fns.c @@ -1,6 +1,7 @@ /* Random utility Lisp functions. -Copyright (C) 1985-1987, 1993-1995, 1997-2013 Free Software Foundation, Inc. +Copyright (C) 1985-1987, 1993-1995, 1997-2014 Free Software Foundation, +Inc. This file is part of GNU Emacs. @@ -35,11 +36,9 @@ along with GNU Emacs. If not, see . */ #include "frame.h" #include "window.h" #include "blockinput.h" -#ifdef HAVE_MENUS #if defined (HAVE_X_WINDOWS) #include "xterm.h" #endif -#endif /* HAVE_MENUS */ Lisp_Object Qstring_lessp; static Lisp_Object Qprovide, Qrequire; @@ -49,8 +48,6 @@ static Lisp_Object Qwidget_type; static Lisp_Object Qcodeset, Qdays, Qmonths, Qpaper; static Lisp_Object Qmd5, Qsha1, Qsha224, Qsha256, Qsha384, Qsha512; - -static bool internal_equal (Lisp_Object, Lisp_Object, int, bool); DEFUN ("identity", Fidentity, Sidentity, 1, 1, 0, doc: /* Return the argument unchanged. */) @@ -80,8 +77,17 @@ See Info node `(elisp)Random Numbers' for more details. */) seed_random (SSDATA (limit), SBYTES (limit)); val = get_random (); - if (NATNUMP (limit) && XFASTINT (limit) != 0) - val %= XFASTINT (limit); + if (INTEGERP (limit) && 0 < XINT (limit)) + while (true) + { + /* Return the remainder, except reject the rare case where + get_random returns a number so close to INTMASK that the + remainder isn't random. */ + EMACS_INT remainder = val % XINT (limit); + if (val - remainder <= INTMASK - XINT (limit) + 1) + return make_number (remainder); + val = get_random (); + } return make_number (val); } @@ -91,6 +97,12 @@ enum { QUIT_COUNT_HEURISTIC = 1 << 16 }; /* Random data-structure functions. */ +static void +CHECK_LIST_END (Lisp_Object x, Lisp_Object y) +{ + CHECK_TYPE (NILP (x), Qlistp, y); +} + DEFUN ("length", Flength, Slength, 1, 1, 0, doc: /* Return the length of vector, list or string SEQUENCE. A byte-code function object is also allowed. @@ -108,7 +120,7 @@ To get the number of bytes, use `string-bytes'. */) else if (CHAR_TABLE_P (sequence)) XSETFASTINT (val, MAX_CHAR); else if (BOOL_VECTOR_P (sequence)) - XSETFASTINT (val, XBOOL_VECTOR (sequence)->size); + XSETFASTINT (val, bool_vector_size (sequence)); else if (COMPILEDP (sequence)) XSETFASTINT (val, ASIZE (sequence) & PSEUDOVECTOR_SIZE_MASK); else if (CONSP (sequence)) @@ -140,8 +152,6 @@ To get the number of bytes, use `string-bytes'. */) 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, 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, @@ -220,6 +230,7 @@ string STR1, compare the part between START1 (inclusive) and END1 \(exclusive). If START1 is nil, it defaults to 0, the beginning of the string; if END1 is nil, it defaults to the length of the string. Likewise, in string STR2, compare the part between START2 and END2. +Like in `substring', negative values are counted from the end. The strings are compared by the numeric values of their characters. For instance, STR1 is "less than" STR2 if its first differing @@ -232,75 +243,39 @@ 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. */) - (Lisp_Object str1, Lisp_Object start1, Lisp_Object end1, Lisp_Object str2, Lisp_Object start2, Lisp_Object end2, Lisp_Object ignore_case) + (Lisp_Object str1, Lisp_Object start1, Lisp_Object end1, Lisp_Object str2, + Lisp_Object start2, Lisp_Object end2, Lisp_Object ignore_case) { - register ptrdiff_t end1_char, end2_char; - register ptrdiff_t i1, i1_byte, i2, i2_byte; + ptrdiff_t from1, to1, from2, to2, i1, i1_byte, i2, i2_byte; CHECK_STRING (str1); CHECK_STRING (str2); - if (NILP (start1)) - start1 = make_number (0); - if (NILP (start2)) - start2 = make_number (0); - CHECK_NATNUM (start1); - CHECK_NATNUM (start2); - if (! NILP (end1)) - CHECK_NATNUM (end1); - if (! NILP (end2)) - CHECK_NATNUM (end2); - - end1_char = SCHARS (str1); - if (! NILP (end1) && end1_char > XINT (end1)) - end1_char = XINT (end1); - if (end1_char < XINT (start1)) - args_out_of_range (str1, start1); - - end2_char = SCHARS (str2); - if (! NILP (end2) && end2_char > XINT (end2)) - end2_char = XINT (end2); - if (end2_char < XINT (start2)) - args_out_of_range (str2, start2); - - i1 = XINT (start1); - i2 = XINT (start2); + + validate_subarray (str1, start1, end1, SCHARS (str1), &from1, &to1); + validate_subarray (str2, start2, end2, SCHARS (str2), &from2, &to2); + + i1 = from1; + i2 = from2; i1_byte = string_char_to_byte (str1, i1); i2_byte = string_char_to_byte (str2, i2); - while (i1 < end1_char && i2 < end2_char) + while (i1 < to1 && i2 < to2) { /* When we find a mismatch, we must compare the characters, not just the bytes. */ int c1, c2; - if (STRING_MULTIBYTE (str1)) - FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1, str1, i1, i1_byte); - else - { - c1 = SREF (str1, i1++); - MAKE_CHAR_MULTIBYTE (c1); - } - - if (STRING_MULTIBYTE (str2)) - FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2, str2, i2, i2_byte); - else - { - c2 = SREF (str2, i2++); - MAKE_CHAR_MULTIBYTE (c2); - } + FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c1, str1, i1, i1_byte); + FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c2, str2, i2, i2_byte); if (c1 == c2) continue; if (! NILP (ignore_case)) { - Lisp_Object tem; - - tem = Fupcase (make_number (c1)); - c1 = XINT (tem); - tem = Fupcase (make_number (c2)); - c2 = XINT (tem); + c1 = XINT (Fupcase (make_number (c1))); + c2 = XINT (Fupcase (make_number (c2))); } if (c1 == c2) @@ -310,15 +285,15 @@ If string STR1 is greater, the value is a positive number N; past the character that we are comparing; hence we don't add or subtract 1 here. */ if (c1 < c2) - return make_number (- i1 + XINT (start1)); + return make_number (- i1 + from1); else - return make_number (i1 - XINT (start1)); + return make_number (i1 - from1); } - if (i1 < end1_char) - return make_number (i1 - XINT (start1) + 1); - if (i2 < end2_char) - return make_number (- i1 + XINT (start1) - 1); + if (i1 < to1) + return make_number (i1 - from1 + 1); + if (i2 < to2) + return make_number (- i1 + from1 - 1); return Qt; } @@ -360,8 +335,15 @@ Symbols are also allowed; their print names are used instead. */) return i1 < SCHARS (s2) ? Qt : Qnil; } +enum concat_target_type + { + concat_cons, + concat_string, + concat_vector + }; + static Lisp_Object concat (ptrdiff_t nargs, Lisp_Object *args, - enum Lisp_Type target_type, bool last_special); + enum concat_target_type target_type, bool last_special); /* ARGSUSED */ Lisp_Object @@ -370,7 +352,7 @@ concat2 (Lisp_Object s1, Lisp_Object s2) Lisp_Object args[2]; args[0] = s1; args[1] = s2; - return concat (2, args, Lisp_String, 0); + return concat (2, args, concat_string, 0); } /* ARGSUSED */ @@ -381,7 +363,7 @@ concat3 (Lisp_Object s1, Lisp_Object s2, Lisp_Object s3) args[0] = s1; args[1] = s2; args[2] = s3; - return concat (3, args, Lisp_String, 0); + return concat (3, args, concat_string, 0); } DEFUN ("append", Fappend, Sappend, 0, MANY, 0, @@ -392,7 +374,7 @@ The last argument is not copied, just used as the tail of the new list. usage: (append &rest SEQUENCES) */) (ptrdiff_t nargs, Lisp_Object *args) { - return concat (nargs, args, Lisp_Cons, 1); + return concat (nargs, args, concat_cons, 1); } DEFUN ("concat", Fconcat, Sconcat, 0, MANY, 0, @@ -402,7 +384,7 @@ Each argument may be a string or a list or vector of characters (integers). usage: (concat &rest SEQUENCES) */) (ptrdiff_t nargs, Lisp_Object *args) { - return concat (nargs, args, Lisp_String, 0); + return concat (nargs, args, concat_string, 0); } DEFUN ("vconcat", Fvconcat, Svconcat, 0, MANY, 0, @@ -412,7 +394,7 @@ Each argument may be a list, vector or string. usage: (vconcat &rest SEQUENCES) */) (ptrdiff_t nargs, Lisp_Object *args) { - return concat (nargs, args, Lisp_Vectorlike, 0); + return concat (nargs, args, concat_vector, 0); } @@ -431,21 +413,21 @@ with the original. */) if (BOOL_VECTOR_P (arg)) { - Lisp_Object val; - ptrdiff_t size_in_chars - = ((XBOOL_VECTOR (arg)->size + BOOL_VECTOR_BITS_PER_CHAR - 1) - / BOOL_VECTOR_BITS_PER_CHAR); - - val = Fmake_bool_vector (Flength (arg), Qnil); - memcpy (XBOOL_VECTOR (val)->data, XBOOL_VECTOR (arg)->data, - size_in_chars); + EMACS_INT nbits = bool_vector_size (arg); + ptrdiff_t nbytes = bool_vector_bytes (nbits); + Lisp_Object val = make_uninit_bool_vector (nbits); + memcpy (bool_vector_data (val), bool_vector_data (arg), nbytes); return val; } - if (!CONSP (arg) && !VECTORP (arg) && !STRINGP (arg)) + if (CONSP (arg)) + return concat (1, &arg, concat_cons, 0); + else if (STRINGP (arg)) + return concat (1, &arg, concat_string, 0); + else if (VECTORP (arg)) + return concat (1, &arg, concat_vector, 0); + else wrong_type_argument (Qsequencep, arg); - - return concat (1, &arg, CONSP (arg) ? Lisp_Cons : XTYPE (arg), 0); } /* This structure holds information of an argument of `concat' that is @@ -459,7 +441,7 @@ struct textprop_rec static Lisp_Object concat (ptrdiff_t nargs, Lisp_Object *args, - enum Lisp_Type target_type, bool last_special) + enum concat_target_type target_type, bool last_special) { Lisp_Object val; Lisp_Object tail; @@ -514,7 +496,7 @@ concat (ptrdiff_t nargs, Lisp_Object *args, EMACS_INT len; this = args[argnum]; len = XFASTINT (Flength (this)); - if (target_type == Lisp_String) + if (target_type == concat_string) { /* We must count the number of bytes needed in the string as well as the number of characters. */ @@ -536,7 +518,7 @@ concat (ptrdiff_t nargs, Lisp_Object *args, if (! ASCII_CHAR_P (c) && ! CHAR_BYTE8_P (c)) some_multibyte = 1; } - else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size > 0) + else if (BOOL_VECTOR_P (this) && bool_vector_size (this) > 0) wrong_type_argument (Qintegerp, Faref (this, make_number (0))); else if (CONSP (this)) for (; CONSP (this); this = XCDR (this)) @@ -576,9 +558,9 @@ concat (ptrdiff_t nargs, Lisp_Object *args, result_len_byte = result_len; /* Create the output object. */ - if (target_type == Lisp_Cons) + if (target_type == concat_cons) val = Fmake_list (make_number (result_len), Qnil); - else if (target_type == Lisp_Vectorlike) + else if (target_type == concat_vector) val = Fmake_vector (make_number (result_len), Qnil); else if (some_multibyte) val = make_uninit_multibyte_string (result_len, result_len_byte); @@ -586,7 +568,7 @@ concat (ptrdiff_t nargs, Lisp_Object *args, val = make_uninit_string (result_len); /* In `append', if all but last arg are nil, return last arg. */ - if (target_type == Lisp_Cons && EQ (val, Qnil)) + if (target_type == concat_cons && EQ (val, Qnil)) return last_tail; /* Copy the contents of the args into the result. */ @@ -670,12 +652,7 @@ concat (ptrdiff_t nargs, Lisp_Object *args, } else if (BOOL_VECTOR_P (this)) { - int byte; - byte = XBOOL_VECTOR (this)->data[thisindex / BOOL_VECTOR_BITS_PER_CHAR]; - if (byte & (1 << (thisindex % BOOL_VECTOR_BITS_PER_CHAR))) - elt = Qt; - else - elt = Qnil; + elt = bool_vector_ref (this, thisindex); thisindex++; } else @@ -1005,11 +982,9 @@ If STRING is multibyte and contains a character of charset if (STRING_MULTIBYTE (string)) { - ptrdiff_t bytes = SBYTES (string); - unsigned char *str = xmalloc (bytes); + unsigned char *str = (unsigned char *) xlispstrdup (string); + ptrdiff_t bytes = str_as_unibyte (str, SBYTES (string)); - memcpy (str, SDATA (string), bytes); - bytes = str_as_unibyte (str, bytes); string = make_unibyte_string ((char *) str, bytes); xfree (str); } @@ -1088,7 +1063,7 @@ an error is signaled. */) if (STRING_MULTIBYTE (string)) { ptrdiff_t chars = SCHARS (string); - unsigned char *str = xmalloc (chars); + unsigned char *str = xmalloc_atomic (chars); ptrdiff_t converted = str_to_unibyte (SDATA (string), str, chars); if (converted < chars) @@ -1114,7 +1089,7 @@ Elements of ALIST that are not conses are also shared. */) CHECK_LIST (alist); if (NILP (alist)) return alist; - alist = concat (1, &alist, Lisp_Cons, 0); + alist = concat (1, &alist, concat_cons, 0); for (tem = alist; CONSP (tem); tem = XCDR (tem)) { register Lisp_Object car; @@ -1126,7 +1101,48 @@ Elements of ALIST that are not conses are also shared. */) return alist; } -DEFUN ("substring", Fsubstring, Ssubstring, 2, 3, 0, +/* Check that ARRAY can have a valid subarray [FROM..TO), + given that its size is SIZE. + If FROM is nil, use 0; if TO is nil, use SIZE. + Count negative values backwards from the end. + Set *IFROM and *ITO to the two indexes used. */ + +void +validate_subarray (Lisp_Object array, Lisp_Object from, Lisp_Object to, + ptrdiff_t size, ptrdiff_t *ifrom, ptrdiff_t *ito) +{ + EMACS_INT f, t; + + if (INTEGERP (from)) + { + f = XINT (from); + if (f < 0) + f += size; + } + else if (NILP (from)) + f = 0; + else + wrong_type_argument (Qintegerp, from); + + if (INTEGERP (to)) + { + t = XINT (to); + if (t < 0) + t += size; + } + else if (NILP (to)) + t = size; + else + wrong_type_argument (Qintegerp, to); + + if (! (0 <= f && f <= t && t <= size)) + args_out_of_range_3 (array, from, to); + + *ifrom = f; + *ito = t; +} + +DEFUN ("substring", Fsubstring, Ssubstring, 1, 3, 0, doc: /* Return a new string whose contents are a substring of STRING. The returned string consists of the characters between index FROM \(inclusive) and index TO (exclusive) of STRING. FROM and TO are @@ -1136,52 +1152,37 @@ to the end of STRING. The STRING argument may also be a vector. In that case, the return value is a new vector that contains the elements between index FROM -\(inclusive) and index TO (exclusive) of that vector argument. */) - (Lisp_Object string, register Lisp_Object from, Lisp_Object to) +\(inclusive) and index TO (exclusive) of that vector argument. + +With one argument, just copy STRING (with properties, if any). */) + (Lisp_Object string, Lisp_Object from, Lisp_Object to) { Lisp_Object res; - ptrdiff_t size; - EMACS_INT from_char, to_char; - - CHECK_VECTOR_OR_STRING (string); - CHECK_NUMBER (from); + ptrdiff_t size, ifrom, ito; if (STRINGP (string)) size = SCHARS (string); - else + else if (VECTORP (string)) size = ASIZE (string); - - if (NILP (to)) - to_char = size; else - { - CHECK_NUMBER (to); - - to_char = XINT (to); - if (to_char < 0) - to_char += size; - } + wrong_type_argument (Qarrayp, string); - from_char = XINT (from); - if (from_char < 0) - from_char += size; - if (!(0 <= from_char && from_char <= to_char && to_char <= size)) - args_out_of_range_3 (string, make_number (from_char), - make_number (to_char)); + validate_subarray (string, from, to, size, &ifrom, &ito); if (STRINGP (string)) { - ptrdiff_t to_byte = - (NILP (to) ? SBYTES (string) : string_char_to_byte (string, to_char)); - ptrdiff_t from_byte = string_char_to_byte (string, from_char); + ptrdiff_t from_byte + = !ifrom ? 0 : string_char_to_byte (string, ifrom); + ptrdiff_t to_byte + = ito == size ? SBYTES (string) : string_char_to_byte (string, ito); res = make_specified_string (SSDATA (string) + from_byte, - to_char - from_char, to_byte - from_byte, + ito - ifrom, to_byte - from_byte, STRING_MULTIBYTE (string)); - copy_text_properties (make_number (from_char), make_number (to_char), + copy_text_properties (make_number (ifrom), make_number (ito), string, make_number (0), res, Qnil); } else - res = Fvector (to_char - from_char, aref_addr (string, from_char)); + res = Fvector (ito - ifrom, aref_addr (string, ifrom)); return res; } @@ -1197,41 +1198,16 @@ If FROM or TO is negative, it counts from the end. With one argument, just copy STRING without its properties. */) (Lisp_Object string, register Lisp_Object from, Lisp_Object to) { - ptrdiff_t size; - EMACS_INT from_char, to_char; - ptrdiff_t from_byte, to_byte; + ptrdiff_t from_char, to_char, from_byte, to_byte, size; CHECK_STRING (string); size = SCHARS (string); + validate_subarray (string, from, to, size, &from_char, &to_char); - if (NILP (from)) - from_char = 0; - else - { - CHECK_NUMBER (from); - from_char = XINT (from); - if (from_char < 0) - from_char += size; - } - - if (NILP (to)) - to_char = size; - else - { - CHECK_NUMBER (to); - to_char = XINT (to); - if (to_char < 0) - to_char += size; - } - - if (!(0 <= from_char && from_char <= to_char && to_char <= size)) - args_out_of_range_3 (string, make_number (from_char), - make_number (to_char)); - - from_byte = NILP (from) ? 0 : string_char_to_byte (string, from_char); + from_byte = !from_char ? 0 : string_char_to_byte (string, from_char); to_byte = - NILP (to) ? SBYTES (string) : string_char_to_byte (string, to_char); + to_char == size ? SBYTES (string) : string_char_to_byte (string, to_char); return make_specified_string (SSDATA (string) + from_byte, to_char - from_char, to_byte - from_byte, STRING_MULTIBYTE (string)); @@ -1356,15 +1332,12 @@ The value is actually the tail of LIST whose car is ELT. */) { register Lisp_Object tail; - if (!FLOATP (elt)) - return Fmemq (elt, list); - for (tail = list; CONSP (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)) + if (!NILP (Feql (elt, tem))) return tail; QUIT; } @@ -1546,15 +1519,12 @@ Write `(setq foo (delq element foo))' to be sure of correctly changing the value of a list `foo'. */) (register Lisp_Object elt, Lisp_Object list) { - register Lisp_Object tail, prev; - register Lisp_Object tem; + Lisp_Object tail, tortoise, prev = Qnil; + bool skip; - tail = list; - prev = Qnil; - while (CONSP (tail)) + FOR_EACH_TAIL (tail, list, tortoise, skip) { - CHECK_LIST_CONS (tail, list); - tem = XCAR (tail); + Lisp_Object tem = XCAR (tail); if (EQ (elt, tem)) { if (NILP (prev)) @@ -1564,8 +1534,6 @@ the value of a list `foo'. */) } else prev = tail; - tail = XCDR (tail); - QUIT; } return list; } @@ -1697,45 +1665,124 @@ changing the value of a sequence `foo'. */) } DEFUN ("nreverse", Fnreverse, Snreverse, 1, 1, 0, - doc: /* Reverse LIST by modifying cdr pointers. -Return the reversed list. Expects a properly nil-terminated list. */) - (Lisp_Object list) + doc: /* Reverse order of items in a list, vector or string SEQ. +If SEQ is a list, it should be nil-terminated. +This function may destructively modify SEQ to produce the value. */) + (Lisp_Object seq) { - register Lisp_Object prev, tail, next; + if (NILP (seq)) + return seq; + else if (STRINGP (seq)) + return Freverse (seq); + else if (CONSP (seq)) + { + Lisp_Object prev, tail, next; - if (NILP (list)) return list; - prev = Qnil; - tail = list; - while (!NILP (tail)) + for (prev = Qnil, tail = seq; !NILP (tail); tail = next) + { + QUIT; + CHECK_LIST_CONS (tail, tail); + next = XCDR (tail); + Fsetcdr (tail, prev); + prev = tail; + } + seq = prev; + } + else if (VECTORP (seq)) { - QUIT; - CHECK_LIST_CONS (tail, tail); - next = XCDR (tail); - Fsetcdr (tail, prev); - prev = tail; - tail = next; + ptrdiff_t i, size = ASIZE (seq); + + for (i = 0; i < size / 2; i++) + { + Lisp_Object tem = AREF (seq, i); + ASET (seq, i, AREF (seq, size - i - 1)); + ASET (seq, size - i - 1, tem); + } } - return prev; + else if (BOOL_VECTOR_P (seq)) + { + ptrdiff_t i, size = bool_vector_size (seq); + + for (i = 0; i < size / 2; i++) + { + bool tem = bool_vector_bitref (seq, i); + bool_vector_set (seq, i, bool_vector_bitref (seq, size - i - 1)); + bool_vector_set (seq, size - i - 1, tem); + } + } + else + wrong_type_argument (Qarrayp, seq); + return seq; } DEFUN ("reverse", Freverse, Sreverse, 1, 1, 0, - doc: /* Reverse LIST, copying. Return the reversed list. + doc: /* Return the reversed copy of list, vector, or string SEQ. See also the function `nreverse', which is used more often. */) - (Lisp_Object list) + (Lisp_Object seq) { Lisp_Object new; - for (new = Qnil; CONSP (list); list = XCDR (list)) + if (NILP (seq)) + return Qnil; + else if (CONSP (seq)) { - QUIT; - new = Fcons (XCAR (list), new); + for (new = Qnil; CONSP (seq); seq = XCDR (seq)) + { + QUIT; + new = Fcons (XCAR (seq), new); + } + CHECK_LIST_END (seq, seq); } - CHECK_LIST_END (list, list); + else if (VECTORP (seq)) + { + ptrdiff_t i, size = ASIZE (seq); + + new = make_uninit_vector (size); + for (i = 0; i < size; i++) + ASET (new, i, AREF (seq, size - i - 1)); + } + else if (BOOL_VECTOR_P (seq)) + { + ptrdiff_t i; + EMACS_INT nbits = bool_vector_size (seq); + + new = make_uninit_bool_vector (nbits); + for (i = 0; i < nbits; i++) + bool_vector_set (new, i, bool_vector_bitref (seq, nbits - i - 1)); + } + else if (STRINGP (seq)) + { + ptrdiff_t size = SCHARS (seq), bytes = SBYTES (seq); + + if (size == bytes) + { + ptrdiff_t i; + + new = make_uninit_string (size); + for (i = 0; i < size; i++) + SSET (new, i, SREF (seq, size - i - 1)); + } + else + { + unsigned char *p, *q; + + new = make_uninit_multibyte_string (size, bytes); + p = SDATA (seq), q = SDATA (new) + bytes; + while (q > SDATA (new)) + { + int ch, len; + + ch = STRING_CHAR_AND_LENGTH (p, len); + p += len, q -= len; + CHAR_STRING (ch, q); + } + } + } + else + wrong_type_argument (Qsequencep, seq); return new; } -Lisp_Object merge (Lisp_Object org_l1, Lisp_Object org_l2, Lisp_Object pred); - 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. @@ -1956,7 +2003,7 @@ The PLIST is modified by side effects. */) prev = tail; QUIT; } - newcell = Fcons (prop, Fcons (val, Qnil)); + newcell = list2 (prop, val); if (NILP (prev)) return newcell; else @@ -1969,10 +2016,7 @@ DEFUN ("eql", Feql, Seql, 2, 2, 0, Floating-point numbers of equal value are `eql', but they may not be `eq'. */) (Lisp_Object obj1, Lisp_Object obj2) { - if (FLOATP (obj1)) - return internal_equal (obj1, obj2, 0, 0) ? Qt : Qnil; - else - return EQ (obj1, obj2) ? Qt : Qnil; + return scm_is_true (scm_eqv_p (obj1, obj2)) ? Qt : Qnil; } DEFUN ("equal", Fequal, Sequal, 2, 2, 0, @@ -1985,139 +2029,107 @@ Numbers are compared by value, but integers cannot equal floats. Symbols must match exactly. */) (register Lisp_Object o1, Lisp_Object o2) { - return internal_equal (o1, o2, 0, 0) ? Qt : Qnil; + return scm_is_true (scm_equal_p (o1, o2)) ? Qt : Qnil; } +SCM compare_text_properties = SCM_BOOL_F; + DEFUN ("equal-including-properties", Fequal_including_properties, Sequal_including_properties, 2, 2, 0, doc: /* Return t if two Lisp objects have similar structure and contents. This is like `equal' except that it compares the text properties of strings. (`equal' ignores text properties.) */) (register Lisp_Object o1, Lisp_Object o2) { - return internal_equal (o1, o2, 0, 1) ? Qt : Qnil; -} + Lisp_Object tem; -/* DEPTH is current depth of recursion. Signal an error if it - gets too deep. - PROPS means compare string text properties too. */ + scm_dynwind_begin (0); + scm_dynwind_fluid (compare_text_properties, SCM_BOOL_T); + tem = Fequal (o1, o2); + scm_dynwind_end (); + return tem; +} -static bool -internal_equal (Lisp_Object o1, Lisp_Object o2, int depth, bool props) +static SCM +misc_equal_p (SCM o1, SCM o2) { - if (depth > 200) - error ("Stack overflow in equal"); - - tail_recurse: - QUIT; - if (EQ (o1, o2)) - return 1; - if (XTYPE (o1) != XTYPE (o2)) - return 0; - - switch (XTYPE (o1)) + if (XMISCTYPE (o1) != XMISCTYPE (o2)) + return SCM_BOOL_F; + if (OVERLAYP (o1)) { - case Lisp_Float: - { - double d1, d2; - - d1 = extract_float (o1); - d2 = extract_float (o2); - /* If d is a NaN, then d != d. Two NaNs should be `equal' even - though they are not =. */ - return d1 == d2 || (d1 != d1 && d2 != d2); - } - - case Lisp_Cons: - if (!internal_equal (XCAR (o1), XCAR (o2), depth + 1, props)) - return 0; - o1 = XCDR (o1); - o2 = XCDR (o2); - goto tail_recurse; - - case Lisp_Misc: - if (XMISCTYPE (o1) != XMISCTYPE (o2)) - return 0; - if (OVERLAYP (o1)) - { - if (!internal_equal (OVERLAY_START (o1), OVERLAY_START (o2), - depth + 1, props) - || !internal_equal (OVERLAY_END (o1), OVERLAY_END (o2), - depth + 1, props)) - return 0; - o1 = XOVERLAY (o1)->plist; - o2 = XOVERLAY (o2)->plist; - goto tail_recurse; - } - if (MARKERP (o1)) - { - return (XMARKER (o1)->buffer == XMARKER (o2)->buffer - && (XMARKER (o1)->buffer == 0 - || XMARKER (o1)->bytepos == XMARKER (o2)->bytepos)); - } - break; - - case Lisp_Vectorlike: - { - register int i; - ptrdiff_t 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 (ASIZE (o2) != size) - return 0; - /* Boolvectors are compared much like strings. */ - if (BOOL_VECTOR_P (o1)) - { - if (XBOOL_VECTOR (o1)->size != XBOOL_VECTOR (o2)->size) - return 0; - if (memcmp (XBOOL_VECTOR (o1)->data, XBOOL_VECTOR (o2)->data, - ((XBOOL_VECTOR (o1)->size - + BOOL_VECTOR_BITS_PER_CHAR - 1) - / BOOL_VECTOR_BITS_PER_CHAR))) - return 0; - return 1; - } - if (WINDOW_CONFIGURATIONP (o1)) - return compare_window_configurations (o1, o2, 0); + if (NILP (Fequal (OVERLAY_START (o1), OVERLAY_START (o2))) + || NILP (Fequal (OVERLAY_END (o1), OVERLAY_END (o2)))) + return SCM_BOOL_F; + return scm_equal_p (XOVERLAY (o1)->plist, XOVERLAY (o2)->plist); + } + if (MARKERP (o1)) + { + struct Lisp_Marker *m1 = XMARKER (o1), *m2 = XMARKER (o2); + return scm_from_bool (m1->buffer == m2->buffer + && (m1->buffer == 0 + || m1->bytepos == m2->bytepos)); + } + return SCM_BOOL_F; +} - /* Aside from them, only true vectors, char-tables, compiled - functions, and fonts (font-spec, font-entity, font-object) - are sensible to compare, so eliminate the others now. */ - if (size & PSEUDOVECTOR_FLAG) - { - if (((size & PVEC_TYPE_MASK) >> PSEUDOVECTOR_AREA_BITS) - < PVEC_COMPILED) - return 0; - size &= PSEUDOVECTOR_SIZE_MASK; - } - for (i = 0; i < size; i++) - { - Lisp_Object v1, v2; - v1 = AREF (o1, i); - v2 = AREF (o2, i); - if (!internal_equal (v1, v2, depth + 1, props)) - return 0; - } - return 1; - } - break; - - case Lisp_String: - if (SCHARS (o1) != SCHARS (o2)) - return 0; - if (SBYTES (o1) != SBYTES (o2)) - return 0; - if (memcmp (SDATA (o1), SDATA (o2), SBYTES (o1))) - return 0; - if (props && !compare_string_intervals (o1, o2)) - return 0; - return 1; - - default: - break; +static SCM +vectorlike_equal_p (SCM o1, SCM o2) +{ + int i; + ptrdiff_t 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 (ASIZE (o2) != size) + return SCM_BOOL_F; + /* Boolvectors are compared much like strings. */ + if (BOOL_VECTOR_P (o1)) + { + if (XBOOL_VECTOR (o1)->size != XBOOL_VECTOR (o2)->size) + return SCM_BOOL_F; + if (memcmp (XBOOL_VECTOR (o1)->data, XBOOL_VECTOR (o2)->data, + ((XBOOL_VECTOR (o1)->size + + BOOL_VECTOR_BITS_PER_CHAR - 1) + / BOOL_VECTOR_BITS_PER_CHAR))) + return SCM_BOOL_F; + return SCM_BOOL_T; + } + if (WINDOW_CONFIGURATIONP (o1)) + return scm_from_bool (compare_window_configurations (o1, o2, 0)); + + /* Aside from them, only true vectors, char-tables, compiled + functions, and fonts (font-spec, font-entity, font-object) are + sensible to compare, so eliminate the others now. */ + if (size & PSEUDOVECTOR_FLAG) + { + if (((size & PVEC_TYPE_MASK) >> PSEUDOVECTOR_AREA_BITS) + < PVEC_COMPILED) + return SCM_BOOL_F; + size &= PSEUDOVECTOR_SIZE_MASK; } + for (i = 0; i < size; i++) + { + Lisp_Object v1, v2; + v1 = AREF (o1, i); + v2 = AREF (o2, i); + if (scm_is_false (scm_equal_p (v1, v2))) + return SCM_BOOL_F; + } + return SCM_BOOL_T; +} - return 0; +static SCM +string_equal_p (SCM o1, SCM o2) +{ + if (SCHARS (o1) != SCHARS (o2)) + return SCM_BOOL_F; + if (SBYTES (o1) != SBYTES (o2)) + return SCM_BOOL_F; + if (memcmp (SDATA (o1), SDATA (o2), SBYTES (o1))) + return SCM_BOOL_F; + if (scm_is_true (scm_fluid_ref (compare_text_properties)) + && !compare_string_intervals (o1, o2)) + return SCM_BOOL_F; + return SCM_BOOL_T; } @@ -2163,20 +2175,7 @@ ARRAY is a vector, string, char-table, or bool-vector. */) p[idx] = charval; } else if (BOOL_VECTOR_P (array)) - { - register unsigned char *p = XBOOL_VECTOR (array)->data; - size = - ((XBOOL_VECTOR (array)->size + BOOL_VECTOR_BITS_PER_CHAR - 1) - / BOOL_VECTOR_BITS_PER_CHAR); - - if (size) - { - memset (p, ! NILP (item) ? -1 : 0, size); - - /* Clear any extraneous bits in the last byte. */ - p[size - 1] &= (1 << (size % BOOL_VECTOR_BITS_PER_CHAR)) - 1; - } - } + return bool_vector_fill (array, item); else wrong_type_argument (Qarrayp, array); return array; @@ -2288,10 +2287,7 @@ mapcar1 (EMACS_INT leni, Lisp_Object *vals, Lisp_Object fn, Lisp_Object seq) { for (i = 0; i < leni; i++) { - unsigned char byte; - byte = XBOOL_VECTOR (seq)->data[i / BOOL_VECTOR_BITS_PER_CHAR]; - dummy = (byte & (1 << (i % BOOL_VECTOR_BITS_PER_CHAR))) ? Qt : Qnil; - dummy = call1 (fn, dummy); + dummy = call1 (fn, bool_vector_ref (seq, i)); if (vals) vals[i] = dummy; } @@ -2425,15 +2421,16 @@ do_yes_or_no_p (Lisp_Object prompt) /* Anything that calls this function must protect from GC! */ DEFUN ("yes-or-no-p", Fyes_or_no_p, Syes_or_no_p, 1, 1, 0, - doc: /* Ask user a yes-or-no question. Return t if answer is yes. + doc: /* Ask user a yes-or-no question. +Return t if answer is yes, and nil if the answer is no. PROMPT is the string to display to ask the question. It should end in a space; `yes-or-no-p' adds \"(yes or no) \" to it. The user must confirm the answer with RET, and can edit it until it has been confirmed. -Under a windowing system a dialog box will be used if `last-nonmenu-event' -is nil, and `use-dialog-box' is non-nil. */) +If dialog boxes are supported, a dialog box will be used +if `last-nonmenu-event' is nil, and `use-dialog-box' is non-nil. */) (Lisp_Object prompt) { register Lisp_Object ans; @@ -2442,23 +2439,19 @@ is nil, and `use-dialog-box' is non-nil. */) CHECK_STRING (prompt); -#ifdef HAVE_MENUS if ((NILP (last_nonmenu_event) || CONSP (last_nonmenu_event)) - && use_dialog_box - && window_system_available (SELECTED_FRAME ())) + && use_dialog_box) { Lisp_Object pane, menu, obj; redisplay_preserve_echo_area (4); - pane = Fcons (Fcons (build_string ("Yes"), Qt), - Fcons (Fcons (build_string ("No"), Qnil), - Qnil)); + pane = list2 (Fcons (build_string ("Yes"), Qt), + Fcons (build_string ("No"), Qnil)); GCPRO1 (pane); menu = Fcons (prompt, pane); obj = Fx_popup_dialog (Qt, menu, Qnil); UNGCPRO; return obj; } -#endif /* HAVE_MENUS */ args[0] = prompt; args[1] = build_string ("(yes or no) "); @@ -2545,6 +2538,8 @@ SUBFEATURE can be used to check a specific subfeature of FEATURE. */) return (NILP (tem)) ? Qnil : Qt; } +static Lisp_Object Qfuncall; + DEFUN ("provide", Fprovide, Sprovide, 1, 2, 0, doc: /* Announce that FEATURE is a feature of the current Emacs. The optional argument SUBFEATURES should be a list of symbols listing @@ -2567,7 +2562,7 @@ particular subfeatures supported in this version of FEATURE. */) /* Run any load-hooks for this file. */ tem = Fassq (feature, Vafter_load_alist); if (CONSP (tem)) - Fprogn (XCDR (tem)); + Fmapc (Qfuncall, XCDR (tem)); return feature; } @@ -2578,10 +2573,10 @@ particular subfeatures supported in this version of FEATURE. */) static Lisp_Object require_nesting_list; -static Lisp_Object +static void require_unwind (Lisp_Object old_value) { - return require_nesting_list = old_value; + require_nesting_list = old_value; } DEFUN ("require", Frequire, Srequire, 1, 3, 0, @@ -2623,7 +2618,7 @@ The normal messages at start and end of loading FILENAME are suppressed. */) if (NILP (tem)) { - ptrdiff_t count = SPECPDL_INDEX (); + dynwind_begin (); int nesting = 0; /* This is to make sure that loadup.el gives a clear picture @@ -2661,8 +2656,11 @@ The normal messages at start and end of loading FILENAME are suppressed. */) UNGCPRO; /* If load failed entirely, return nil. */ - if (NILP (tem)) - return unbind_to (count, Qnil); + if (NILP (tem)){ + + dynwind_end (); + return Qnil; + } tem = Fmemq (feature, Vfeatures); if (NILP (tem)) @@ -2671,7 +2669,7 @@ The normal messages at start and end of loading FILENAME are suppressed. */) /* Once loading finishes, don't undo it. */ Vautoload_queue = Qt; - feature = unbind_to (count, feature); + dynwind_end (); } return feature; @@ -3328,14 +3326,10 @@ base64_decode_1 (const char *from, char *to, ptrdiff_t length, key_and_value vector of the hash table. This could be done if a `:linear-search t' argument is given to make-hash-table. */ - -/* The list of all weak hash tables. Don't staticpro this one. */ - -static struct Lisp_Hash_Table *weak_hash_tables; - /* Various symbols. */ -static Lisp_Object Qhash_table_p, Qkey, Qvalue, Qeql; +static Lisp_Object Qhash_table_p; +static Lisp_Object Qkey, Qvalue, Qeql; Lisp_Object Qeq, Qequal; Lisp_Object QCtest, QCsize, QCrehash_size, QCrehash_threshold, QCweakness; static Lisp_Object Qhash_table_test, Qkey_or_value, Qkey_and_value; @@ -3345,6 +3339,48 @@ static Lisp_Object Qhash_table_test, Qkey_or_value, Qkey_and_value; Utilities ***********************************************************************/ +static void +CHECK_HASH_TABLE (Lisp_Object x) +{ + CHECK_TYPE (HASH_TABLE_P (x), Qhash_table_p, x); +} + +static void +set_hash_key_and_value (struct Lisp_Hash_Table *h, Lisp_Object key_and_value) +{ + h->key_and_value = key_and_value; +} +static void +set_hash_next (struct Lisp_Hash_Table *h, Lisp_Object next) +{ + h->next = next; +} +static void +set_hash_next_slot (struct Lisp_Hash_Table *h, ptrdiff_t idx, Lisp_Object val) +{ + gc_aset (h->next, idx, val); +} +static void +set_hash_hash (struct Lisp_Hash_Table *h, Lisp_Object hash) +{ + h->hash = hash; +} +static void +set_hash_hash_slot (struct Lisp_Hash_Table *h, ptrdiff_t idx, Lisp_Object val) +{ + gc_aset (h->hash, idx, val); +} +static void +set_hash_index (struct Lisp_Hash_Table *h, Lisp_Object index) +{ + h->index = index; +} +static void +set_hash_index_slot (struct Lisp_Hash_Table *h, ptrdiff_t idx, Lisp_Object val) +{ + gc_aset (h->index, idx, val); +} + /* If OBJ is a Lisp hash table, return a pointer to its struct Lisp_Hash_Table. Otherwise, signal an error. */ @@ -3484,8 +3520,7 @@ cmpfn_user_defined (struct hash_table_test *ht, static EMACS_UINT hashfn_eq (struct hash_table_test *ht, Lisp_Object key) { - EMACS_UINT hash = XHASH (key) ^ XTYPE (key); - return hash; + return scm_ihashq (key, MOST_POSITIVE_FIXNUM); } /* Value is a hash code for KEY for use in hash table H which uses @@ -3495,12 +3530,7 @@ hashfn_eq (struct hash_table_test *ht, Lisp_Object key) static EMACS_UINT hashfn_eql (struct hash_table_test *ht, Lisp_Object key) { - EMACS_UINT hash; - if (FLOATP (key)) - hash = sxhash (key, 0); - else - hash = XHASH (key) ^ XTYPE (key); - return hash; + return scm_ihashv (key, MOST_POSITIVE_FIXNUM); } /* Value is a hash code for KEY for use in hash table H which uses @@ -3510,8 +3540,7 @@ hashfn_eql (struct hash_table_test *ht, Lisp_Object key) static EMACS_UINT hashfn_equal (struct hash_table_test *ht, Lisp_Object key) { - EMACS_UINT hash = sxhash (key, 0); - return hash; + return scm_ihash (key, MOST_POSITIVE_FIXNUM); } /* Value is a hash code for KEY for use in hash table H which uses as @@ -3526,9 +3555,7 @@ hashfn_user_defined (struct hash_table_test *ht, Lisp_Object key) args[0] = ht->user_hash_function; args[1] = key; hash = Ffuncall (2, args); - if (!INTEGERP (hash)) - signal_error ("Invalid hash code returned from user-supplied hash function", hash); - return XUINT (hash); + return hashfn_eq (ht, hash); } /* An upper bound on the size of a hash table index. It must fit in @@ -3612,15 +3639,6 @@ make_hash_table (struct hash_table_test test, eassert (HASH_TABLE_P (table)); eassert (XHASH_TABLE (table) == h); - /* Maybe add this hash table to the list of all weak hash tables. */ - if (NILP (h->weak)) - h->next_weak = NULL; - else - { - h->next_weak = weak_hash_tables; - weak_hash_tables = h; - } - return table; } @@ -3642,13 +3660,6 @@ copy_hash_table (struct Lisp_Hash_Table *h1) h2->index = Fcopy_sequence (h1->index); XSET_HASH_TABLE (table, h2); - /* Maybe add this hash table to the list of all weak hash tables. */ - if (!NILP (h2->weak)) - { - h2->next_weak = weak_hash_tables; - weak_hash_tables = h2; - } - return table; } @@ -3884,163 +3895,10 @@ hash_clear (struct Lisp_Hash_Table *h) -/************************************************************************ - Weak Hash Tables - ************************************************************************/ - -/* Sweep weak hash table H. REMOVE_ENTRIES_P means remove - entries from the table that don't survive the current GC. - !REMOVE_ENTRIES_P means mark entries that are in use. Value is - true if anything was marked. */ - -static bool -sweep_weak_table (struct Lisp_Hash_Table *h, bool remove_entries_p) -{ - ptrdiff_t bucket, n; - bool marked; - - n = ASIZE (h->index) & ~ARRAY_MARK_FLAG; - marked = 0; - - for (bucket = 0; bucket < n; ++bucket) - { - Lisp_Object idx, next, prev; - - /* Follow collision chain, removing entries that - don't survive this garbage collection. */ - prev = Qnil; - for (idx = HASH_INDEX (h, bucket); !NILP (idx); idx = next) - { - ptrdiff_t i = XFASTINT (idx); - bool key_known_to_survive_p = survives_gc_p (HASH_KEY (h, i)); - bool value_known_to_survive_p = survives_gc_p (HASH_VALUE (h, i)); - bool remove_p; - - if (EQ (h->weak, Qkey)) - remove_p = !key_known_to_survive_p; - else if (EQ (h->weak, Qvalue)) - remove_p = !value_known_to_survive_p; - else if (EQ (h->weak, Qkey_or_value)) - remove_p = !(key_known_to_survive_p || value_known_to_survive_p); - else if (EQ (h->weak, Qkey_and_value)) - remove_p = !(key_known_to_survive_p && value_known_to_survive_p); - else - emacs_abort (); - - next = HASH_NEXT (h, i); - - if (remove_entries_p) - { - if (remove_p) - { - /* Take out of collision chain. */ - if (NILP (prev)) - set_hash_index_slot (h, bucket, next); - else - set_hash_next_slot (h, XFASTINT (prev), next); - - /* Add to free list. */ - set_hash_next_slot (h, i, h->next_free); - h->next_free = idx; - - /* Clear key, value, and hash. */ - set_hash_key_slot (h, i, Qnil); - set_hash_value_slot (h, i, Qnil); - set_hash_hash_slot (h, i, Qnil); - - h->count--; - } - else - { - prev = idx; - } - } - else - { - if (!remove_p) - { - /* Make sure key and value survive. */ - if (!key_known_to_survive_p) - { - mark_object (HASH_KEY (h, i)); - marked = 1; - } - - if (!value_known_to_survive_p) - { - mark_object (HASH_VALUE (h, i)); - marked = 1; - } - } - } - } - } - - return marked; -} - -/* Remove elements from weak hash tables that don't survive the - current garbage collection. Remove weak tables that don't survive - from Vweak_hash_tables. Called from gc_sweep. */ - -void -sweep_weak_hash_tables (void) -{ - struct Lisp_Hash_Table *h, *used, *next; - bool marked; - - /* Mark all keys and values that are in use. Keep on marking until - there is no more change. This is necessary for cases like - value-weak table A containing an entry X -> Y, where Y is used in a - key-weak table B, Z -> Y. If B comes after A in the list of weak - tables, X -> Y might be removed from A, although when looking at B - one finds that it shouldn't. */ - do - { - marked = 0; - for (h = weak_hash_tables; h; h = h->next_weak) - { - if (h->header.size & ARRAY_MARK_FLAG) - marked |= sweep_weak_table (h, 0); - } - } - while (marked); - - /* Remove tables and entries that aren't used. */ - for (h = weak_hash_tables, used = NULL; h; h = next) - { - next = h->next_weak; - - if (h->header.size & ARRAY_MARK_FLAG) - { - /* TABLE is marked as used. Sweep its contents. */ - if (h->count > 0) - sweep_weak_table (h, 1); - - /* Add table to the list of used weak hash tables. */ - h->next_weak = used; - used = h; - } - } - - weak_hash_tables = used; -} - - - /*********************************************************************** Hash Code Computation ***********************************************************************/ -/* Maximum depth up to which to dive into Lisp structures. */ - -#define SXHASH_MAX_DEPTH 3 - -/* Maximum length up to which to take list and vector elements into - account. */ - -#define SXHASH_MAX_LEN 7 - /* Return a hash for string PTR which has length LEN. The hash value can be any EMACS_UINT value. */ @@ -4061,159 +3919,13 @@ hash_string (char const *ptr, ptrdiff_t len) return hash; } -/* Return a hash for string PTR which has length LEN. The hash - code returned is guaranteed to fit in a Lisp integer. */ - -static EMACS_UINT -sxhash_string (char const *ptr, ptrdiff_t len) -{ - EMACS_UINT hash = hash_string (ptr, len); - return SXHASH_REDUCE (hash); -} - -/* Return a hash for the floating point value VAL. */ - -static EMACS_UINT -sxhash_float (double val) -{ - EMACS_UINT hash = 0; - enum { - WORDS_PER_DOUBLE = (sizeof val / sizeof hash - + (sizeof val % sizeof hash != 0)) - }; - union { - double val; - EMACS_UINT word[WORDS_PER_DOUBLE]; - } u; - int i; - u.val = val; - memset (&u.val + 1, 0, sizeof u - sizeof u.val); - for (i = 0; i < WORDS_PER_DOUBLE; i++) - hash = sxhash_combine (hash, u.word[i]); - return SXHASH_REDUCE (hash); -} - -/* Return a hash for list LIST. DEPTH is the current depth in the - list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */ - -static EMACS_UINT -sxhash_list (Lisp_Object list, int depth) -{ - EMACS_UINT hash = 0; - int i; - - if (depth < SXHASH_MAX_DEPTH) - for (i = 0; - CONSP (list) && i < SXHASH_MAX_LEN; - list = XCDR (list), ++i) - { - EMACS_UINT hash2 = sxhash (XCAR (list), depth + 1); - hash = sxhash_combine (hash, hash2); - } - - if (!NILP (list)) - { - EMACS_UINT hash2 = sxhash (list, depth + 1); - hash = sxhash_combine (hash, hash2); - } - - return SXHASH_REDUCE (hash); -} - - -/* Return a hash for vector VECTOR. DEPTH is the current depth in - the Lisp structure. */ - -static EMACS_UINT -sxhash_vector (Lisp_Object vec, int depth) -{ - EMACS_UINT hash = ASIZE (vec); - int i, n; - - n = min (SXHASH_MAX_LEN, ASIZE (vec)); - for (i = 0; i < n; ++i) - { - EMACS_UINT hash2 = sxhash (AREF (vec, i), depth + 1); - hash = sxhash_combine (hash, hash2); - } - - return SXHASH_REDUCE (hash); -} - -/* Return a hash for bool-vector VECTOR. */ - -static EMACS_UINT -sxhash_bool_vector (Lisp_Object vec) -{ - EMACS_UINT hash = XBOOL_VECTOR (vec)->size; - int i, n; - - n = min (SXHASH_MAX_LEN, XBOOL_VECTOR (vec)->header.size); - for (i = 0; i < n; ++i) - hash = sxhash_combine (hash, XBOOL_VECTOR (vec)->data[i]); - - return SXHASH_REDUCE (hash); -} - - /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp structure. Value is an unsigned integer clipped to INTMASK. */ EMACS_UINT sxhash (Lisp_Object obj, int depth) { - EMACS_UINT hash; - - if (depth > SXHASH_MAX_DEPTH) - return 0; - - switch (XTYPE (obj)) - { - case_Lisp_Int: - hash = XUINT (obj); - break; - - case Lisp_Misc: - hash = XHASH (obj); - break; - - case Lisp_Symbol: - obj = SYMBOL_NAME (obj); - /* Fall through. */ - - case Lisp_String: - hash = sxhash_string (SSDATA (obj), SBYTES (obj)); - break; - - /* This can be everything from a vector to an overlay. */ - case Lisp_Vectorlike: - if (VECTORP (obj)) - /* According to the CL HyperSpec, two arrays are equal only if - they are `eq', except for strings and bit-vectors. In - Emacs, this works differently. We have to compare element - by element. */ - hash = sxhash_vector (obj, depth); - else if (BOOL_VECTOR_P (obj)) - hash = sxhash_bool_vector (obj); - else - /* Others are `equal' if they are `eq', so let's take their - address as hash. */ - hash = XHASH (obj); - break; - - case Lisp_Cons: - hash = sxhash_list (obj, depth); - break; - - case Lisp_Float: - hash = sxhash_float (XFLOAT_DATA (obj)); - break; - - default: - emacs_abort (); - } - - return hash; + return scm_ihash (obj, MOST_POSITIVE_FIXNUM); } @@ -4468,7 +4180,8 @@ DEFUN ("remhash", Fremhash, Sremhash, 2, 2, 0, DEFUN ("maphash", Fmaphash, Smaphash, 2, 2, 0, doc: /* Call FUNCTION for all entries in hash table TABLE. -FUNCTION is called with two arguments, KEY and VALUE. */) +FUNCTION is called with two arguments, KEY and VALUE. +`maphash' always returns nil. */) (Lisp_Object function, Lisp_Object table) { struct Lisp_Hash_Table *h = check_hash_table (table); @@ -4497,9 +4210,9 @@ compare keys, and HASH for computing hash codes of keys. TEST must be a function taking two arguments and returning non-nil if both arguments are the same. HASH must be a function taking one -argument and return an integer that is the hash code of the argument. -Hash code computation should use the whole value range of integers, -including negative integers. */) +argument and returning an object that is the hash code of the argument. +It should be the case that if (eq (funcall HASH x1) (funcall HASH x2)) +returns nil, then (funcall TEST x1 x2) also returns nil. */) (Lisp_Object name, Lisp_Object test, Lisp_Object hash) { return Fput (name, Qhash_table_test, list2 (test, hash)); @@ -4519,12 +4232,12 @@ including negative integers. */) /* ALGORITHM is a symbol: md5, sha1, sha224 and so on. */ static Lisp_Object -secure_hash (Lisp_Object algorithm, Lisp_Object object, Lisp_Object start, Lisp_Object end, Lisp_Object coding_system, Lisp_Object noerror, Lisp_Object binary) +secure_hash (Lisp_Object algorithm, Lisp_Object object, Lisp_Object start, + Lisp_Object end, Lisp_Object coding_system, Lisp_Object noerror, + Lisp_Object binary) { int i; - ptrdiff_t size; - EMACS_INT start_char = 0, end_char = 0; - ptrdiff_t start_byte, end_byte; + ptrdiff_t size, start_char = 0, start_byte, end_char = 0, end_byte; register EMACS_INT b, e; register struct buffer *bp; EMACS_INT temp; @@ -4561,40 +4274,16 @@ secure_hash (Lisp_Object algorithm, Lisp_Object object, Lisp_Object start, Lisp_ object = code_convert_string (object, coding_system, Qnil, 1, 0, 1); size = SCHARS (object); + validate_subarray (object, start, end, size, &start_char, &end_char); - if (!NILP (start)) - { - CHECK_NUMBER (start); - - start_char = XINT (start); - - if (start_char < 0) - start_char += size; - } - - if (NILP (end)) - end_char = size; - else - { - CHECK_NUMBER (end); - - end_char = XINT (end); - - if (end_char < 0) - end_char += size; - } - - if (!(0 <= start_char && start_char <= end_char && end_char <= size)) - args_out_of_range_3 (object, make_number (start_char), - make_number (end_char)); - - start_byte = NILP (start) ? 0 : string_char_to_byte (object, start_char); - end_byte = - NILP (end) ? SBYTES (object) : string_char_to_byte (object, end_char); + start_byte = !start_char ? 0 : string_char_to_byte (object, start_char); + end_byte = (end_char == size + ? SBYTES (object) + : string_char_to_byte (object, end_char)); } else { - struct buffer *prev = current_buffer; + dynwind_begin (); record_unwind_current_buffer (); @@ -4688,10 +4377,7 @@ secure_hash (Lisp_Object algorithm, Lisp_Object object, Lisp_Object start, Lisp_ } object = make_buffer_string (b, e, 0); - set_buffer_internal (prev); - /* Discard the unwind protect for recovering the current - buffer. */ - specpdl_ptr--; + dynwind_end (); if (STRING_MULTIBYTE (object)) object = code_convert_string (object, coding_system, Qnil, 1, 0, 0); @@ -4803,9 +4489,20 @@ If BINARY is non-nil, returns a string in binary form. */) return secure_hash (algorithm, object, start, end, Qnil, Qnil, binary); } +void +init_fns_once (void) +{ + compare_text_properties = scm_make_fluid (); + scm_set_smob_equalp (lisp_misc_tag, misc_equal_p); + scm_set_smob_equalp (lisp_string_tag, string_equal_p); + scm_set_smob_equalp (lisp_vectorlike_tag, vectorlike_equal_p); +} + void syms_of_fns (void) { +#include "fns.x" + DEFSYM (Qmd5, "md5"); DEFSYM (Qsha1, "sha1"); DEFSYM (Qsha224, "sha224"); @@ -4829,23 +4526,6 @@ syms_of_fns (void) DEFSYM (Qkey_or_value, "key-or-value"); DEFSYM (Qkey_and_value, "key-and-value"); - defsubr (&Ssxhash); - defsubr (&Smake_hash_table); - defsubr (&Scopy_hash_table); - defsubr (&Shash_table_count); - defsubr (&Shash_table_rehash_size); - defsubr (&Shash_table_rehash_threshold); - defsubr (&Shash_table_size); - defsubr (&Shash_table_test); - defsubr (&Shash_table_weakness); - defsubr (&Shash_table_p); - defsubr (&Sclrhash); - defsubr (&Sgethash); - defsubr (&Sputhash); - defsubr (&Sremhash); - defsubr (&Smaphash); - defsubr (&Sdefine_hash_table_test); - DEFSYM (Qstring_lessp, "string-lessp"); DEFSYM (Qprovide, "provide"); DEFSYM (Qrequire, "require"); @@ -4864,8 +4544,9 @@ syms_of_fns (void) DEFVAR_LISP ("features", Vfeatures, doc: /* A list of symbols which are the features of the executing Emacs. Used by `featurep' and `require', and altered by `provide'. */); - Vfeatures = Fcons (intern_c_string ("emacs"), Qnil); + Vfeatures = list1 (intern_c_string ("emacs")); DEFSYM (Qsubfeatures, "subfeatures"); + DEFSYM (Qfuncall, "funcall"); #ifdef HAVE_LANGINFO_CODESET DEFSYM (Qcodeset, "codeset"); @@ -4891,81 +4572,21 @@ that disables the use of a file dialog, regardless of the value of this variable. */); use_file_dialog = 1; - defsubr (&Sidentity); - defsubr (&Srandom); - defsubr (&Slength); - defsubr (&Ssafe_length); - defsubr (&Sstring_bytes); - defsubr (&Sstring_equal); - defsubr (&Scompare_strings); - defsubr (&Sstring_lessp); - defsubr (&Sappend); - defsubr (&Sconcat); - defsubr (&Svconcat); - defsubr (&Scopy_sequence); - defsubr (&Sstring_make_multibyte); - defsubr (&Sstring_make_unibyte); - defsubr (&Sstring_as_multibyte); - defsubr (&Sstring_as_unibyte); - defsubr (&Sstring_to_multibyte); - defsubr (&Sstring_to_unibyte); - defsubr (&Scopy_alist); - defsubr (&Ssubstring); - defsubr (&Ssubstring_no_properties); - defsubr (&Snthcdr); - defsubr (&Snth); - defsubr (&Selt); - defsubr (&Smember); - defsubr (&Smemq); - defsubr (&Smemql); - 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 (&Slax_plist_get); - defsubr (&Slax_plist_put); - defsubr (&Seql); - defsubr (&Sequal); - defsubr (&Sequal_including_properties); - defsubr (&Sfillarray); - defsubr (&Sclear_string); - defsubr (&Snconc); - defsubr (&Smapcar); - defsubr (&Smapc); - defsubr (&Smapconcat); - defsubr (&Syes_or_no_p); - defsubr (&Sload_average); - defsubr (&Sfeaturep); - defsubr (&Srequire); - defsubr (&Sprovide); - defsubr (&Splist_member); - defsubr (&Swidget_put); - defsubr (&Swidget_get); - defsubr (&Swidget_apply); - defsubr (&Sbase64_encode_region); - defsubr (&Sbase64_decode_region); - defsubr (&Sbase64_encode_string); - defsubr (&Sbase64_decode_string); - defsubr (&Smd5); - defsubr (&Ssecure_hash); - defsubr (&Slocale_info); - - { - struct hash_table_test - eq = { Qeq, Qnil, Qnil, NULL, hashfn_eq }, - eql = { Qeql, Qnil, Qnil, cmpfn_eql, hashfn_eql }, - equal = { Qequal, Qnil, Qnil, cmpfn_equal, hashfn_equal }; - hashtest_eq = eq; - hashtest_eql = eql; - hashtest_equal = equal; - } + hashtest_eq.name = Qeq; + hashtest_eq.user_hash_function = Qnil; + hashtest_eq.user_cmp_function = Qnil; + hashtest_eq.cmpfn = 0; + hashtest_eq.hashfn = hashfn_eq; + + hashtest_eql.name = Qeql; + hashtest_eql.user_hash_function = Qnil; + hashtest_eql.user_cmp_function = Qnil; + hashtest_eql.cmpfn = cmpfn_eql; + hashtest_eql.hashfn = hashfn_eql; + + hashtest_equal.name = Qequal; + hashtest_equal.user_hash_function = Qnil; + hashtest_equal.user_cmp_function = Qnil; + hashtest_equal.cmpfn = cmpfn_equal; + hashtest_equal.hashfn = hashfn_equal; }