test-helpers.k (3632B)

1 ;;; 2 ;;; Some helpers used in many modules 3 ;;; (check.k should be loaded) 4 ;;; 5 6 ($define! not-eq? ($lambda (x y) (not? (eq? x y)))) 7 ($define! not-equal? ($lambda (x y) (not? (equal? x y)))) 8 ($define! $check-predicate ($vau (x) denv (eval (list $check eq? x #t) denv))) 9 ($define! $check-not-predicate ($vau (x) denv (eval (list $check eq? x #f) denv))) 10 ($define! $check-no-error ($vau (x) denv 11 (eval (list $check 12 ($lambda (#ignore #ignore) #t) 13 x 14 #inert) 15 denv))) 16 17 ;; mutable-pair?, immutable-pair?, mutable-string? & immutable-string? 18 ;; were added to the ground environment 19 #| 20 ($define! mutable-pair? 21 ($lambda (obj) 22 ($and? (pair? obj) 23 (guard-dynamic-extent 24 () 25 ($lambda () 26 (set-car! obj (car obj)) 27 #t) 28 ;; As per the report (section 4.7.1) setting the car of an 29 ;; immutable pair (even if the value is the same) should 30 ;; signal an error. 31 (list (list error-continuation 32 ($lambda (#ignore divert) 33 (apply divert #f)))))))) 34 35 ($define! immutable-pair? 36 ($lambda (obj) ($and? (pair? obj) (not? (mutable-pair? obj))))) 37 38 ($define! nonempty-mutable-string? 39 ($lambda (obj) 40 ($and? 41 (string? obj) 42 (>? (string-length obj) 0) 43 (guard-dynamic-extent 44 () 45 ($lambda () (string-fill! obj #\x) #t) 46 (list 47 (list error-continuation 48 ($lambda (#ignore divert) (apply divert #f)))))))) 49 50 ($define! immutable-string? 51 ($lambda (obj) ($and? (string? obj) (not? (nonempty-mutable-string? obj))))) 52 |# 53 54 ($define! nonempty-mutable-string? mutable-string?) 55 56 ;; XXX/TODO Some of these could be removed if we had eager comprehension in 57 ;; check.k (which would also complete the srfi-78 implementation). The problem 58 ;; is that the design adaptation from macros to operatives should be taken 59 ;; with some care. I intended to do it before the remaining tests, but since 60 ;; Oto Havle went ahead and wrote the tests without it, they have lost some 61 ;; priority. Andres Navarro 62 63 ;; ($false-for-all? P XS) evaluates to #t iff (P X) evaluates 64 ;; to #f for all members X of the list XS. 65 ;; 66 ($define! $false-for-all? 67 ($vau (p . xs) denv 68 (apply and? 69 (map ($lambda (x) (not? (eval (list p x) denv))) xs)))) 70 71 ;; (cartesian-product XS YS) returns list of all pairs (X Y), 72 ;; where X is a member of the list XS and Y is a member of list YS. 73 ;; 74 ;; for example 75 ;; (cartesian-product (1 2) (3 4)) ===> ((1 3) (1 4) (2 3) (2 4)) 76 ;; 77 ($define! cartesian-product 78 ($lambda (xs ys) 79 (apply append 80 (map ($lambda (x) (map ($lambda (y) (list x y)) ys)) xs)))) 81 82 ;; ($true-for-all-combinations? BIN (X1 X2...) (Y1 Y1...)) 83 ;; evaluates to #t, iff (BIN X Y) evaluates to #t for all X and Y. 84 ;; 85 ($define! $true-for-all-combinations? 86 ($vau (p xs ys) denv 87 (apply and? 88 (map ($lambda ((x y)) (eval (list p x y) denv)) 89 (cartesian-product xs ys))))) 90 91 ;; ($false-for-all-combinations? BIN (X1 X2...) (Y1 Y2...)) 92 ;; evaluates to #t, iff (BIN X Y) evaluates to #f for all X and Y. 93 ;; 94 ($define! $false-for-all-combinations? 95 ($vau (p xs ys) denv 96 (apply and? 97 (map ($lambda ((x y)) (not? (eval (list p x y) denv))) 98 (cartesian-product xs ys))))) 99 100 ;; ($quote V) evaluates to V. The value V itself is not evaluated. 101 ;; See section 5.5.1, page 67 of the Kernel Report. 102 ($define! $quote ($vau (x) #ignore x))