183 lines
4.0 KiB
Scheme
183 lines
4.0 KiB
Scheme
|
|
(define ones-case
|
|
(make-struct-case
|
|
(list
|
|
one00?
|
|
one01?
|
|
one02?
|
|
one03?
|
|
|
|
one10?
|
|
one11?
|
|
one12?
|
|
one13?
|
|
|
|
one20?
|
|
one21?
|
|
one22?
|
|
one23?
|
|
|
|
one30?
|
|
one31?
|
|
one32?
|
|
one33?)
|
|
|
|
(list
|
|
(lambda (x) 'one00)
|
|
(lambda (x) 'one01)
|
|
(lambda (x) 'one02)
|
|
(lambda (x) 'one03)
|
|
|
|
(lambda (x) 'one10)
|
|
(lambda (x) 'one11)
|
|
(lambda (x) 'one12)
|
|
(lambda (x) 'one13)
|
|
|
|
(lambda (x) 'one20)
|
|
(lambda (x) 'one21)
|
|
(lambda (x) 'one22)
|
|
(lambda (x) 'one23)
|
|
|
|
(lambda (x) 'one30)
|
|
(lambda (x) 'one31)
|
|
(lambda (x) 'one32)
|
|
(lambda (x) 'one33))))
|
|
|
|
(define multi-case
|
|
(make-struct-case
|
|
(list
|
|
two130?
|
|
two131?
|
|
two132?
|
|
two133?
|
|
|
|
one10?
|
|
one11?
|
|
one12?
|
|
one13?
|
|
|
|
one20?
|
|
one21?
|
|
one22?
|
|
one23?
|
|
|
|
base0?
|
|
base1?
|
|
base2?
|
|
base3?)
|
|
|
|
(list
|
|
(lambda (x) 'two130)
|
|
(lambda (x) 'two131)
|
|
(lambda (x) 'two132)
|
|
(lambda (x) 'two133)
|
|
|
|
(lambda (x) 'one10)
|
|
(lambda (x) 'one11)
|
|
(lambda (x) 'one12)
|
|
(lambda (x) 'one13)
|
|
|
|
(lambda (x) 'one20)
|
|
(lambda (x) 'one21)
|
|
(lambda (x) 'one22)
|
|
(lambda (x) 'one23)
|
|
|
|
(lambda (x) 'base0)
|
|
(lambda (x) 'base1)
|
|
(lambda (x) 'base2)
|
|
(lambda (x) 'base3))
|
|
|
|
(lambda (x) x)))
|
|
|
|
(letrec ([bundle
|
|
(lambda (l f)
|
|
(if (null? l)
|
|
null
|
|
(list* f (car l) (cadr l)
|
|
(bundle (cddr l) f))))])
|
|
(check (append
|
|
(bundle ones-test ones-case)
|
|
(bundle multi-test multi-case)
|
|
(list base1-a x11 1
|
|
one11-a x11 2
|
|
one10-a x10 1
|
|
|
|
base1-a x31 1
|
|
one31-z x31 4
|
|
|
|
base2-l x132 1
|
|
two132-a x132 6
|
|
one32-y x132 4))))
|
|
|
|
(test #t arity-at-least? (multi-case (arity void)))
|
|
|
|
(arity-test multi-case 1 1)
|
|
|
|
(error-test `(,ones-case 6) type?)
|
|
(error-test `(,multi-case 6) type?)
|
|
|
|
(error-test `(,ones-case (arity void)) exn:else?)
|
|
|
|
(test (void) (make-struct-case null null void) x00)
|
|
(test #t procedure? (make-struct-case null null))
|
|
|
|
(error-test `((make-struct-case null null) x00) exn:else?)
|
|
|
|
(error-test `(make-struct-case (list 8) (list void)))
|
|
(error-test `(make-struct-case (list exn:misc? 8) (list void void)))
|
|
(error-test `(make-struct-case (list exn:misc? 8 exn?) (list void void void)))
|
|
(error-test `(make-struct-case exn? (list void)))
|
|
(error-test `(make-struct-case (list* exn:misc? exn?) (list void)))
|
|
|
|
(error-test `(make-struct-case (list exn?) (list 8)))
|
|
(error-test `(make-struct-case (list exn?) (list (lambda () 8))))
|
|
(error-test `(make-struct-case (list exn:misc? exn?)
|
|
(list void string-set!)))
|
|
(error-test `(make-struct-case (list exn:misc? exn:syntax? exn?)
|
|
(list void void string-set!)))
|
|
(error-test `(make-struct-case (list exn?) void))
|
|
(error-test `(make-struct-case (list exn?) (list* void void)))
|
|
|
|
(error-test `(make-struct-case (list exn:misc?) (list void void))
|
|
exn:application:list-sizes?)
|
|
(error-test `(make-struct-case (list exn:misc? exn?) (list void))
|
|
exn:application:list-sizes?)
|
|
|
|
(arity-test make-struct-case 2 3)
|
|
|
|
(test 0 (struct-case-lambda x (else 0)) (arity void))
|
|
(test (arity void) (struct-case-lambda x (else)) (arity void))
|
|
(test (arity void) (struct-case-lambda x (arity-at-least?)) (arity void))
|
|
(test 0 (struct-case-lambda x (arity-at-least? 0) (else 1)) (arity void))
|
|
|
|
(define s (struct-case-lambda x
|
|
[exn? 'exn]
|
|
[arity-at-least? x]
|
|
[else (cons x 5)]))
|
|
|
|
(test 'exn s (make-exn 1 2))
|
|
(test (arity void) s (arity void))
|
|
(test (cons x00 5) s x00)
|
|
|
|
(arity-test s 1 1)
|
|
|
|
(error-test '(s 9))
|
|
(error-test '(struct-case-lambda) syntaxe?)
|
|
(error-test '(struct-case-lambda 5) syntaxe?)
|
|
(error-test '(struct-case-lambda x . 5) syntaxe?)
|
|
(error-test '(struct-case-lambda x ()) syntaxe?)
|
|
(error-test '(struct-case-lambda x else) syntaxe?)
|
|
(error-test '(struct-case-lambda x (else 9) (exn? 8)) syntaxe?))
|
|
|
|
(define time-branch
|
|
(lambda (proc list)
|
|
(time
|
|
(let loop ([n 1000])
|
|
(unless (zero? n)
|
|
(let loop ([l list])
|
|
(unless (null? l)
|
|
(proc (car l))
|
|
(loop (cddr l))))
|
|
(loop (sub1 n)))))))
|
|
|