110 lines
3.5 KiB
Scheme
110 lines
3.5 KiB
Scheme
|
|
(load-relative "loadtest.ss")
|
|
|
|
(Section 'function)
|
|
|
|
(require scheme/function mzlib/etc)
|
|
|
|
;; stuff from scheme/base
|
|
|
|
(test 0 (compose add1 sub1) 0)
|
|
(test 2 (compose add1 (lambda () 1)))
|
|
(test 5 (compose (lambda (a b) a) (lambda (x) (values (add1 x) x))) 4)
|
|
(test -1 (compose (lambda (a b) (+ a b)) (lambda (x y) (values (- y) x))) 2 3)
|
|
(test 'hi (compose (case-lambda [(x) 'bye][(y z) 'hi]) (lambda () (values 1 2))))
|
|
(test 'ok (compose (lambda () 'ok) (lambda () (values))))
|
|
(test 'ok (compose (lambda () 'ok) (lambda (w) (values))) 5)
|
|
(test-values '(1 2 3) (lambda () ((compose (lambda (x) (values x (add1 x) (+ x 2))) (lambda (y) y)) 1)))
|
|
|
|
(err/rt-test (compose 5))
|
|
(err/rt-test (compose add1 sub1 5))
|
|
(err/rt-test (compose add1 5 sub1))
|
|
(err/rt-test (compose 5 add1 sub1))
|
|
(err/rt-test ((compose add1 (lambda () (values 1 2)))) exn:application:arity?)
|
|
(err/rt-test ((compose add1 sub1)) exn:application:arity?)
|
|
(err/rt-test ((compose (lambda () 1) add1) 8) exn:application:arity?)
|
|
|
|
(arity-test compose 1 -1)
|
|
|
|
;; ---------- rec (from mzlib/etc) ----------
|
|
(let ()
|
|
(test 3 (rec f (λ (x) 3)) 3)
|
|
(test 3 (rec f (λ (x) x)) 3)
|
|
(test 2 (rec f (λ (x) (if (= x 3) (f 2) x))) 3)
|
|
(test 3 (rec (f x) 3) 3)
|
|
(test 3 (rec (f x) x) 3)
|
|
(test 2 (rec (f x) (if (= x 3) (f 2) x)) 3)
|
|
(test 2 (rec (f x . y) (car y)) 1 2 3)
|
|
(test 2 'no-duplications
|
|
(let ([x 1]) (rec ignored (begin (set! x (+ x 1)) void)) x))
|
|
(test 'f object-name (rec (f x) x))
|
|
(test 'f object-name (rec (f x . y) x))
|
|
(test 'f object-name (rec f (lambda (x) x)))
|
|
(test (list 2) (rec (f . x) (if (= (car x) 3) (f 2) x)) 3))
|
|
|
|
;; ---------- negate ----------
|
|
(let ()
|
|
(define *not (negate not))
|
|
(define *void (negate void))
|
|
(define *< (negate <))
|
|
(test #t *not #t)
|
|
(test #f *not #f)
|
|
(test #t *not 12)
|
|
(test #f *void)
|
|
(test #t *< 12 3)
|
|
(test #t *< 12 12)
|
|
(test #f *< 11 12)
|
|
(test #t *< 14 13 12 11)
|
|
(test #f *< 11 12 13 14))
|
|
|
|
;; ---------- curry/r ----------
|
|
(let ()
|
|
(define foo0 (lambda () 0))
|
|
(define foo1 (lambda (x) x))
|
|
(define foo3 (lambda (x y z) (list x y z)))
|
|
(define foo2< (lambda (x y . r) (list* x y r)))
|
|
(define foo35 (case-lambda [(a b c) 3] [(a b c d e) 5]))
|
|
(define foo:x (lambda (#:x [x 1] n . ns) (* x (apply + n ns))))
|
|
(define *foo0 (curry foo0))
|
|
(define *foo1 (curry foo1))
|
|
(define *foo3 (curry foo3))
|
|
(define *foo2< (curry foo2<))
|
|
(define *foo35 (curry foo35))
|
|
(define *foo:x2 (curry foo:x #:x 2))
|
|
(define ++ (curry +))
|
|
(define-syntax-rule ((f x ...) . => . e2) (test e2 f x ...))
|
|
;; see the docs for why these are expected
|
|
(((curry foo0)) . => . 0)
|
|
((*foo0) . => . 0)
|
|
((curry foo1 123) . => . 123)
|
|
((*foo1 123) . => . 123)
|
|
(((*foo1) 123) . => . 123)
|
|
((((*foo1)) 123) . => . 123)
|
|
((curry foo3 1 2 3) . => . '(1 2 3))
|
|
((*foo3 1 2 3) . => . '(1 2 3))
|
|
(((*foo3 1 2) 3) . => . '(1 2 3))
|
|
(((((((*foo3) 1)) 2)) 3) . => . '(1 2 3))
|
|
(((curry foo2< 1 2)) . => . '(1 2))
|
|
(((curry foo2< 1 2 3)) . => . '(1 2 3))
|
|
(((curry foo2< 1 2) 3) . => . '(1 2 3))
|
|
(((*foo2< 1 2)) . => . '(1 2))
|
|
(((*foo2< 1 2 3)) . => . '(1 2 3))
|
|
(((*foo2< 1 2) 3) . => . '(1 2 3))
|
|
(((curry + 1 2) 3) . => . 6)
|
|
(((++ 1 2) 3) . => . 6)
|
|
(((++) 1 2) . => . 3)
|
|
(((++)) . => . 0)
|
|
(((curry foo35 1 2) 3) . => . 3)
|
|
(((curry foo35 1 2 3)) . => . 3)
|
|
(((*foo35 1 2) 3) . => . 3)
|
|
(((*foo35 1 2 3)) . => . 3)
|
|
(((((*foo35 1 2 3 4))) 5) . => . 5)
|
|
(((((((((((*foo35)) 1)) 2)) 3 4))) 5) . => . 5)
|
|
((*foo:x2 1 2 3) . => . 12)
|
|
((map *foo:x2 '(1 2 3)) . => . '(2 4 6))
|
|
((((curryr foo3 1) 2) 3) . => . '(3 2 1))
|
|
(((curryr list 1) 2 3) . => . '(2 3 1))
|
|
)
|
|
|
|
(report-errs)
|