From 43a584f7105ba3a0d7830879003a8c5241258969 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 26 Apr 2013 08:22:28 -0500 Subject: [PATCH] IN PROGRESS: enable opt/c on provide/contract and define/contract (via with-contract) --- .../racket/contract/private/provide.rkt | 45 +++++++------------ racket/collects/racket/contract/region.rkt | 16 +++---- 2 files changed, 25 insertions(+), 36 deletions(-) diff --git a/racket/collects/racket/contract/private/provide.rkt b/racket/collects/racket/contract/private/provide.rkt index 11ec0e1414..590f8204df 100644 --- a/racket/collects/racket/contract/private/provide.rkt +++ b/racket/collects/racket/contract/private/provide.rkt @@ -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 diff --git a/racket/collects/racket/contract/region.rkt b/racket/collects/racket/contract/region.rkt index e7b770173d..a7d98625c3 100644 --- a/racket/collects/racket/contract/region.rkt +++ b/racket/collects/racket/contract/region.rkt @@ -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 .