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

Refactor out new has-contract?/value-contract functionality so that it's

Browse Source 
the responsibility of the (higher-order) contract to add the contract
(plus possibly more in the future) to the wrapped value.

svn: r18469

original commit: bf60da75e179c2b2ecd9c09f0f7aadda629d95b5
This commit is contained in:
Stevie Strickland 2010-03-04 21:10:44 +00:00
parent 2b7121ca81
commit d889d9de71
1 changed files with 28 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
collects/mzlib/private/contract-arrow.ss
View File

@ -22,6 +22,10 @@
opt->* opt->*
unconstrained-domain->) unconstrained-domain->)
(define-struct contracted-function (proc ctc)
#:property prop:procedure 0
#:property prop:contracted 1)
(define-syntax (unconstrained-domain-> stx) (define-syntax (unconstrained-domain-> stx)
(syntax-case stx () (syntax-case stx ()
[(_ rngs ...) [(_ rngs ...)
@ -31,6 +35,7 @@
[(res-x ...) (generate-temporaries #'(rngs ...))]) [(res-x ...) (generate-temporaries #'(rngs ...))])
#'(let ([rngs-x (coerce-contract 'unconstrained-domain-> rngs)] ...) #'(let ([rngs-x (coerce-contract 'unconstrained-domain-> rngs)] ...)
(let ([proj-x (contract-projection rngs-x)] ...) (let ([proj-x (contract-projection rngs-x)] ...)
(define ctc
(make-contract (make-contract
#:name #:name
(build-compound-type-name 'unconstrained-domain-> (contract-name rngs-x) ...) (build-compound-type-name 'unconstrained-domain-> (contract-name rngs-x) ...)
@ -39,11 +44,14 @@
(let ([p-app-x (proj-x blame)] ...) (let ([p-app-x (proj-x blame)] ...)
(λ (val) (λ (val)
(if (procedure? val) (if (procedure? val)
(make-contracted-function
(λ args (λ args
(let-values ([(res-x ...) (apply val args)]) (let-values ([(res-x ...) (apply val args)])
(values (p-app-x res-x) ...))) (values (p-app-x res-x) ...)))
ctc)
(raise-blame-error blame val "expected a procedure"))))) (raise-blame-error blame val "expected a procedure")))))
#:first-order procedure?))))])) #:first-order procedure?))
ctc)))]))
(define (build--> name doms doms-rest rngs kwds quoted-kwds rng-any? func) (define (build--> name doms doms-rest rngs kwds quoted-kwds rng-any? func)
(let ([doms/c (map (λ (dom) (coerce-contract name dom)) doms)] (let ([doms/c (map (λ (dom) (coerce-contract name dom)) doms)]
@ -88,6 +96,7 @@
(if has-rest? (if has-rest?
(check-procedure/more val dom-length '() mandatory-keywords blame) (check-procedure/more val dom-length '() mandatory-keywords blame)
(check-procedure val dom-length 0 '() mandatory-keywords blame))) (check-procedure val dom-length 0 '() mandatory-keywords blame)))
ctc
(append partial-doms partial-ranges partial-kwds)))))) (append partial-doms partial-ranges partial-kwds))))))
#:name #:name
@ -263,10 +272,10 @@
[use-any? use-any?]) [use-any? use-any?])
(with-syntax ([outer-lambda (with-syntax ([outer-lambda
(syntax (syntax
(lambda (chk dom-names ... rng-names ... kwd-names ...) (lambda (chk ctc dom-names ... rng-names ... kwd-names ...)
(lambda (val) (lambda (val)
(chk val) (chk val)
inner-lambda)))]) (make-contracted-function inner-lambda ctc))))])
(values (values
(syntax (build--> '-> (syntax (build--> '->
(list dom-ctcs ...) (list dom-ctcs ...)
@ -323,10 +332,10 @@
(syntax (lambda args body))))]) (syntax (lambda args body))))])
(with-syntax ([outer-lambda (with-syntax ([outer-lambda
(syntax (syntax
(lambda (chk dom-x ... rst-x rng-x ... dom-kwd-ctc-id ...) (lambda (chk ctc dom-x ... rst-x rng-x ... dom-kwd-ctc-id ...)
(lambda (val) (lambda (val)
(chk val) (chk val)
inner-lambda)))]) (make-contracted-function inner-lambda ctc))))])
(values (syntax (build--> '->* (values (syntax (build--> '->*
(list doms ...) (list doms ...)
rst rst
@ -353,10 +362,10 @@
(syntax (lambda args body))))]) (syntax (lambda args body))))])
(with-syntax ([outer-lambda (with-syntax ([outer-lambda
(syntax (syntax
(lambda (chk dom-x ... rst-x ignored dom-kwd-ctc-id ...) (lambda (chk ctc dom-x ... rst-x ignored dom-kwd-ctc-id ...)
(lambda (val) (lambda (val)
(chk val) (chk val)
inner-lambda)))]) (make-contracted-function inner-lambda ctc))))])
(values (syntax (build--> '->* (values (syntax (build--> '->*
(list doms ...) (list doms ...)
rst rst