suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

added recursive contracts and fixed a bug or two

Browse Source 
svn: r81
This commit is contained in:
Robby Findler 2005-06-09 18:56:19 +00:00
parent 37bf17c51b
commit 06b511f323
2 changed files with 76 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

40
collects/mzlib/contract.ss
View File

@ -11,6 +11,7 @@ add struct contracts for immutable structs?
(provide (rename -contract contract)
any
recursive-contract
->
->d
->*
@ -506,7 +507,7 @@ add struct contracts for immutable structs?
;
;
;; contract = (make-contract ((union #f (listof number)) -> string)
;; contract = (make-contract sexp
;; (sym
;; sym
;; (union syntax #f)
@ -560,7 +561,7 @@ add struct contracts for immutable structs?
;; build-compound-type-name : (union contract symbol) ... -> (union path #f) -> sexp
;; build-compound-type-name : (union contract symbol) ... -> (-> sexp)
(define (build-compound-type-name . fs)
(let loop ([subs fs]
[i 0])
@ -594,7 +595,7 @@ add struct contracts for immutable structs?
(build-flat-contract name predicate))
(define (build-flat-contract name predicate)
(make-flat-contract
(make-flat-contract
name
(lambda (pos neg src-info orig-str)
(lambda (val)
@ -728,6 +729,23 @@ add struct contracts for immutable structs?
""))
""))
(define-syntax (recursive-contract stx)
(syntax-case stx ()
[(_ arg)
(syntax (recursive-contract/proc '(recursive-contract arg) (delay (check-contract arg))))]))
(define (recursive-contract/proc name delayed-contract)
(make-contract name
(λ (pos neg src str)
(let ([proc (contract-proc (force delayed-contract))])
(λ (val)
((proc pos neg src str) val))))))
(define (check-contract ctc)
(unless (contract? ctc)
(error 'recursive-contract "expected a contract, got ~e" ctc))
ctc)
;
;
;
@ -3094,14 +3112,14 @@ add struct contracts for immutable structs?
[(null? args) (flat-contract null?)]
[else (cons-immutable/c (car args) (loop (cdr args)))])))
(define (syntax/c c)
(unless (flat-contract/predicate? c)
(error 'syntax/c "expected argument of type <flat-contract> or procedure of arity 1, got ~e" c))
(build-flat-contract
(let ([pred (flat-contract-predicate c)])
(lambda (val)
(and (syntax? val)
(pred (syntax-e val)))))))
(define (syntax/c ctc-in)
(let ([ctc (coerce-contract syntax/c ctc-in)])
(build-flat-contract
(build-compound-type-name 'syntax/c ctc)
(let ([pred (flat-contract-predicate ctc)])
(lambda (val)
(and (syntax? val)
(pred (syntax-e val))))))))
(define promise/c
(lambda (ctc-in)

47
collects/tests/mzscheme/contract-test.ss
View File

@ -2781,6 +2781,20 @@
x)
1)
(test/pos-blame
'syntax/c1
'(contract (syntax/c boolean?)
#'x
'pos
'neg))
(test/spec-passed
'syntax/c2
'(contract (syntax/c symbol?)
#'x
'pos
'neg))
(test/spec-passed
'struct/c1
'(let ()
@ -2807,6 +2821,35 @@
1
'pos
'neg)))
(test/spec-passed
'recursive-contract1
(letrec ([ctc (-> integer? (recursive-contract ctc))])
(letrec ([f (λ (x) f)])
((((contract ctc f 'pos 'neg) 1) 2) 3))))
(test/neg-blame
'recursive-contract2
'(letrec ([ctc (-> integer? (recursive-contract ctc))])
(letrec ([f (λ (x) f)])
((contract ctc f 'pos 'neg) #f))))
(test/neg-blame
'recursive-contract3
'(letrec ([ctc (-> integer? (recursive-contract ctc))])
(letrec ([f (λ (x) f)])
((((contract ctc f 'pos 'neg) 1) 2) #f))))
(test/pos-blame
'recursive-contract4
'(letrec ([ctc (-> integer? (recursive-contract ctc))])
(letrec ([c 0]
[f (λ (x)
(set! c (+ c 1))
(if (= c 2)
'nope
f))])
((((contract ctc f 'pos 'neg) 1) 2) 3))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
@ -3107,9 +3150,13 @@
(test-name '(object-contract (m (->r ((x ...) (y ...) (z ...)) rest-x ... ...)))
(object-contract (m (->r ((x number?) (y boolean?) (z pair?)) rest-x any/c number?))))
(test-name '(promise/c any/c) (promise/c any/c))
(test-name '(syntax/c any/c) (syntax/c any/c))
(test-name '(struct/c st integer?)
(let ()
(define-struct st (a))
(struct/c st integer?)))
(test-name '(recursive-contract (box/c boolean?)) (recursive-contract (box/c boolean?)))
(test-name '(recursive-contract x) (let ([x (box/c boolean?)]) (recursive-contract x)))
))
(report-errs)