diff options
| -rw-r--r-- | mew.scm | 45 | ||||
| -rw-r--r-- | mew.svnwiki | 3 | ||||
| -rw-r--r-- | tests/test.mew | 19 |
3 files changed, 52 insertions, 15 deletions
diff --git a/mew.scm b/mew.scm index 0383116..63463c5 100644 --- a/mew.scm +++ b/mew.scm @@ -23,7 +23,7 @@ uniq-accumulator unlist until vals void? -> fun-> fun->> set-> - <>? + =? <>? ~? generic-make-accumulator) @@ -84,7 +84,6 @@ (begin seq) (lambda fun) (apply app) - (equal? =?) (ceiling ceil) )) @@ -97,18 +96,40 @@ (define (boolean x) (not (not x))) + (define (tbl=? a b) + (and (hash-table? a) + (hash-table? b) + (= (hash-table-size a) (hash-table-size b)) + (call-with-current-continuation + (lambda (ret) + (hash-table-for-each + a + (lambda (k v) + ;; n.b. nan is never equal to anything + (unless (=? (hash-table-ref/default b k +nan.0) v) + (ret #f)))) + #t)))) + + (define =? + (case-lambda + (() #t) + ((_) #t) + ((x y) (or (equal? x y) + (tbl=? x y))) + ((x . rest) (every (lambda (y) (=? x y)) rest)))) + (define <>? (case-lambda - ((a b) (not (equal? a b))) - ((a b c) (and (not (equal? a b)) - (not (equal? b c)) - (not (equal? c a)))) - ((a b c d) (and (not (equal? a b)) - (not (equal? a c)) - (not (equal? a d)) - (not (equal? b c)) - (not (equal? b d)) - (not (equal? c d)))) + ((a b) (not (=? a b))) + ((a b c) (and (not (=? a b)) + (not (=? b c)) + (not (=? c a)))) + ((a b c d) (and (not (=? a b)) + (not (=? a c)) + (not (=? a d)) + (not (=? b c)) + (not (=? b d)) + (not (=? c d)))) ((a b c d . rest) (call-with-current-continuation (lambda (return) diff --git a/mew.svnwiki b/mew.svnwiki index 142fb2a..eab7e64 100644 --- a/mew.svnwiki +++ b/mew.svnwiki @@ -244,7 +244,8 @@ If {{<obj>}} is false, read all data from {{*current-input-port*}}. <procedure>(=? <val>...)</procedure> -Alias for {{equal?}}. +Return true if all values are {{equal?}} or hash-tables with same +set of keys and {{equal?}} values. <procedure>(<>? <val1> <val2> ...)</procedure> diff --git a/tests/test.mew b/tests/test.mew index 82a2e71..501a3ae 100644 --- a/tests/test.mew +++ b/tests/test.mew @@ -74,6 +74,19 @@ (test #t (boolean "foo")) (test #t (boolean (void)))) +(test-group "=?" + (test #t (=?)) + (test #t (=? 1)) + (test #t (=? "foo" "foo")) + (test #t (=? 1 1 1)) + (test #t (=? #(1 2 3) #(1 2 3))) + (test #t (=? (tbl 1 2 3 4) (tbl 3 4 1 2))) + (test #f (=? 4 5)) + (test #f (=? 4 5 6)) + (test #f (=? "foo" "bar")) + (test #f (=? 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20)) + (test #f (=? 4 5 4))) + (test-group "<>?" (test #t (<>? 4 5)) (test #t (<>? 4 5 6)) @@ -82,6 +95,8 @@ (test #f (<>? 4 5 4)) (test #f (<>? "foo" "foo")) (test #f (<>? 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 7)) + (test #t (<>? (tbl 1 2 3 4) (tbl 3 4 1 22))) + (test #t (<>? (tbl 1 2 3 4) (tbl 3 4))) (test-error "error with no arguments" (<>?)) (test-error "error with one argument" (<>? 42))) @@ -259,12 +274,12 @@ (test-group "set-at" (test #(0 42 0) (set-at #(0 0 0) 1 42)) - (test '(42) (vals (set-at (tbl 1 11) 1 42))) + (test #t (=? (tbl 1 42) (set-at (tbl 1 11) 1 42))) (test "fox" (set-at "foo" 2 #\x)) (test-error (set-at '(0 0 0) 1 42))) (test-group "del-at" - (test '(42) (vals (del-at (tbl 0 41 1 42 2 43) 0 2))) + (test #t (=? (tbl 1 42) (del-at (tbl 0 41 1 42 2 43) 0 2))) (test-error (del-at "foo" 2))) (test-group "empty?" |