(use simple-tests simple-exceptions simple-contracts) (contract-check-level 1) (define-test (helpers?) (check "FLIP" (null? ((%% list))) (equal? ((%% list) 1) '(1)) (equal? ((%% list) 1 2) '(2 1)) (equal? ((%% list) 1 2 3 4) '(2 3 4 1)) (equal? ((%% map) '(0 1 2) add1) '(1 2 3)) "PIPE" (= ((pipe) 5) 5) (= ((pipe (+ 1)) 5) 6) (not ((pipe (- 10) (positive?)) 5)) ((pipe (- 10) (negative?)) 5) (equal? ((pipe ((%% list) 1 2 3 4)) 10) '(1 2 3 4 10)) (equal? ((pipe (list 1 2 3 4)) 10) '(10 1 2 3 4)) (equal? ((pipe ((%% map) add1)) '(0 1 2)) '(1 2 3)) (equal? ((pipe (list 1 2 3)) 0) '(0 1 2 3)) (equal? ((pipe ((%% list) 1 2 3)) 0) '(1 2 3 0)) )) (define-test (contracts?) (check "COMMANDS" (define-values (counter! counter) (let ((state 0)) (values (xlambda ((new (pipe (= (add1 old)))) ;integer? (pipe (= (add1 old)))) ;integer? (lambda (x) (= x (add1 old)))) (old integer?) <-) (let ((old state)) (set! state (add1 state)) (values state old))) (xlambda ((result (pipe (= state))) <-) state)))) (zero? (counter)) (counter!) (= (counter) 1) (counter!) (= (counter) 2) (define-values (push pop top) (let ((stk '())) (let ( (push (xlambda ((new list? (pipe (equal? (cons arg old)))) (old list?) <- (arg)) (let ((old stk)) (set! stk (cons arg stk)) (values stk old)))) (pop (xlambda ((new list? (pipe (equal? (cdr old)))) (old list?) <-) (let ((old (<< stk 'pop (pipe (null?) (not))))) (set! stk (cdr stk)) (values stk old)))) (top (xlambda ((result) <-) (car (<< stk 'top (pipe (null?) (not)))))) ) (values push pop top) ))) ;(top) ; precondition violated ;(pop) ; precondition violated (push 0) (push 1) (= 1 (top)) (equal? (call-with-values (lambda () (push 2)) list) '((2 1 0) (1 0))) (= 2 (top)) (equal? (call-with-values (lambda () (pop)) list) '((1 0) (2 1 0))) "QUERIES" (define-values (add add-pre add-post) (xlambda ((result integer? odd? (pipe (= (apply + x y ys)))) <- (x integer? odd?) (y integer? even?) ys integer? even?) (apply + x y ys))) (= (add 1 2 4 6) 13) (equal? add-pre '((x (conjoin integer? odd?)) (y (conjoin integer? even?)) ys (conjoin integer? even?))) (equal? add-post '(result (conjoin integer? odd? (pipe (= (apply + x y ys)))))) (not (condition-case (add 1 2 3) ((exn argument) #f))) (define wrong-add (xlambda ((result integer? even?) <- (x integer? odd?) xs integer? even?) (apply + x xs))) (not (condition-case (wrong-add 1 2 4) ((exn result) #f))) (define-values (divide divide-pre divide-post) (xlambda ((q integer?) (r (pipe (+ (* n q)) (= m))) <- (m integer? (pipe (>= 0))) (n integer? positive?)) (let loop ((q 0) (r m)) (if (< r n) (values q r) (loop (+ q 1) (- r n)))))) (equal? (call-with-values (lambda () (divide 385 25)) list) '(15 10)) (equal? divide-pre '((m (conjoin integer? (pipe (>= 0)))) (n (conjoin integer? positive?)))) (equal? divide-post '((q integer?) (r (pipe (+ (* n q)) (= m))))) "XDEFINE" ;(xdefine ((result integer?) sum (a integer?) as integer?) (xdefine ((result integer?) #(sum-post sum sum-pre) (a integer?) as integer?) (apply + a as)) ;(print sum-post) ;(print sum-pre) (= (sum 1 2 3) 6) (not (condition-case (sum 1 2 #f) ((exn argument) #f))) (xdefine ((result list?) wrong-sum (a integer?) as integer?) (apply + a as)) (not (condition-case (wrong-sum 1 2 3) ((exn result) #f))) )) (compound-test (SIMPLE-CONTRACTS) (helpers?) (contracts?) (pe '(pipe (<< 6 even?) (<< 5 odd?))) (xpr:val (pipe (<< 5 integer? odd?) (<< 5 integer? even?)) ) )