Mercurial > hg > xemacs-beta
comparison tests/automated/lisp-tests.el @ 4906:6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
-------------------- ChangeLog entries follow: --------------------
lisp/ChangeLog addition:
2010-02-01 Ben Wing <ben@xemacs.org>
* cl-extra.el:
* cl-extra.el (cl-string-vector-equalp): Removed.
* cl-extra.el (cl-bit-vector-vector-equalp): Removed.
* cl-extra.el (cl-vector-array-equalp): Removed.
* cl-extra.el (cl-hash-table-contents-equalp): Removed.
* cl-extra.el (equalp): Removed.
* cl-extra.el (cl-mapcar-many):
Comment out the whole `equalp' implementation for the moment;
remove once we're sure the C implementation works.
* cl-macs.el:
* cl-macs.el (equalp):
Simplify the compiler-macro for `equalp' -- once it's in C,
we don't need to try so hard to expand it.
src/ChangeLog addition:
2010-02-01 Ben Wing <ben@xemacs.org>
* abbrev.c (abbrev_match_mapper):
* buffer.h (CANON_TABLE_OF):
* buffer.h:
* editfns.c (Fchar_equal):
* minibuf.c (scmp_1):
* text.c (qxestrcasecmp_i18n):
* text.c (qxestrncasecmp_i18n):
* text.c (qxetextcasecmp):
* text.c (qxetextcasecmp_matching):
Create new macro CANONCASE that converts to a canonical mapping
and use it to do caseless comparisons instead of DOWNCASE.
* alloc.c:
* alloc.c (cons_equal):
* alloc.c (vector_equal):
* alloc.c (string_equal):
* bytecode.c (compiled_function_equal):
* chartab.c (char_table_entry_equal):
* chartab.c (char_table_equal):
* data.c (weak_list_equal):
* data.c (weak_box_equal):
* data.c (ephemeron_equal):
* device-msw.c (equal_devmode):
* elhash.c (hash_table_equal):
* events.c (event_equal):
* extents.c (properties_equal):
* extents.c (extent_equal):
* faces.c:
* faces.c (face_equal):
* faces.c (face_hash):
* floatfns.c (float_equal):
* fns.c:
* fns.c (bit_vector_equal):
* fns.c (plists_differ):
* fns.c (Fplists_eq):
* fns.c (Fplists_equal):
* fns.c (Flax_plists_eq):
* fns.c (Flax_plists_equal):
* fns.c (internal_equal):
* fns.c (internal_equalp):
* fns.c (internal_equal_0):
* fns.c (syms_of_fns):
* glyphs.c (image_instance_equal):
* glyphs.c (glyph_equal):
* glyphs.c (glyph_hash):
* gui.c (gui_item_equal):
* lisp.h:
* lrecord.h (struct lrecord_implementation):
* marker.c (marker_equal):
* number.c (bignum_equal):
* number.c (ratio_equal):
* number.c (bigfloat_equal):
* objects.c (color_instance_equal):
* objects.c (font_instance_equal):
* opaque.c (equal_opaque):
* opaque.c (equal_opaque_ptr):
* rangetab.c (range_table_equal):
* specifier.c (specifier_equal):
Add a `foldcase' param to the equal() method and use it to implement
`equalp' comparisons. Also add to plists_differ(), although we
don't currently use it here.
Rewrite internal_equalp(). Implement cross-type vector comparisons.
Don't implement our own handling of numeric promotion -- just use
the `=' primitive.
Add internal_equal_0(), which takes a `foldcase' param and calls
either internal_equal() or internal_equalp().
* buffer.h:
When given a 0 for buffer (which is the norm when functions don't
have a specific buffer available), use the current buffer's table,
not `standard-case-table'; otherwise the current settings are
ignored.
* casetab.c:
* casetab.c (set_case_table):
When handling old-style vectors of 256 in `set-case-table' don't
overwrite the existing table! Instead create a new table and
populate.
* device-msw.c (sync_printer_with_devmode):
* lisp.h:
* text.c (lisp_strcasecmp_ascii):
Rename lisp_strcasecmp to lisp_strcasecmp_ascii and use
lisp_strcasecmp_i18n for caseless comparisons in some places.
* elhash.c:
Delete unused lisp_string_hash and lisp_string_equal().
* events.h:
* keymap-buttons.h:
* keymap.h:
* keymap.c (keymap_lookup_directly):
* keymap.c (keymap_store):
* keymap.c (FROB):
* keymap.c (key_desc_list_to_event):
* keymap.c (describe_map_mapper):
* keymap.c (INCLUDE_BUTTON_ZERO):
New file keymap-buttons.h; use to handle buttons 1-26 in place of
duplicating code 26 times.
* frame-gtk.c (allocate_gtk_frame_struct):
* frame-msw.c (mswindows_init_frame_1):
Fix some comments about internal_equal() in redisplay that don't
apply any more.
* keymap-slots.h:
* keymap.c:
New file keymap-slots.h. Use it to notate the slots in a keymap
structure, similar to frameslots.h or coding-system-slots.h.
* keymap.c (MARKED_SLOT):
* keymap.c (keymap_equal):
* keymap.c (keymap_hash):
Implement.
tests/ChangeLog addition:
2010-02-01 Ben Wing <ben@xemacs.org>
* automated/case-tests.el:
* automated/case-tests.el (uni-mappings):
* automated/search-tests.el:
Delete old pristine-case-table code. Rewrite the Unicode torture
test to take into account whether overlapping mappings exist for
more than one character, and not doing the upcase/downcase
comparisons in such cases.
* automated/lisp-tests.el (foo):
* automated/lisp-tests.el (string-variable):
* automated/lisp-tests.el (featurep):
Replace Assert (equal ... with Assert-equal; same for other types
of equality. Replace some awkward equivalents of Assert-equalp
with Assert-equalp. Add lots of equalp tests.
* automated/case-tests.el:
* automated/regexp-tests.el:
* automated/search-tests.el:
Fix up the comments at the top of the files. Move rules about where
to put tests into case-tests.el.
* automated/test-harness.el:
* automated/test-harness.el (test-harness-aborted-summary-template): New.
* automated/test-harness.el (test-harness-from-buffer):
* automated/test-harness.el (batch-test-emacs):
Fix Assert-test-not. Create Assert-not-equal and variants.
Delete the doc strings from all these convenience functions to avoid
excessive repetition; instead use one copy in a comment.
author | Ben Wing <ben@xemacs.org> |
---|---|
date | Mon, 01 Feb 2010 01:02:40 -0600 |
parents | 91a023144e72 |
children | 1b96882bdf37 |
comparison
equal
deleted
inserted
replaced
4903:70089046adef | 4906:6ef8256a020a |
---|---|
1955 (Assert | 1955 (Assert |
1956 (= 1 (length (multiple-value-list | 1956 (= 1 (length (multiple-value-list |
1957 (foo-zero 400 (1+ most-positive-fixnum))))) | 1957 (foo-zero 400 (1+ most-positive-fixnum))))) |
1958 "Checking multiple values are discarded correctly when forced") | 1958 "Checking multiple values are discarded correctly when forced") |
1959 (Check-Error setting-constant (setq multiple-values-limit 20)) | 1959 (Check-Error setting-constant (setq multiple-values-limit 20)) |
1960 (Assert | 1960 (Assert-equal '(-1 1) |
1961 (equal '(-1 1) | 1961 (multiple-value-list (floor -3 4)) |
1962 (multiple-value-list (floor -3 4))) | |
1963 "Checking #'multiple-value-list gives a sane result") | 1962 "Checking #'multiple-value-list gives a sane result") |
1964 (let ((ey 40000) | 1963 (let ((ey 40000) |
1965 (bee "this is a string") | 1964 (bee "this is a string") |
1966 (cee #s(hash-table size 256 data (969 ?\xF9)))) | 1965 (cee #s(hash-table size 256 data (969 ?\xF9)))) |
1967 (Assert | 1966 (Assert-equal |
1968 (equal | 1967 (multiple-value-list (values ey bee cee)) |
1969 (multiple-value-list (values ey bee cee)) | 1968 (multiple-value-list (values-list (list ey bee cee))) |
1970 (multiple-value-list (values-list (list ey bee cee)))) | |
1971 "Checking that #'values and #'values-list are correctly related") | 1969 "Checking that #'values and #'values-list are correctly related") |
1972 (Assert | 1970 (Assert-equal |
1973 (equal | 1971 (multiple-value-list (values-list (list ey bee cee))) |
1974 (multiple-value-list (values-list (list ey bee cee))) | 1972 (multiple-value-list (apply #'values (list ey bee cee))) |
1975 (multiple-value-list (apply #'values (list ey bee cee)))) | |
1976 "Checking #'values-list and #'apply with #values are correctly related")) | 1973 "Checking #'values-list and #'apply with #values are correctly related")) |
1977 (Assert | 1974 (Assert= (multiple-value-call #'+ (floor 5 3) (floor 19 4)) 10 |
1978 (= (multiple-value-call #'+ (floor 5 3) (floor 19 4)) 10) | |
1979 "Checking #'multiple-value-call gives reasonable results.") | 1975 "Checking #'multiple-value-call gives reasonable results.") |
1980 (Assert | 1976 (Assert= (multiple-value-call (values '+ '*) (floor 5 3) (floor 19 4)) 10 |
1981 (= (multiple-value-call (values '+ '*) (floor 5 3) (floor 19 4)) 10) | |
1982 "Checking #'multiple-value-call correct when first arg multiple.") | 1977 "Checking #'multiple-value-call correct when first arg multiple.") |
1983 (Assert | 1978 (Assert= 1 (length (multiple-value-list (prog1 (floor pi) "hi there"))) |
1984 (= 1 (length (multiple-value-list (prog1 (floor pi) "hi there")))) | |
1985 "Checking #'prog1 does not pass back multiple values") | 1979 "Checking #'prog1 does not pass back multiple values") |
1986 (Assert | 1980 (Assert= 2 (length (multiple-value-list |
1987 (= 2 (length (multiple-value-list | 1981 (multiple-value-prog1 (floor pi) "hi there"))) |
1988 (multiple-value-prog1 (floor pi) "hi there")))) | |
1989 "Checking #'multiple-value-prog1 passes back multiple values") | 1982 "Checking #'multiple-value-prog1 passes back multiple values") |
1990 (multiple-value-bind (floored remainder this-is-nil) | 1983 (multiple-value-bind (floored remainder this-is-nil) |
1991 (floor pi 1.0) | 1984 (floor pi 1.0) |
1992 (Assert= floored 3 | 1985 (Assert= floored 3 |
1993 "Checking floored bound correctly") | 1986 "Checking floored bound correctly") |
2001 (multiple-value-setq (ey bee cee) | 1994 (multiple-value-setq (ey bee cee) |
2002 (ffloor e 1.0)) | 1995 (ffloor e 1.0)) |
2003 (Assert-eql 2.0 ey "Checking ey set correctly") | 1996 (Assert-eql 2.0 ey "Checking ey set correctly") |
2004 (Assert-eql bee (- e 2.0) "Checking bee set correctly") | 1997 (Assert-eql bee (- e 2.0) "Checking bee set correctly") |
2005 (Assert (null cee) "Checking cee set to nil correctly")) | 1998 (Assert (null cee) "Checking cee set to nil correctly")) |
2006 (Assert | 1999 (Assert= 3 (length (multiple-value-list (eval '(values nil t pi)))) |
2007 (= 3 (length (multiple-value-list (eval '(values nil t pi))))) | |
2008 "Checking #'eval passes back multiple values") | 2000 "Checking #'eval passes back multiple values") |
2009 (Assert | 2001 (Assert= 2 (length (multiple-value-list (apply #'floor '(5 3)))) |
2010 (= 2 (length (multiple-value-list (apply #'floor '(5 3))))) | |
2011 "Checking #'apply passes back multiple values") | 2002 "Checking #'apply passes back multiple values") |
2012 (Assert | 2003 (Assert= 2 (length (multiple-value-list (funcall #'floor 5 3))) |
2013 (= 2 (length (multiple-value-list (funcall #'floor 5 3)))) | |
2014 "Checking #'funcall passes back multiple values") | 2004 "Checking #'funcall passes back multiple values") |
2015 (Assert | 2005 (Assert-equal '(1 2) (multiple-value-list |
2016 (equal '(1 2) (multiple-value-list | 2006 (multiple-value-call #'floor (values 5 3))) |
2017 (multiple-value-call #'floor (values 5 3)))) | |
2018 "Checking #'multiple-value-call passes back multiple values correctly") | 2007 "Checking #'multiple-value-call passes back multiple values correctly") |
2019 (Assert | 2008 (Assert= 1 (length (multiple-value-list |
2020 (= 1 (length (multiple-value-list | 2009 (and (multiple-value-function-returning-nil) t))) |
2021 (and (multiple-value-function-returning-nil) t)))) | |
2022 "Checking multiple values from non-trailing forms discarded by #'and") | 2010 "Checking multiple values from non-trailing forms discarded by #'and") |
2023 (Assert | 2011 (Assert= 5 (length (multiple-value-list |
2024 (= 5 (length (multiple-value-list | 2012 (and t (multiple-value-function-returning-nil)))) |
2025 (and t (multiple-value-function-returning-nil))))) | |
2026 "Checking multiple values from final forms not discarded by #'and") | 2013 "Checking multiple values from final forms not discarded by #'and") |
2027 (Assert | 2014 (Assert= 1 (length (multiple-value-list |
2028 (= 1 (length (multiple-value-list | 2015 (or (multiple-value-function-returning-t) t))) |
2029 (or (multiple-value-function-returning-t) t)))) | |
2030 "Checking multiple values from non-trailing forms discarded by #'and") | 2016 "Checking multiple values from non-trailing forms discarded by #'and") |
2031 (Assert | 2017 (Assert= 5 (length (multiple-value-list |
2032 (= 5 (length (multiple-value-list | 2018 (or nil (multiple-value-function-returning-t)))) |
2033 (or nil (multiple-value-function-returning-t))))) | |
2034 "Checking multiple values from final forms not discarded by #'and") | 2019 "Checking multiple values from final forms not discarded by #'and") |
2035 (Assert | 2020 (Assert= 1 (length (multiple-value-list |
2036 (= 1 (length (multiple-value-list | 2021 (cond ((multiple-value-function-returning-t))))) |
2037 (cond ((multiple-value-function-returning-t)))))) | |
2038 "Checking cond doesn't pass back multiple values in tests.") | 2022 "Checking cond doesn't pass back multiple values in tests.") |
2039 (Assert | 2023 (Assert-equal (list nil pi e radians-to-degrees degrees-to-radians) |
2040 (equal (list nil pi e radians-to-degrees degrees-to-radians) | |
2041 (multiple-value-list | 2024 (multiple-value-list |
2042 (cond (t (multiple-value-function-returning-nil))))) | 2025 (cond (t (multiple-value-function-returning-nil)))) |
2043 "Checking cond passes back multiple values in clauses.") | 2026 "Checking cond passes back multiple values in clauses.") |
2044 (Assert | 2027 (Assert= 1 (length (multiple-value-list |
2045 (= 1 (length (multiple-value-list | 2028 (prog1 (multiple-value-function-returning-nil)))) |
2046 (prog1 (multiple-value-function-returning-nil))))) | |
2047 "Checking prog1 discards multiple values correctly.") | 2029 "Checking prog1 discards multiple values correctly.") |
2048 (Assert | 2030 (Assert= 5 (length (multiple-value-list |
2049 (= 5 (length (multiple-value-list | |
2050 (multiple-value-prog1 | 2031 (multiple-value-prog1 |
2051 (multiple-value-function-returning-nil))))) | 2032 (multiple-value-function-returning-nil)))) |
2052 "Checking multiple-value-prog1 passes back multiple values correctly.") | 2033 "Checking multiple-value-prog1 passes back multiple values correctly.") |
2053 (Assert | 2034 (Assert-equal (list t pi e degrees-to-radians radians-to-degrees) |
2054 (equal (list t pi e degrees-to-radians radians-to-degrees) | |
2055 (multiple-value-list | 2035 (multiple-value-list |
2056 (catch 'VoN61Lo4Y (function-throwing-multiple-values))))) | 2036 (catch 'VoN61Lo4Y (function-throwing-multiple-values)))) |
2057 (Assert | 2037 (Assert-equal (list t pi e degrees-to-radians radians-to-degrees) |
2058 (equal (list t pi e degrees-to-radians radians-to-degrees) | |
2059 (multiple-value-list | 2038 (multiple-value-list |
2060 (loop | 2039 (loop |
2061 for eye in `(a b c d ,e f g ,nil ,pi) | 2040 for eye in `(a b c d ,e f g ,nil ,pi) |
2062 do (when (null eye) | 2041 do (when (null eye) |
2063 (return (multiple-value-function-returning-t)))))) | 2042 (return (multiple-value-function-returning-t))))) |
2064 "Checking #'loop passes back multiple values correctly.") | 2043 "Checking #'loop passes back multiple values correctly.") |
2065 (Assert | 2044 (Assert |
2066 (null (or)) | 2045 (null (or)) |
2067 "Checking #'or behaves correctly with zero arguments.") | 2046 "Checking #'or behaves correctly with zero arguments.") |
2068 (Assert | 2047 (Assert-eq t (and) |
2069 (eq t (and)) | |
2070 "Checking #'and behaves correctly with zero arguments.") | 2048 "Checking #'and behaves correctly with zero arguments.") |
2071 (Assert | 2049 (Assert= (* 3.0 (- pi 3.0)) |
2072 (= (* 3.0 (- pi 3.0)) | |
2073 (letf (((values three one-four-one-five-nine) (floor pi))) | 2050 (letf (((values three one-four-one-five-nine) (floor pi))) |
2074 (* three one-four-one-five-nine))) | 2051 (* three one-four-one-five-nine)) |
2075 "checking letf handles #'values in a basic sense")) | 2052 "checking letf handles #'values in a basic sense")) |
2076 | 2053 |
2077 ;; #'equalp tests. | 2054 ;; #'equalp tests. |
2078 (let ((string-variable "aBcDeeFgH\u00Edj") | 2055 (let ((string-variable "aBcDeeFgH\u00Edj") |
2079 (eacute-character ?\u00E9) | 2056 (eacute-character ?\u00E9) |
2080 (Eacute-character ?\u00c9) | 2057 (Eacute-character ?\u00c9) |
2081 (+base-chars+ (loop | 2058 (+base-chars+ (loop |
2082 with res = (make-string 96 ?\x20) | 2059 with res = (make-string 96 ?\x20) |
2083 for int-char from #x20 to #x7f | 2060 for int-char from #x20 to #x7f |
2084 for char being each element in-ref res | 2061 for char being each element in-ref res |
2085 do (setf char (int-to-char int-char)) | 2062 do (setf char (int-to-char int-char)) |
2086 finally return res))) | 2063 finally return res))) |
2064 (let ((equal-lists | |
2065 '((111111111111111111111111111111111111111111111111111 | |
2066 111111111111111111111111111111111111111111111111111.0) | |
2067 (0 0.0 0.000 -0 -0.0 -0.000 #b0 0/5 -0/5) | |
2068 (21845 #b101010101010101 #x5555) | |
2069 (1.5 1.500000000000000000000000000000000000000000000000000000000 | |
2070 3/2) | |
2071 (-55 -110/2) | |
2072 ;; Can't use this, these values aren't `='. | |
2073 ;;(-12345678901234567890123457890123457890123457890123457890123457890 | |
2074 ;; -12345678901234567890123457890123457890123457890123457890123457890.0) | |
2075 ))) | |
2076 (loop for li in equal-lists do | |
2077 (loop for (x . tail) on li do | |
2078 (loop for y in tail do | |
2079 (Assert-equalp x y) | |
2080 (Assert-equalp y x))))) | |
2081 | |
2082 (let ((diff-list | |
2083 `(0 1 2 3 1000 5000000000 5555555555555555555555555555555555555 | |
2084 -1 -2 -3 -1000 -5000000000 -5555555555555555555555555555555555555 | |
2085 1/2 1/3 2/3 8/2 355/113 (/ 3/2 0.2) (/ 3/2 0.7) | |
2086 55555555555555555555555555555555555555555/2718281828459045 | |
2087 0.111111111111111111111111111111111111111111111111111111111111111 | |
2088 1e+300 1e+301 -1e+300 -1e+301))) | |
2089 (loop for (x . tail) on diff-list do | |
2090 (loop for y in tail do | |
2091 (Assert-not-equalp x y) | |
2092 (Assert-not-equalp y x)))) | |
2093 | |
2087 (Assert-equalp "hi there" "Hi There" | 2094 (Assert-equalp "hi there" "Hi There" |
2088 "checking equalp isn't case-sensitive") | 2095 "checking equalp isn't case-sensitive") |
2089 (Assert-equalp 99 99.0 | 2096 (Assert-equalp 99 99.0 |
2090 "checking equalp compares numerical values of different types") | 2097 "checking equalp compares numerical values of different types") |
2091 (Assert (null (equalp 99 ?c)) | 2098 (Assert (null (equalp 99 ?c)) |
2092 "checking equalp does not convert characters to numbers") | 2099 "checking equalp does not convert characters to numbers") |
2093 ;; Fixed in Hg d0ea57eb3de4. | 2100 ;; Fixed in Hg d0ea57eb3de4. |
2094 (Assert (null (equalp "hi there" [hi there])) | 2101 (Assert (null (equalp "hi there" [hi there])) |
2095 "checking equalp doesn't error with string and non-string") | 2102 "checking equalp doesn't error with string and non-string") |
2096 (Assert-eq t (equalp "ABCDEEFGH\u00CDJ" string-variable) | 2103 (Assert-equalp "ABCDEEFGH\u00CDJ" string-variable |
2097 "checking #'equalp is case-insensitive with an upcased constant") | 2104 "checking #'equalp is case-insensitive with an upcased constant") |
2098 (Assert-eq t (equalp "abcdeefgh\xedj" string-variable) | 2105 (Assert-equalp "abcdeefgh\xedj" string-variable |
2099 "checking #'equalp is case-insensitive with a downcased constant") | 2106 "checking #'equalp is case-insensitive with a downcased constant") |
2100 (Assert-eq t (equalp string-variable string-variable) | 2107 (Assert-equalp string-variable string-variable |
2101 "checking #'equalp works when handed the same string twice") | 2108 "checking #'equalp works when handed the same string twice") |
2102 (Assert-eq t (equalp string-variable "aBcDeeFgH\u00Edj") | 2109 (Assert-equalp string-variable "aBcDeeFgH\u00Edj" |
2103 "check #'equalp is case-insensitive with a variable-cased constant") | 2110 "check #'equalp is case-insensitive with a variable-cased constant") |
2104 (Assert-eq t (equalp "" (bit-vector)) | 2111 (Assert-equalp "" (bit-vector) |
2105 "check empty string and empty bit-vector are #'equalp.") | 2112 "check empty string and empty bit-vector are #'equalp.") |
2106 (Assert-eq t (equalp (string) (bit-vector)) | 2113 (Assert-equalp (string) (bit-vector) |
2107 "check empty string and empty bit-vector are #'equalp, no constants") | 2114 "check empty string and empty bit-vector are #'equalp, no constants") |
2108 (Assert-eq t (equalp "hi there" (vector ?h ?i ?\ ?t ?h ?e ?r ?e)) | 2115 (Assert-equalp "hi there" (vector ?h ?i ?\ ?t ?h ?e ?r ?e) |
2109 "check string and vector with same contents #'equalp") | 2116 "check string and vector with same contents #'equalp") |
2110 (Assert-eq t (equalp (string ?h ?i ?\ ?t ?h ?e ?r ?e) | 2117 (Assert-equalp (string ?h ?i ?\ ?t ?h ?e ?r ?e) |
2111 (vector ?h ?i ?\ ?t ?h ?e ?r ?e)) | 2118 (vector ?h ?i ?\ ?t ?h ?e ?r ?e) |
2112 "check string and vector with same contents #'equalp, no constants") | 2119 "check string and vector with same contents #'equalp, no constants") |
2113 (Assert-eq t (equalp [?h ?i ?\ ?t ?h ?e ?r ?e] | 2120 (Assert-equalp [?h ?i ?\ ?t ?h ?e ?r ?e] |
2114 (string ?h ?i ?\ ?t ?h ?e ?r ?e)) | 2121 (string ?h ?i ?\ ?t ?h ?e ?r ?e) |
2115 "check string and vector with same contents #'equalp, vector constant") | 2122 "check string and vector with same contents #'equalp, vector constant") |
2116 (Assert-eq t (equalp [0 1.0 0.0 0 1] | 2123 (Assert-equalp [0 1.0 0.0 0 1] |
2117 (bit-vector 0 1 0 0 1)) | 2124 (bit-vector 0 1 0 0 1) |
2118 "check vector and bit-vector with same contents #'equalp,\ | 2125 "check vector and bit-vector with same contents #'equalp,\ |
2119 vector constant") | 2126 vector constant") |
2120 (Assert-eq t (equalp #*01001 | 2127 (Assert-not-equalp [0 2 0.0 0 1] |
2121 (vector 0 1.0 0.0 0 1)) | 2128 (bit-vector 0 1 0 0 1) |
2122 "check vector and bit-vector with same contents #'equalp,\ | 2129 "check vector and bit-vector with different contents not #'equalp,\ |
2130 vector constant") | |
2131 (Assert-equalp #*01001 | |
2132 (vector 0 1.0 0.0 0 1) | |
2133 "check vector and bit-vector with same contents #'equalp,\ | |
2123 bit-vector constant") | 2134 bit-vector constant") |
2124 (Assert-eq t (equalp ?\u00E9 Eacute-character) | 2135 (Assert-equalp ?\u00E9 Eacute-character |
2125 "checking characters are case-insensitive, one constant") | 2136 "checking characters are case-insensitive, one constant") |
2126 (Assert-eq nil (equalp ?\u00E9 (aref (format "%c" ?a) 0)) | 2137 (Assert-not-equalp ?\u00E9 (aref (format "%c" ?a) 0) |
2127 "checking distinct characters are not equalp, one constant") | 2138 "checking distinct characters are not equalp, one constant") |
2128 (Assert-eq t (equalp t (and)) | 2139 (Assert-equalp t (and) |
2129 "checking symbols are correctly #'equalp") | 2140 "checking symbols are correctly #'equalp") |
2130 (Assert-eq nil (equalp t (or nil '#:t)) | 2141 (Assert-not-equalp t (or nil '#:t) |
2131 "checking distinct symbols with the same name are not #'equalp") | 2142 "checking distinct symbols with the same name are not #'equalp") |
2132 (Assert-eq t (equalp #s(char-table type generic data (?\u0080 "hi-there")) | 2143 (Assert-equalp #s(char-table type generic data (?\u0080 "hi-there")) |
2133 (let ((aragh (make-char-table 'generic))) | 2144 (let ((aragh (make-char-table 'generic))) |
2134 (put-char-table ?\u0080 "hi-there" aragh) | 2145 (put-char-table ?\u0080 "hi-there" aragh) |
2135 aragh)) | 2146 aragh) |
2136 "checking #'equalp succeeds correctly, char-tables") | 2147 "checking #'equalp succeeds correctly, char-tables") |
2137 (Assert-eq nil (equalp #s(char-table type generic data (?\u0080 "hi-there")) | 2148 (Assert-equalp #s(char-table type generic data (?\u0080 "hi-there")) |
2138 (let ((aragh (make-char-table 'generic))) | 2149 (let ((aragh (make-char-table 'generic))) |
2139 (put-char-table ?\u0080 "HI-THERE" aragh) | 2150 (put-char-table ?\u0080 "HI-THERE" aragh) |
2140 aragh)) | 2151 aragh) |
2141 "checking #'equalp fails correctly, char-tables")) | 2152 "checking #'equalp succeeds correctly, char-tables") |
2153 (Assert-not-equalp #s(char-table type generic data (?\u0080 "hi-there")) | |
2154 (let ((aragh (make-char-table 'generic))) | |
2155 (put-char-table ?\u0080 "hi there" aragh) | |
2156 aragh) | |
2157 "checking #'equalp fails correctly, char-tables")) | |
2142 | 2158 |
2143 ;; There are more tests available for equalp here: | 2159 ;; There are more tests available for equalp here: |
2144 ;; | 2160 ;; |
2145 ;; http://www.parhasard.net/xemacs/equalp-tests.el | 2161 ;; http://www.parhasard.net/xemacs/equalp-tests.el |
2146 ;; | 2162 ;; |
2197 "checking #'assoc* correct if #'eql not explicitly specified") | 2213 "checking #'assoc* correct if #'eql not explicitly specified") |
2198 (Assert-eq | 2214 (Assert-eq |
2199 (rassoc* (1- most-negative-fixnum) assoc*-list) | 2215 (rassoc* (1- most-negative-fixnum) assoc*-list) |
2200 (rassoc* (1- most-negative-fixnum) assoc*-list :test #'eql) | 2216 (rassoc* (1- most-negative-fixnum) assoc*-list :test #'eql) |
2201 "checking #'rassoc* correct if #'eql not explicitly specified") | 2217 "checking #'rassoc* correct if #'eql not explicitly specified") |
2202 (Assert-eq | 2218 (Assert-eql (1+most-positive-fixnum) (1+ most-positive-fixnum) |
2203 (eql (1+most-positive-fixnum) (1+ most-positive-fixnum)) | 2219 "checking #'eql handles a bignum literal properly.") |
2204 t | |
2205 "checking #'eql handles a bignum literal properly.") | |
2206 (Assert-eq | 2220 (Assert-eq |
2207 (member* (1+most-positive-fixnum) member*-list) | 2221 (member* (1+most-positive-fixnum) member*-list) |
2208 (member* (1+ most-positive-fixnum) member*-list :test #'equal) | 2222 (member* (1+ most-positive-fixnum) member*-list :test #'equal) |
2209 "checking #'member* compiler macro correct with literal bignum") | 2223 "checking #'member* compiler macro correct with literal bignum") |
2210 (Assert-eq | 2224 (Assert-eq |