~ chicken-core (master) /tests/data-structures-tests.scm

  1;;;; data-structures-tests.scm
  2
  3(import (chicken sort)
  4	(chicken string))
  5
  6(define-syntax assert-error
  7  (syntax-rules ()
  8    ((_ expr)
  9     (assert (handle-exceptions _ #t expr #f)))))
 10
 11(assert (equal? 'bar (alist-ref 'foo '((foo . bar)))))
 12(assert (not (alist-ref 'foo '())))
 13(assert (not (alist-ref 'foo '((bar . foo)))))
 14(assert-error (alist-ref 'foo 'bar))
 15(assert-error (alist-ref 'foo '(bar)))
 16
 17(let ((cmp (lambda (x y) (eqv? x y))))
 18  (assert (equal? 'bar (alist-ref 'foo '((foo . bar)) cmp)))
 19  (assert (not (alist-ref 'foo '() cmp)))
 20  (assert (not (alist-ref 'foo '((bar . foo)) cmp)))
 21  (assert-error (alist-ref 'foo 'bar cmp))
 22  (assert-error (alist-ref 'foo '(bar) cmp)))
 23
 24
 25(let ((alist '((foo . 123) ("bar" . "baz"))))
 26  (alist-update! 'foo 999 alist)
 27  (assert (= (alist-ref 'foo alist) 999))
 28  (alist-update! 'qux 'nope alist)
 29  (assert (not (alist-ref 'qux alist)))
 30  (assert (eq? 'yep (alist-ref 'qux (alist-update! 'qux 'yep alist))))
 31  (assert (eq? 'ok (alist-ref "bar" (alist-update! "bar" 'ok alist equal?) equal?))))
 32
 33(let ((alist '((foo . 123) ("bar" . "baz"))))
 34  (alist-update 'foo 999 alist)
 35  (assert (= (alist-ref 'foo alist) 123))
 36  (assert (eq? 'yep (alist-ref 'qux (alist-update 'qux 'yep alist))))
 37  (assert (eq? 'ok (alist-ref "bar" (alist-update "bar" 'ok alist equal?) equal?))))
 38
 39;; #808: strings with embedded nul bytes should not be compared
 40;; with ASCIIZ string comparison functions
 41(assert (substring=? "foo\x00;a" "foo\x00;a" 1 1))
 42(assert (substring-ci=? "foo\x00;a" "foo\x00;a" 1 1))
 43(assert (substring-ci=? "foo\x00;a" "foo\x00;A" 1 1))
 44(assert (= 2 (substring-index "o\x00;bar" "foo\x00;bar")))
 45(assert (= 2 (substring-index-ci "o\x00;bar" "foo\x00;bar")))
 46(assert (= 2 (substring-index-ci "o\x00;bar" "foo\x00;BAR")))
 47(assert (not (substring=? "foo\x00;a" "foo\x00;b" 1 1)))
 48(assert (not (substring-ci=? "foo\x00;a" "foo\x00;b" 1 1)))
 49(assert (substring=? "foo" "foo" 0 0 3))
 50(assert (substring-ci=? "foo" "foo" 0 0 3))
 51(assert (not (substring-index "o\x00;bar" "foo\x00;baz")))
 52(assert (not (substring-index-ci "o\x00;bar" "foo\x00;baz")))
 53(assert (= 0 (substring-index "" "")))
 54(assert (= 1 (substring-index "" "a" 1)))
 55(assert-error (substring=? "a" "a" 2))
 56(assert-error (substring=? "a" "a" -2))
 57(assert-error (substring=? "a" "a" 0 2))
 58(assert-error (substring=? "a" "a" 0 -2))
 59(assert-error (substring=? "a" "a" 0 0 2))
 60(assert-error (substring=? "a" "a" 0 0 -2))
 61(assert-error (substring-ci=? "a" "a" 2))
 62(assert-error (substring-ci=? "a" "a" -2))
 63(assert-error (substring-ci=? "a" "a" 0 2))
 64(assert-error (substring-ci=? "a" "a" 0 -2))
 65(assert-error (substring-ci=? "a" "a" 0 0 2))
 66(assert-error (substring-ci=? "a" "a" 0 0 -2))
 67(assert-error (substring-ci=? "a" "a" 0 0 2))
 68(assert-error (substring-index "" "a" 2))
 69(assert-error (substring-index "a" "b" 2))
 70(assert (not (substring-index "a" "b" 1)))
 71(assert (not (substring-index "ab" "")))
 72(assert (= 0 (string-compare3 "foo\x00;a" "foo\x00;a")))
 73(assert (> 0 (string-compare3 "foo\x00;a" "foo\x00;b")))
 74(assert (< 0 (string-compare3 "foo\x00;b" "foo\x00;a")))
 75(assert (= 0 (string-compare3-ci "foo\x00;a" "foo\x00;a")))
 76(assert (= 0 (string-compare3-ci "foo\x00;a" "foo\x00;A")))
 77(assert (> 0 (string-compare3-ci "foo\x00;a" "foo\x00;b")))
 78(assert (> 0 (string-compare3-ci "foo\x00;A" "foo\x00;b")))
 79(assert (< 0 (string-compare3-ci "foo\x00;b" "foo\x00;a")))
 80(assert (< 0 (string-compare3-ci "foo\x00;b" "foo\x00;A")))
 81
 82(assert (string=? "bde" (string-translate* "abcd"
 83					   '(("a" . "b")
 84					     ("b" . "")
 85					     ("c" . "d")
 86					     ("d" . "e")))))
 87(assert (string=? "bc" (string-translate* "abc"
 88					  '(("ab" . "b")
 89					    ("bc" . "WRONG")))))
 90(assert (string=? "x" (string-translate* "ab" '(("ab" . "x")))))
 91(assert (string=? "xy" (string-translate* "xyz" '(("z" . "")))))
 92
 93;; topological-sort
 94
 95(assert (equal? '() (topological-sort '() eq?)))
 96(assert (equal? '(a b c d) (topological-sort '((a b) (b c) (c d)) eq?)))
 97(assert (equal? '(a b c d) (topological-sort '((a b) (c d)) eq?)))
 98(assert-error (topological-sort '((a b) (b a)) eq?))
 99(assert
100  (equal?
101    (topological-sort
102     '((i am)
103       (not trying)
104       (confuse the)
105       (am trying)
106       (trying to)
107       (am not)
108       (trying the)
109       (to confuse)
110       (the issue))
111      eq?)
112    '(i am not trying to confuse the issue)))