X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/51e12e8e9411e5d050c36ef6d8777445a5497972..989973023dd4592c3713b67d786e7353f4981221:/src/fns.c diff --git a/src/fns.c b/src/fns.c index 9bc854a9c7..01a1ea761d 100644 --- a/src/fns.c +++ b/src/fns.c @@ -48,9 +48,7 @@ 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. */) (Lisp_Object arg) @@ -268,21 +266,8 @@ If string STR1 is greater, the value is a positive number N; 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; @@ -350,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 @@ -360,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 */ @@ -371,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, @@ -382,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, @@ -392,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, @@ -402,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); } @@ -428,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 @@ -445,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; @@ -500,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. */ @@ -562,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); @@ -572,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. */ @@ -1067,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) @@ -1078,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. @@ -1093,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; @@ -1336,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; } @@ -1913,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, @@ -1956,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; } @@ -2023,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, @@ -2039,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; } @@ -2691,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 @@ -2729,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)) @@ -2739,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; @@ -2813,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; } @@ -3396,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; @@ -3595,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 @@ -3606,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 @@ -3621,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 @@ -3721,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; } @@ -3751,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; } @@ -3993,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. */ @@ -4171,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); } @@ -4682,7 +4297,7 @@ secure_hash (Lisp_Object algorithm, Lisp_Object object, Lisp_Object start, } else { - struct buffer *prev = current_buffer; + dynwind_begin (); record_unwind_current_buffer (); @@ -4776,10 +4391,7 @@ secure_hash (Lisp_Object algorithm, Lisp_Object object, Lisp_Object start, } 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); @@ -4891,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"); @@ -4917,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"); @@ -4980,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;