Mercurial > hg > xemacs-beta

comparison tests/automated/lisp-tests.el @ 5191:71ee43b8a74d

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API tests/ChangeLog addition: 2010-04-05 Aidan Kehoe <kehoea@parhasard.net> * automated/hash-table-tests.el: Test the new built-in #'equalp hash table test. Test #'define-hash-table-test. * automated/lisp-tests.el: When asserting that two objects are #'equalp, also assert that their #'equalp-hash is identical. man/ChangeLog addition: 2010-04-03 Aidan Kehoe <kehoea@parhasard.net> * lispref/hash-tables.texi (Introduction to Hash Tables): Document that we now support #'equalp as a hash table test by default, and mention #'define-hash-table-test. (Working With Hash Tables): Document #'define-hash-table-test. src/ChangeLog addition: 2010-04-05 Aidan Kehoe <kehoea@parhasard.net> * elhash.h: * elhash.c (struct Hash_Table_Test, lisp_object_eql_equal) (lisp_object_eql_hash, lisp_object_equal_equal) (lisp_object_equal_hash, lisp_object_equalp_hash) (lisp_object_equalp_equal, lisp_object_general_hash) (lisp_object_general_equal, Feq_hash, Feql_hash, Fequal_hash) (Fequalp_hash, define_hash_table_test, Fdefine_hash_table_test) (init_elhash_once_early, mark_hash_table_tests, string_equalp_hash): * glyphs.c (vars_of_glyphs): Add a new hash table test in C, #'equalp. Make it possible to specify new hash table tests with functions define_hash_table_test, #'define-hash-table-test. Use define_hash_table_test() in glyphs.c. Expose the hash functions (besides that used for #'equal) to Lisp, for people writing functions to be used with #'define-hash-table-test. Call define_hash_table_test() very early in temacs, to create the built-in hash table tests. * ui-gtk.c (emacs_gtk_boxed_hash): * specifier.h (struct specifier_methods): * specifier.c (specifier_hash): * rangetab.c (range_table_entry_hash, range_table_hash): * number.c (bignum_hash, ratio_hash, bigfloat_hash): * marker.c (marker_hash): * lrecord.h (struct lrecord_implementation): * keymap.c (keymap_hash): * gui.c (gui_item_id_hash, gui_item_hash): * glyphs.c (image_instance_hash, glyph_hash): * glyphs-x.c (x_image_instance_hash): * glyphs-msw.c (mswindows_image_instance_hash): * glyphs-gtk.c (gtk_image_instance_hash): * frame-msw.c (mswindows_set_title_from_ibyte): * fontcolor.c (color_instance_hash, font_instance_hash): * fontcolor-x.c (x_color_instance_hash): * fontcolor-tty.c (tty_color_instance_hash): * fontcolor-msw.c (mswindows_color_instance_hash): * fontcolor-gtk.c (gtk_color_instance_hash): * fns.c (bit_vector_hash): * floatfns.c (float_hash): * faces.c (face_hash): * extents.c (extent_hash): * events.c (event_hash): * data.c (weak_list_hash, weak_box_hash): * chartab.c (char_table_entry_hash, char_table_hash): * bytecode.c (compiled_function_hash): * alloc.c (vector_hash): Change the various object hash methods to take a new EQUALP parameter, hashing appropriately for #'equalp if it is true.
author Aidan Kehoe <kehoea@parhasard.net>
date Mon, 05 Apr 2010 13:03:35 +0100
parents 000287f8053b
children d579d76f3dcc
comparison
equal deleted inserted replaced
5190:1c1d8843de5e 5191:71ee43b8a74d
2147 (loop for (x . tail) on li do 2147 (loop for (x . tail) on li do
2148 (loop for y in tail do 2148 (loop for y in tail do
2149 (push `(Assert (equalp ,(quote-maybe x) 2149 (push `(Assert (equalp ,(quote-maybe x)
2150 ,(quote-maybe y))) res) 2150 ,(quote-maybe y))) res)
2151 (push `(Assert (equalp ,(quote-maybe y) 2151 (push `(Assert (equalp ,(quote-maybe y)
2152 ,(quote-maybe x))) res)))) 2152 ,(quote-maybe x))) res)
2153 (push `(Assert (eql (equalp-hash ,(quote-maybe y))
2154 (equalp-hash ,(quote-maybe x))))
2155 res))))
2153 (cons 'progn (nreverse res)))) 2156 (cons 'progn (nreverse res))))
2154 (equalp-diff-list-tests (diff-list) 2157 (equalp-diff-list-tests (diff-list)
2155 (let (res) 2158 (let (res)
2156 (setq diff-list (eval diff-list)) 2159 (setq diff-list (eval diff-list))
2157 (loop for (x . tail) on diff-list do 2160 (loop for (x . tail) on diff-list do
2158 (loop for y in tail do 2161 (loop for y in tail do
2159 (push `(Assert (not (equalp ,(quote-maybe x) 2162 (push `(Assert (not (equalp ,(quote-maybe x)
2160 ,(quote-maybe y)))) res) 2163 ,(quote-maybe y)))) res)
2161 (push `(Assert (not (equalp ,(quote-maybe y) 2164 (push `(Assert (not (equalp ,(quote-maybe y)
2162 ,(quote-maybe x)))) res))) 2165 ,(quote-maybe x)))) res)))
2163 (cons 'progn (nreverse res))))) 2166 (cons 'progn (nreverse res))))
2167 (Assert-equalp (object-one object-two &optional failing-case description)
2168 `(progn
2169 (Assert (equalp ,object-one ,object-two)
2170 ,@(if failing-case
2171 (list failing-case description)))
2172 (Assert (eql (equalp-hash ,object-one) (equalp-hash ,object-two))))))
2164 (equalp-equal-list-tests 2173 (equalp-equal-list-tests
2165 `(,@(when (featurep 'bignum) 2174 `(,@(when (featurep 'bignum)
2166 (read "((111111111111111111111111111111111111111111111111111 2175 (read "((111111111111111111111111111111111111111111111111111
2167 111111111111111111111111111111111111111111111111111.0))")) 2176 111111111111111111111111111111111111111111111111111.0))"))
2168 (0 0.0 0.000 -0 -0.0 -0.000 #b0 ,@(when (featurep 'ratio) '(0/5 -0/5))) 2177 (0 0.0 0.000 -0 -0.0 -0.000 #b0 ,@(when (featurep 'ratio) '(0/5 -0/5)))
2181 -1 -2 -3 -1000 -5000000000 2190 -1 -2 -3 -1000 -5000000000
2182 1/2 1/3 2/3 8/2 355/113 2191 1/2 1/3 2/3 8/2 355/113
2183 ,@(when (featurep 'ratio) (mapcar* #'/ '(3/2 3/2) '(0.2 0.7))) 2192 ,@(when (featurep 'ratio) (mapcar* #'/ '(3/2 3/2) '(0.2 0.7)))
2184 55555555555555555555555555555555555555555/2718281828459045 2193 55555555555555555555555555555555555555555/2718281828459045
2185 0.111111111111111111111111111111111111111111111111111111111111111 2194 0.111111111111111111111111111111111111111111111111111111111111111
2186 1e+300 1e+301 -1e+300 -1e+301))) 2195 1e+300 1e+301 -1e+300 -1e+301))
2187 2196
2188 (Assert (equalp "hi there" "Hi There") 2197 (Assert-equalp "hi there" "Hi There"
2189 "checking equalp isn't case-sensitive") 2198 "checking equalp isn't case-sensitive")
2190 (Assert (equalp 99 99.0) 2199 (Assert-equalp
2191 "checking equalp compares numerical values of different types") 2200 99 99.0
2192 (Assert (null (equalp 99 ?c)) 2201 "checking equalp compares numerical values of different types")
2193 "checking equalp does not convert characters to numbers") 2202 (Assert (null (equalp 99 ?c))
2194 ;; Fixed in Hg d0ea57eb3de4. 2203 "checking equalp does not convert characters to numbers")
2195 (Assert (null (equalp "hi there" [hi there])) 2204 ;; Fixed in Hg d0ea57eb3de4.
2196 "checking equalp doesn't error with string and non-string") 2205 (Assert (null (equalp "hi there" [hi there]))
2197 (Assert (equalp "ABCDEEFGH\u00CDJ" string-variable) 2206 "checking equalp doesn't error with string and non-string")
2198 "checking #'equalp is case-insensitive with an upcased constant") 2207 (Assert-equalp
2199 (Assert (equalp "abcdeefgh\xedj" string-variable) 2208 "ABCDEEFGH\u00CDJ" string-variable
2200 "checking #'equalp is case-insensitive with a downcased constant") 2209 "checking #'equalp is case-insensitive with an upcased constant")
2201 (Assert (equalp string-variable string-variable) 2210 (Assert-equalp
2202 "checking #'equalp works when handed the same string twice") 2211 "abcdeefgh\xedj" string-variable
2203 (Assert (equalp string-variable "aBcDeeFgH\u00Edj") 2212 "checking #'equalp is case-insensitive with a downcased constant")
2204 "check #'equalp is case-insensitive with a variable-cased constant") 2213 (Assert-equalp string-variable string-variable
2205 (Assert (equalp "" (bit-vector)) 2214 "checking #'equalp works when handed the same string twice")
2206 "check empty string and empty bit-vector are #'equalp.") 2215 (Assert (equalp string-variable "aBcDeeFgH\u00Edj")
2207 (Assert (equalp (string) (bit-vector)) 2216 "check #'equalp is case-insensitive with a variable-cased constant")
2208 "check empty string and empty bit-vector are #'equalp, no constants") 2217 (Assert-equalp "" (bit-vector)
2209 (Assert (equalp "hi there" (vector ?h ?i ?\ ?t ?h ?e ?r ?e)) 2218 "check empty string and empty bit-vector are #'equalp.")
2210 "check string and vector with same contents #'equalp") 2219 (Assert-equalp
2211 (Assert (equalp (string ?h ?i ?\ ?t ?h ?e ?r ?e) 2220 (string) (bit-vector)
2212 (vector ?h ?i ?\ ?t ?h ?e ?r ?e)) 2221 "check empty string and empty bit-vector are #'equalp, no constants")
2213 "check string and vector with same contents #'equalp, no constants") 2222 (Assert-equalp "hi there" (vector ?h ?i ?\ ?t ?h ?e ?r ?e)
2214 (Assert (equalp [?h ?i ?\ ?t ?h ?e ?r ?e] 2223 "check string and vector with same contents #'equalp")
2215 (string ?h ?i ?\ ?t ?h ?e ?r ?e)) 2224 (Assert-equalp
2216 "check string and vector with same contents #'equalp, vector constant") 2225 (string ?h ?i ?\ ?t ?h ?e ?r ?e)
2217 (Assert (equalp [0 1.0 0.0 0 1] 2226 (vector ?h ?i ?\ ?t ?h ?e ?r ?e)
2218 (bit-vector 0 1 0 0 1)) 2227 "check string and vector with same contents #'equalp, no constants")
2219 "check vector and bit-vector with same contents #'equalp,\ 2228 (Assert-equalp
2229 [?h ?i ?\ ?t ?h ?e ?r ?e]
2230 (string ?h ?i ?\ ?t ?h ?e ?r ?e)
2231 "check string and vector with same contents #'equalp, vector constant")
2232 (Assert-equalp [0 1.0 0.0 0 1]
2233 (bit-vector 0 1 0 0 1)
2234 "check vector and bit-vector with same contents #'equalp,\
2220 vector constant") 2235 vector constant")
2221 (Assert (not (equalp [0 2 0.0 0 1] 2236 (Assert (not (equalp [0 2 0.0 0 1]
2222 (bit-vector 0 1 0 0 1))) 2237 (bit-vector 0 1 0 0 1)))
2223 "check vector and bit-vector with different contents not #'equalp,\ 2238 "check vector and bit-vector with different contents not #'equalp,\
2224 vector constant") 2239 vector constant")
2225 (Assert (equalp #*01001 2240 (Assert-equalp #*01001
2226 (vector 0 1.0 0.0 0 1)) 2241 (vector 0 1.0 0.0 0 1)
2227 "check vector and bit-vector with same contents #'equalp,\ 2242 "check vector and bit-vector with same contents #'equalp,\
2228 bit-vector constant") 2243 bit-vector constant")
2229 (Assert (equalp ?\u00E9 Eacute-character) 2244 (Assert-equalp ?\u00E9 Eacute-character
2230 "checking characters are case-insensitive, one constant") 2245 "checking characters are case-insensitive, one constant")
2231 (Assert (not (equalp ?\u00E9 (aref (format "%c" ?a) 0))) 2246 (Assert (not (equalp ?\u00E9 (aref (format "%c" ?a) 0)))
2232 "checking distinct characters are not equalp, one constant") 2247 "checking distinct characters are not equalp, one constant")
2233 (Assert (equalp t (and)) 2248 (Assert-equalp t (and)
2234 "checking symbols are correctly #'equalp") 2249 "checking symbols are correctly #'equalp")
2235 (Assert (not (equalp t (or nil '#:t))) 2250 (Assert (not (equalp t (or nil '#:t)))
2236 "checking distinct symbols with the same name are not #'equalp") 2251 "checking distinct symbols with the same name are not #'equalp")
2237 (Assert (equalp #s(char-table type generic data (?\u0080 "hi-there")) 2252 (Assert-equalp #s(char-table type generic data (?\u0080 "hi-there"))
2238 (let ((aragh (make-char-table 'generic))) 2253 (let ((aragh (make-char-table 'generic)))
2239 (put-char-table ?\u0080 "hi-there" aragh) 2254 (put-char-table ?\u0080 "hi-there" aragh)
2240 aragh)) 2255 aragh)
2241 "checking #'equalp succeeds correctly, char-tables") 2256 "checking #'equalp succeeds correctly, char-tables")
2242 (Assert (equalp #s(char-table type generic data (?\u0080 "hi-there")) 2257 (Assert-equalp #s(char-table type generic data (?\u0080 "hi-there"))
2243 (let ((aragh (make-char-table 'generic))) 2258 (let ((aragh (make-char-table 'generic)))
2244 (put-char-table ?\u0080 "HI-THERE" aragh) 2259 (put-char-table ?\u0080 "HI-THERE" aragh)
2245 aragh)) 2260 aragh)
2246 "checking #'equalp succeeds correctly, char-tables") 2261 "checking #'equalp succeeds correctly, char-tables")
2247 (Assert (not (equalp #s(char-table type generic data (?\u0080 "hi-there")) 2262 (Assert (not (equalp #s(char-table type generic data (?\u0080 "hi-there"))
2248 (let ((aragh (make-char-table 'generic))) 2263 (let ((aragh (make-char-table 'generic)))
2249 (put-char-table ?\u0080 "hi there" aragh) 2264 (put-char-table ?\u0080 "hi there" aragh)
2250 aragh))) 2265 aragh)))
2251 "checking #'equalp fails correctly, char-tables")) 2266 "checking #'equalp fails correctly, char-tables")))
2252 2267
2253 ;; There are more tests available for equalp here: 2268 ;; There are more tests available for equalp here:
2254 ;; 2269 ;;
2255 ;; http://www.parhasard.net/xemacs/equalp-tests.el 2270 ;; http://www.parhasard.net/xemacs/equalp-tests.el
2256 ;; 2271 ;;