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

IN PROGRESS: enable opt/c on provide/contract and define/contract (via with-contract)

Browse Source
This commit is contained in:
Robby Findler 2013-04-26 08:22:28 -05:00
parent 96a782fe91
commit 43a584f710
2 changed files with 25 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

45
racket/collects/racket/contract/private/provide.rkt
View File

@ -24,14 +24,10 @@
"guts.rkt"
"misc.rkt"
"exists.rkt"
"opt.rkt"
syntax/location
syntax/srcloc)
(define-syntax (verify-contract stx)
(syntax-case stx ()
[(_ name x) (a:known-good-contract? #'x) #'x]
[(_ name x) #'(coerce-contract name x)]))
(define-for-syntax (self-ctor-transformer orig stx)
(with-syntax ([orig orig])
(syntax-case stx ()
@ -372,12 +368,10 @@
#t))]
[mutator-ids (reverse (list-ref the-struct-info 4))] ;; (listof (union #f identifier))
[field-contract-ids (map (λ (field-name field-contract)
(if (a:known-good-contract? field-contract)
field-contract
(a:mangle-id provide-stx
"provide/contract-field-contract"
field-name
struct-name)))
(a:mangle-id provide-stx
"provide/contract-field-contract"
field-name
struct-name))
field-names
field-contracts)]
[struct:struct-name
@ -532,11 +526,9 @@
[(field-contract-id-definitions ...)
(filter values (map (λ (field-contract-id field-contract)
(if (a:known-good-contract? field-contract)
#f
(with-syntax ([field-contract-id field-contract-id]
[field-contract field-contract])
#`(define field-contract-id (verify-contract '#,who field-contract)))))
(with-syntax ([field-contract-id field-contract-id]
[field-contract field-contract])
#'(define field-contract-id (opt/c field-contract #:error-name provide/contract))))
field-contract-ids
field-contracts))]
[(field-contracts ...) field-contracts]
@ -742,17 +734,14 @@
(define (code-for-one-id/new-name stx id reflect-id ctrct/no-prop user-rename-id
[mangle-for-maker? #f]
[provide? #t])
(let ([no-need-to-check-ctrct? (a:known-good-contract? ctrct/no-prop)]
[ex-id (or reflect-id id)]
(let ([ex-id (or reflect-id id)]
[ctrct (syntax-property ctrct/no-prop
'racket/contract:contract-on-boundary
(gensym 'provide/contract-boundary))])
(with-syntax ([id-rename (id-for-one-id user-rename-id reflect-id id mangle-for-maker?)]
[contract-id (if no-need-to-check-ctrct?
ctrct
(a:mangle-id provide-stx
"provide/contract-contract-id"
(or user-rename-id ex-id)))]
[contract-id (a:mangle-id provide-stx
"provide/contract-contract-id"
(or user-rename-id ex-id))]
[pos-stx (datum->syntax id 'here)]
[id id]
[ex-id ex-id]
@ -770,11 +759,11 @@
(quasisyntax/loc stx
(begin
#,@(if no-need-to-check-ctrct?
(list)
(list #`(define contract-id
(let ([ex-id ctrct]) ;; let is here to give the right name.
(verify-contract '#,who ex-id)))))
(define contract-id
;; let is here to give the right name.
(let ([ex-id (opt/c ctrct #:error-name provide/contract)])
ex-id))
(define-syntax id-rename
(make-provide/contract-transformer (quote-syntax contract-id)
(a:update-loc

16
racket/collects/racket/contract/region.rkt
View File

@ -19,14 +19,14 @@
"private/arrow.rkt"
"private/base.rkt"
"private/guts.rkt"
"private/misc.rkt")
"private/misc.rkt"
"private/opt.rkt")
;; These are useful for all below.
(define-syntax (verify-contract stx)
(define-syntax (add-opt-contract stx)
(syntax-case stx ()
[(_ name x) (a:known-good-contract? #'x) #'x]
[(_ name x) #'(coerce-contract name x)]))
[(_ x) #'(opt/c x #:error-name with-contract)]))
@ -688,14 +688,14 @@
(with-syntax ([new-stx (add-context #'(syntax-parameterize
([current-contract-region (λ (stx) #'blame-stx)])
(let-values ([(res ...) (let () . body)])
(values (contract (verify-contract 'with-contract rc.ctc)
(values (contract (add-opt-contract rc.ctc)
res
blame-stx
blame-id) ...))))])
(syntax/loc stx
(let ()
(define-values (free-ctc-id ...)
(values (verify-contract 'with-contract free-ctc) ...))
(values (add-opt-contract free-ctc) ...))
(define blame-id
(current-contract-region))
(define-values ()
@ -757,7 +757,7 @@
(syntax/loc stx
(begin
(define-values (free-ctc-id ...)
(values (verify-contract 'with-contract free-ctc) ...))
(values (add-opt-contract free-ctc) ...))
(define blame-id
(current-contract-region))
(define-values ()
@ -787,7 +787,7 @@
ext-id
(contract ctc-id true-p blame-stx blame-id (quote ext-id) (quote-srcloc ext-id))
ctc-id
(verify-contract 'with-contract ctc))
(add-opt-contract ctc))
...)
blame-stx
.