Mercurial > hg > xemacs-beta

comparison tests/automated/case-tests.el @ 4906:6ef8256a020a

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
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 9e7f5a77cc84
comparison
equal deleted inserted replaced
4903:70089046adef 4906:6ef8256a020a
27 27
28 ;;; Synched up with: Not in FSF. 28 ;;; Synched up with: Not in FSF.
29 29
30 ;;; Commentary: 30 ;;; Commentary:
31 31
32 ;; Test case-table related functionality. 32 ;; Test case-table related functionality. See test-harness.el for
33 ;; instructions on how to run these tests.
33 34
34 ;; NOTE NOTE NOTE: See also: 35 ;; NOTE NOTE NOTE: See also:
35 ;; 36 ;;
36 ;; (1) regexp-tests.el, for case-related regexp searching. 37 ;; (1) regexp-tests.el, for case-related regexp searching.
37 ;; (2) search-tests.el, for case-related non-regexp searching. 38 ;; (2) search-tests.el, for case-related non-regexp searching.
38 39 ;; (3) lisp-tests.el, for case-related comparisons with `equalp'.
39 ;; NOTE NOTE NOTE: There is some domain overlap among regexp-tests.el, 40
40 ;; search-tests.el and case-tests.el. See search-tests.el. 41 ;; NOTE NOTE NOTE: There is some domain overlap among case-tests.el,
42 ;; lisp-tests.el, regexp-tests.el, and search-tests.el. The current rule
43 ;; for what goes where is:
41 ;; 44 ;;
42 45 ;; (1) Anything regexp-related goes in regexp-tests.el, including searches.
43 ;; Ben thinks this is unnecessary. See comment in search-tests.el. 46 ;; (2) Non-regexp searches go in search-tests.el. This includes case-folding
44 47 ;; searches in the situation where the test tests both folding and
45 ;;(defvar pristine-case-table nil 48 ;; non-folding behavior.
46 ;; "The standard case table, without manipulation from case-tests.el") 49 ;; (3) Anything else that involves case-testing but in an ancillary manner
47 ;; 50 ;; goes into whichever primary area it is involved in (e.g. searches for
48 ;;(setq pristine-case-table (or 51 ;; search-tests.el, Lisp primitives in lisp-tests.el). But if it is
49 ;; ;; This is the compiled run; we've retained 52 ;; primarily case-related and happens to involve other areas in an
50 ;; ;; it from the interpreted run. 53 ;; ancillary manner, it goes into case-tests.el. This includes, for
51 ;; pristine-case-table 54 ;; example, the Unicode case map torture tests.
52 ;; ;; This is the interpreted run; set it. 55
53 ;; (copy-case-table (standard-case-table))))
54 56
55 (Assert (case-table-p (standard-case-table))) 57 (Assert (case-table-p (standard-case-table)))
56 ;; Old case table test. 58 ;; Old case table test.
57 (Assert (case-table-p (list 59 (Assert (case-table-p (list
58 (make-string 256 ?a) 60 (make-string 256 ?a)
1440 (?\U00010424 ?\U0001044C) ;; DESERET CAPITAL LETTER EN 1442 (?\U00010424 ?\U0001044C) ;; DESERET CAPITAL LETTER EN
1441 (?\U00010425 ?\U0001044D) ;; DESERET CAPITAL LETTER ENG 1443 (?\U00010425 ?\U0001044D) ;; DESERET CAPITAL LETTER ENG
1442 (?\U00010426 ?\U0001044E) ;; DESERET CAPITAL LETTER OI 1444 (?\U00010426 ?\U0001044E) ;; DESERET CAPITAL LETTER OI
1443 (?\U00010427 ?\U0001044F) ;; DESERET CAPITAL LETTER EW 1445 (?\U00010427 ?\U0001044F) ;; DESERET CAPITAL LETTER EW
1444 )) 1446 ))
1445 (uni-casetab (loop 1447 ;; a table to track mappings that overlap with some other mapping
1446 with case-table = (make-case-table) 1448 (multi-hash (make-hash-table))
1447 for (uc lc) in uni-mappings 1449 (uni-casetab
1448 do (put-case-table-pair uc lc case-table) 1450 (loop
1449 finally return case-table)) 1451 with case-table = (make-case-table)
1450 ;; All lowercase 1452 for (uc lc) in uni-mappings do
1451 (lower (with-output-to-string 1453 ;; see if there are existing mappings for either char of the new
1452 (loop for (uc lc) in uni-mappings do (princ lc)))) 1454 ;; mapping pair.
1453 ;; All uppercase 1455 (let* ((curucval (get-case-table 'downcase uc case-table))
1454 (upper (with-output-to-string 1456 (curlcval (get-case-table 'upcase lc case-table))
1455 (loop for (uc lc) in uni-mappings do (princ lc)))) 1457 (curucval (and (not (eq curucval uc)) curucval))
1456 ;; For each pair, lower followed by upper 1458 (curlcval (and (not (eq curlcval lc)) curlcval))
1457 (lowerupper (with-output-to-string 1459 )
1458 (loop for (uc lc) in uni-mappings 1460 ;; if so, flag both the existing and new mapping pair as having
1459 do (princ lc) (princ uc)))) 1461 ;; an overlapping mapping.
1460 ;; For each pair, upper followed by lower 1462 (when (or curucval curlcval)
1461 (upperlower (with-output-to-string 1463 (loop for ch in (list curucval curlcval uc lc) do
1462 (loop for (uc lc) in uni-mappings 1464 (puthash ch t multi-hash)))
1463 do (princ uc) (princ lc)))) 1465
1464 ) 1466 ;; finally, make the new mapping.
1465 (with-case-table uni-casetab 1467 (put-case-table-pair uc lc case-table))
1466 (Assert-equalp lower upper) 1468 finally return case-table)))
1467 (Assert-equalp lowerupper upperlower) 1469 (flet ((ismulti (uc lc)
1468 (Assert-equal lower (downcase upper)) 1470 (or (gethash uc multi-hash) (gethash lc multi-hash))))
1469 (Assert-equal upper (downcase lower)) 1471 (let (
1470 (Assert-equal lower (downcase upper)) 1472 ;; All lowercase
1471 (Assert-equal upper (downcase lower)) 1473 (lowermulti (with-output-to-string
1472 (Assert-equal (downcase lower) (downcase (downcase lower))) 1474 (loop for (uc lc) in uni-mappings do (princ lc))))
1473 (Assert-equal (upcase lowerupper) (upcase upperlower)) 1475 ;; All uppercase
1474 (Assert-equal (downcase lowerupper) (downcase upperlower)) 1476 (uppermulti (with-output-to-string
1475 (with-temp-buffer 1477 (loop for (uc lc) in uni-mappings do (princ uc))))
1476 (set-case-table uni-casetab) 1478 ;; For each pair, lower followed by upper
1477 (loop for (str1 str2) in `((,lower ,upper) 1479 (loweruppermulti (with-output-to-string
1478 (,lowerupper ,upperlower) 1480 (loop for (uc lc) in uni-mappings
1479 (,upper ,lower) 1481 do (princ lc) (princ uc))))
1480 (,upperlower ,lowerupper)) 1482 ;; For each pair, upper followed by lower
1481 do 1483 (upperlowermulti (with-output-to-string
1482 (erase-buffer) 1484 (loop for (uc lc) in uni-mappings
1483 (Assert= (point-min) 1) 1485 do (princ uc) (princ lc))))
1484 (Assert= (point) 1) 1486 ;; All lowercase, no complex mappings
1485 (insert str1) 1487 (lower (with-output-to-string
1486 (let ((point (point)) 1488 (loop for (uc lc) in uni-mappings do
1487 (case-fold-search t)) 1489 (unless (ismulti uc lc) (princ lc)))))
1488 (Assert= (length str1) (1- point)) 1490 ;; All uppercase, no complex mappings
1489 (goto-char (point-min)) 1491 (upper (with-output-to-string
1490 (Assert-eql (search-forward str2 nil t) point))) 1492 (loop for (uc lc) in uni-mappings do
1491 (loop for (uc lc) in uni-mappings do 1493 (unless (ismulti uc lc) (princ uc)))))
1492 (loop for (ch1 ch2) in `((,uc ,lc) 1494 ;; For each pair, lower followed by upper, no complex mappings
1493 (,lc ,uc)) 1495 (lowerupper (with-output-to-string
1496 (loop for (uc lc) in uni-mappings do
1497 (unless (ismulti uc lc) (princ lc) (princ uc)))))
1498 ;; For each pair, upper followed by lower, no complex mappings
1499 (upperlower (with-output-to-string
1500 (loop for (uc lc) in uni-mappings do
1501 (unless (ismulti uc lc) (princ uc) (princ lc)))))
1502 )
1503 (with-case-table
1504 uni-casetab
1505 ;; Comparison with `equalp' uses a canonical mapping internally and
1506 ;; so should be able to handle multi-mappings. Just comparing
1507 ;; using downcase and upcase, however, won't necessarily work in
1508 ;; the presence of such mappings -- that's what the internal canon
1509 ;; and eqv tables are for.
1510 (Assert-equalp lowermulti uppermulti)
1511 (Assert-equalp loweruppermulti upperlowermulti)
1512 (Assert-equal lower (downcase upper))
1513 (Assert-equal upper (upcase lower))
1514 (Assert-equal (downcase lower) (downcase (downcase lower)))
1515 (Assert-equal (upcase lowerupper) (upcase upperlower))
1516 (Assert-equal (downcase lowerupper) (downcase upperlower))
1517 ;; Individually -- we include multi-mappings since we're using
1518 ;; `equalp'.
1519 (loop
1520 for (uc lc) in uni-mappings do
1521 (Assert-equalp uc lc)
1522 (Assert-equalp (string uc) (string lc)))
1523 )
1524
1525 ;; Here we include multi-mappings -- searching should be able to
1526 ;; handle it.
1527 (with-temp-buffer
1528 (set-case-table uni-casetab)
1529 (loop for (str1 str2) in `((,lowermulti ,uppermulti)
1530 (,loweruppermulti ,upperlowermulti)
1531 (,uppermulti ,lowermulti)
1532 (,upperlowermulti ,loweruppermulti))
1494 do 1533 do
1495 (erase-buffer) 1534 (erase-buffer)
1496 (insert ?0) 1535 (Assert= (point-min) 1)
1497 (insert ch1) 1536 (Assert= (point) 1)
1498 (insert ?1) 1537 (insert str1)
1499 (goto-char (point-min)) 1538 (let ((point (point))
1500 (Assert-eql (search-forward (char-to-string ch2) nil t) 3 1539 (case-fold-search t))
1501 (format "Case-folded searching doesn't equate %s and %s" 1540 (Assert= (length str1) (1- point))
1502 (char-as-unicode-escape ch1) 1541 (goto-char (point-min))
1503 (char-as-unicode-escape ch2)))))))) 1542 (Assert-eql (search-forward str2 nil t) point)))
1543 (loop for (uc lc) in uni-mappings do
1544 (loop for (ch1 ch2) in `((,uc ,lc)
1545 (,lc ,uc))
1546 do
1547 (erase-buffer)
1548 (insert ?0)
1549 (insert ch1)
1550 (insert ?1)
1551 (goto-char (point-min))
1552 (Assert-eql (search-forward (char-to-string ch2) nil t) 3
1553 (format "Case-folded searching doesn't equate %s and %s"
1554 (char-as-unicode-escape ch1)
1555 (char-as-unicode-escape ch2))))))
1556 )))