X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/536aa4668198bf4851356a8e3a57b7f8969014c3..989973023dd4592c3713b67d786e7353f4981221:/src/fns.c diff --git a/src/fns.c b/src/fns.c index 53819ed23a..01a1ea761d 100644 --- a/src/fns.c +++ b/src/fns.c @@ -48,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, Lisp_Object); DEFUN ("identity", Fidentity, Sidentity, 1, 1, 0, doc: /* Return the argument unchanged. */) @@ -232,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 @@ -244,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) @@ -322,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; } @@ -372,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 @@ -382,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 */ @@ -393,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, @@ -404,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, @@ -414,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, @@ -424,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); } @@ -450,10 +420,14 @@ with the original. */) 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, XTYPE (arg), 0); } /* This structure holds information of an argument of `concat' that is @@ -467,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; @@ -522,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. */ @@ -584,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); @@ -594,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. */ @@ -1089,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) @@ -1100,6 +1074,23 @@ an error is signaled. */) return string; } +DEFUN ("string-to-scheme", Fstring_to_scheme, Sstring_to_scheme, 1, 1, 0, 0) + (Lisp_Object string) +{ + CHECK_STRING (string); + return scm_from_utf8_stringn (SSDATA (string), SBYTES (string)); +} + +DEFUN ("string-from-scheme", Fstring_from_scheme, Sstring_from_scheme, 1, 1, 0, 0) + (Lisp_Object string) +{ + char *s; + size_t lenp; + + CHECK_STRING (string); + s = scm_to_utf8_stringn (string, &lenp); + return make_string (s, lenp); +} DEFUN ("copy-alist", Fcopy_alist, Scopy_alist, 1, 1, 0, doc: /* Return a copy of ALIST. @@ -1115,7 +1106,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; @@ -1133,9 +1124,9 @@ Elements of ALIST that are not conses are also shared. */) Count negative values backwards from the end. Set *IFROM and *ITO to the two indexes used. */ -static void +void validate_subarray (Lisp_Object array, Lisp_Object from, Lisp_Object to, - ptrdiff_t size, EMACS_INT *ifrom, EMACS_INT *ito) + ptrdiff_t size, ptrdiff_t *ifrom, ptrdiff_t *ito) { EMACS_INT f, t; @@ -1184,8 +1175,7 @@ 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 ifrom, ito; + ptrdiff_t size, ifrom, ito; if (STRINGP (string)) size = SCHARS (string); @@ -1225,9 +1215,7 @@ 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); @@ -1361,15 +1349,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, Qnil)) + if (!NILP (Feql (elt, tem))) return tail; QUIT; } @@ -1697,40 +1682,121 @@ 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); + } + } + 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); + } } - return prev; + 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; } @@ -1857,7 +1923,7 @@ This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */) (Lisp_Object symbol, Lisp_Object propname) { CHECK_SYMBOL (symbol); - return Fplist_get (XSYMBOL (symbol)->plist, propname); + return Fplist_get (symbol_plist (symbol), propname); } DEFUN ("plist-put", Fplist_put, Splist_put, 3, 3, 0, @@ -1900,7 +1966,7 @@ It can be retrieved with `(get SYMBOL PROPNAME)'. */) { CHECK_SYMBOL (symbol); set_symbol_plist - (symbol, Fplist_put (XSYMBOL (symbol)->plist, propname, value)); + (symbol, Fplist_put (symbol_plist (symbol), propname, value)); return value; } @@ -1967,10 +2033,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, Qnil) ? 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, @@ -1983,170 +2046,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, Qnil) ? 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, Qnil) ? 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. */ + dynwind_begin (); + scm_dynwind_fluid (compare_text_properties, SCM_BOOL_T); + tem = Fequal (o1, o2); + dynwind_end (); + return tem; +} -static bool -internal_equal (Lisp_Object o1, Lisp_Object o2, int depth, bool props, - Lisp_Object ht) +static SCM +misc_equal_p (SCM o1, SCM o2) { - if (depth > 10) + if (XMISCTYPE (o1) != XMISCTYPE (o2)) + return SCM_BOOL_F; + if (OVERLAYP (o1)) { - if (depth > 200) - error ("Stack overflow in equal"); - if (NILP (ht)) - { - Lisp_Object args[2]; - args[0] = QCtest; - args[1] = Qeq; - ht = Fmake_hash_table (2, args); - } - switch (XTYPE (o1)) - { - case Lisp_Cons: case Lisp_Misc: case Lisp_Vectorlike: - { - struct Lisp_Hash_Table *h = XHASH_TABLE (ht); - EMACS_UINT hash; - ptrdiff_t i = hash_lookup (h, o1, &hash); - if (i >= 0) - { /* `o1' was seen already. */ - Lisp_Object o2s = HASH_VALUE (h, i); - if (!NILP (Fmemq (o2, o2s))) - return 1; - else - set_hash_value_slot (h, i, Fcons (o2, o2s)); - } - else - hash_put (h, o1, Fcons (o2, Qnil), hash); - } - default: ; - } + 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); } - - tail_recurse: - QUIT; - if (EQ (o1, o2)) - return 1; - if (XTYPE (o1) != XTYPE (o2)) - return 0; - - switch (XTYPE (o1)) + if (MARKERP (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, ht)) - return 0; - o1 = XCDR (o1); - o2 = XCDR (o2); - /* FIXME: This inf-loops in a circular list! */ - 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, ht) - || !internal_equal (OVERLAY_END (o1), OVERLAY_END (o2), - depth + 1, props, ht)) - 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)) - { - EMACS_INT size = bool_vector_size (o1); - if (size != bool_vector_size (o2)) - return 0; - if (memcmp (bool_vector_data (o1), bool_vector_data (o2), - bool_vector_bytes (size))) - return 0; - return 1; - } - if (WINDOW_CONFIGURATIONP (o1)) - return compare_window_configurations (o1, o2, 0); + 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, ht)) - 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; } @@ -2635,7 +2635,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 @@ -2673,8 +2673,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)) @@ -2683,7 +2686,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; @@ -2757,16 +2760,13 @@ usage: (widget-apply WIDGET PROPERTY &rest ARGS) */) (ptrdiff_t nargs, Lisp_Object *args) { /* This function can GC. */ - Lisp_Object newargs[3]; struct gcpro gcpro1, gcpro2; Lisp_Object result; - newargs[0] = Fwidget_get (args[0], args[1]); - newargs[1] = args[0]; - newargs[2] = Flist (nargs - 2, args + 2); - GCPRO2 (newargs[0], newargs[2]); - result = Fapply (3, newargs); - UNGCPRO; + result = call3 (intern ("apply"), + Fwidget_get (args[0], args[1]), + args[0], + Flist (nargs - 2, args + 2)); return result; } @@ -3340,11 +3340,6 @@ 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; @@ -3539,8 +3534,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 @@ -3550,12 +3544,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 @@ -3565,8 +3554,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 @@ -3665,15 +3653,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; } @@ -3695,13 +3674,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; } @@ -3937,164 +3909,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. */ - -NO_INLINE /* For better stack traces */ -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. */ @@ -4115,160 +3933,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_INT size = bool_vector_size (vec); - EMACS_UINT hash = size; - int i, n; - - n = min (SXHASH_MAX_LEN, bool_vector_words (size)); - for (i = 0; i < n; ++i) - hash = sxhash_combine (hash, bool_vector_data (vec)[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); } @@ -4575,12 +4246,12 @@ returns nil, then (funcall TEST x1 x2) also returns nil. */) /* 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; @@ -4626,7 +4297,7 @@ secure_hash (Lisp_Object algorithm, Lisp_Object object, Lisp_Object start, Lisp_ } else { - struct buffer *prev = current_buffer; + dynwind_begin (); record_unwind_current_buffer (); @@ -4720,10 +4391,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); @@ -4835,9 +4503,33 @@ If BINARY is non-nil, returns a string in binary form. */) return secure_hash (algorithm, object, start, end, Qnil, Qnil, binary); } +DEFUN ("eval-scheme", Feval_scheme, Seval_scheme, 1, 1, + "sEval Scheme: ", + doc: /* Evaluate a string containing a Scheme expression. */) + (Lisp_Object string) +{ + Lisp_Object tem; + + CHECK_STRING (string); + + tem = scm_c_eval_string (SSDATA (string)); + return (INTERACTIVE ? Fprin1 (tem, Qt) : tem); +} + +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"); @@ -4861,23 +4553,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"); @@ -4924,74 +4599,6 @@ 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); - hashtest_eq.name = Qeq; hashtest_eq.user_hash_function = Qnil; hashtest_eq.user_cmp_function = Qnil;