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

* Fix with-contract so that all uncontracted names are automatically exported

Browse Source 
* Also allow mutation of contracted names that flow in/out of with-contract.

svn: r16376
This commit is contained in:
Stevie Strickland 2009-10-19 23:17:30 +00:00
parent 1bcf4be2ae
commit c17885638a
3 changed files with 122 additions and 156 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

247
collects/scheme/contract/regions.ss
View File

@ -295,14 +295,10 @@
(syntax-error "non-auto field after auto fields" (syntax-error "non-auto field after auto fields"
(field-info-stx (car fields)))))))]) (field-info-stx (car fields)))))))])
(with-syntax ([ctc-bindings (with-syntax ([ctc-bindings
(let ([val-bindings (if (s-info-def-vals? sinfo) (if (s-info-def-vals? sinfo)
(cons (cadr names) (map list (cddr names)
(map list (cddr names) ctcs)
ctcs)) null)]
null)])
(if (s-info-def-stxs? sinfo)
(cons (car names) val-bindings)
val-bindings))]
[orig stx] [orig stx]
[struct-name (syntax-case #'name () [struct-name (syntax-case #'name ()
[id (identifier? #'id) #'id] [id (identifier? #'id) #'id]
@ -388,11 +384,14 @@
(make-set!-transformer (make-set!-transformer
(lambda (stx) (lambda (stx)
(syntax-case stx (set!) (syntax-case stx (set!)
[(set! id arg) [(set! i arg)
(raise-syntax-error 'with-contract (quasisyntax/loc stx
"cannot set! a contracted variable" (set! #,id
stx (contract #,contract-stx
(syntax id))] arg
#,neg-blame-id
#,pos-blame-id
#,(id->contract-src-info id))))]
[(f arg ...) [(f arg ...)
(quasisyntax/loc stx (quasisyntax/loc stx
((contract #,contract-stx ((contract #,contract-stx
@ -410,76 +409,13 @@
#,neg-blame-id #,neg-blame-id
#,(id->contract-src-info id)))])))) #,(id->contract-src-info id)))]))))
(define-for-syntax (check-and-split-with-contracts args)
(define-syntax (with-contract-helper stx)
(syntax-case stx ()
[(_ () ())
(begin #'(define-values () (values)))]
[(_ (p0 p ...) (u ...))
(raise-syntax-error 'with-contract
"no definition found for identifier"
#'p0)]
[(_ () (u0 u ...))
(raise-syntax-error 'with-contract
"no definition found for identifier"
#'u0)]
[(_ (p ...) (u ...) body0 body ...)
(let ([expanded-body0 (local-expand #'body0
(syntax-local-context)
(kernel-form-identifier-list))])
(define (filter-ids to-filter to-remove)
(filter (λ (i1)
(not (memf (λ (i2)
(bound-identifier=? i1 i2))
to-remove)))
to-filter))
(syntax-case expanded-body0 (begin define-values define-syntaxes)
[(begin sub ...)
(syntax/loc stx
(with-contract-helper (p ...) (u ...) sub ... body ...))]
[(define-syntaxes (id ...) expr)
(let ([ids (syntax->list #'(id ...))])
(for ([i1 (syntax->list #'(p ...))])
(when (ormap (λ (i2)
(bound-identifier=? i1 i2))
ids)
(raise-syntax-error 'with-contract
"cannot export syntax with a contract"
i1)))
(with-syntax ([def expanded-body0]
[unused-us (filter-ids (syntax->list #'(u ...)) ids)])
(with-syntax ()
(syntax/loc stx
(begin def (with-contract-helper (p ...) unused-us body ...))))))]
[(define-values (id ...) expr)
(let ([ids (syntax->list #'(id ...))])
(with-syntax ([def expanded-body0]
[unused-ps (filter-ids (syntax->list #'(p ...)) ids)]
[unused-us (filter-ids (syntax->list #'(u ...)) ids)])
(syntax/loc stx
(begin def (with-contract-helper unused-ps unused-us body ...)))))]
[else
(quasisyntax/loc stx
(begin #,expanded-body0
(with-contract-helper (p ...) (u ...) body ...)))]))]))
(define-for-syntax (check-and-split-with-contracts single-allowed? args)
(let loop ([args args] (let loop ([args args]
[unprotected null]
[protected null] [protected null]
[protections null]) [protections null])
(cond (cond
[(null? args) [(null? args)
(values unprotected protected protections)] (values protected protections)]
[(identifier? (car args))
(unless single-allowed?
(raise-syntax-error 'with-contract
"expected (identifier contract)"
(car args)))
(loop (cdr args)
(cons (car args) unprotected)
protected
protections)]
[(let ([lst (syntax->list (car args))]) [(let ([lst (syntax->list (car args))])
(and (list? lst) (and (list? lst)
(= (length lst) 2) (= (length lst) 2)
@ -488,13 +424,11 @@
=> =>
(lambda (l) (lambda (l)
(loop (cdr args) (loop (cdr args)
unprotected
(cons (first l) protected) (cons (first l) protected)
(cons (second l) protections)))] (cons (second l) protections)))]
[else [else
(raise-syntax-error 'with-contract (raise-syntax-error 'with-contract
(format "expected ~a(identifier contract)" "expected (identifier contract)"
(if single-allowed? "an identifier or " ""))
(car args))]))) (car args))])))
(define-syntax (with-contract stx) (define-syntax (with-contract stx)
@ -524,77 +458,90 @@
[(_ #:type type blame (arg ...) #:freevars (fv ...) . body) [(_ #:type type blame (arg ...) #:freevars (fv ...) . body)
(and (identifier? #'blame) (and (identifier? #'blame)
(identifier? #'type)) (identifier? #'type))
(let*-values ([(marker) (make-syntax-introducer)] (let*-values ([(intdef) (syntax-local-make-definition-context)]
[(ctx) (list (gensym 'intdef))]
[(cid-marker) (make-syntax-introducer)] [(cid-marker) (make-syntax-introducer)]
[(no-need free-vars free-ctcs) [(free-vars free-ctcs)
(check-and-split-with-contracts #f (syntax->list #'(fv ...)))] (check-and-split-with-contracts (syntax->list #'(fv ...)))]
[(unprotected protected protections) [(protected protections)
(check-and-split-with-contracts #t (syntax->list #'(arg ...)))]) (check-and-split-with-contracts (syntax->list #'(arg ...)))])
(begin (define (add-context stx)
(let ([dupd-id (check-duplicate-identifier (append unprotected protected))]) (let ([ctx-added-stx (local-expand #`(quote #,stx)
(when dupd-id ctx
(raise-syntax-error 'with-contract (list #'quote)
"identifier appears twice in exports" intdef)])
dupd-id))) (syntax-case ctx-added-stx ()
(with-syntax ([blame-stx #''(type blame)] [(_ expr) #'expr])))
[blame-id (car (generate-temporaries (list #t)))] (when (eq? (syntax-local-context) 'expression)
[(free-var ...) free-vars] (raise-syntax-error 'with-contract
[(free-var-id ...) (map marker free-vars)] "cannot use in an expression context"
[(free-ctc-id ...) (map cid-marker free-vars)] stx))
[(free-ctc ...) (map (λ (c v) (let ([dupd-id (check-duplicate-identifier protected)])
(syntax-property c 'inferred-name v)) (when dupd-id
free-ctcs (raise-syntax-error 'with-contract
free-vars)] "identifier appears twice in exports"
[(free-src-info ...) (map id->contract-src-info free-vars)] dupd-id)))
[(ctc-id ...) (map cid-marker protected)] (syntax-local-bind-syntaxes protected #f intdef)
[(ctc ...) (map (λ (c v) (syntax-local-bind-syntaxes free-vars #f intdef)
(marker (syntax-property c 'inferred-name v))) (internal-definition-context-seal intdef)
protections (with-syntax ([blame-stx #''(type blame)]
protected)] [blame-id (car (generate-temporaries (list #t)))]
[(p ...) protected] [(free-var ...) free-vars]
[(marked-p ...) (map marker protected)] [(free-var-id ...) (add-context #`#,free-vars)]
[(src-info ...) (map (compose id->contract-src-info marker) protected)] [(free-ctc-id ...) (map cid-marker free-vars)]
[(u ...) unprotected] [(free-ctc ...) (map (λ (c v)
[(marked-u ...) (map marker unprotected)]) (syntax-property c 'inferred-name v))
free-ctcs
free-vars)]
[(free-src-info ...) (map id->contract-src-info free-vars)]
[(ctc-id ...) (map cid-marker protected)]
[(ctc ...) (map (λ (c v)
(syntax-property (add-context c) 'inferred-name v))
protections
protected)]
[(p ...) protected]
[(marked-p ...) (add-context #`#,protected)]
[(src-info ...) (map (compose id->contract-src-info add-context) protected)])
(with-syntax ([new-stx (add-context #'(splicing-syntax-parameterize
([current-contract-region (λ (stx) #'blame-stx)])
. body))])
(quasisyntax/loc stx (quasisyntax/loc stx
(begin (begin
(define-values (free-ctc-id ...) (define-values (free-ctc-id ...)
(values (verify-contract 'with-contract free-ctc) ...)) (values (verify-contract 'with-contract free-ctc) ...))
(define blame-id (define blame-id
(current-contract-region)) (current-contract-region))
(define-values () (define-values ()
(begin (contract free-ctc-id (begin (contract free-ctc-id
free-var free-var
blame-id blame-id
'cant-happen 'cant-happen
free-src-info) free-src-info)
... ...
(values))) (values)))
(define-syntaxes (free-var-id ...) (define-syntaxes (free-var-id ...)
(values (make-contracted-id-transformer (values (make-contracted-id-transformer
(quote-syntax free-var) (quote-syntax free-var)
(quote-syntax free-ctc-id) (quote-syntax free-ctc-id)
(quote-syntax blame-id) (quote-syntax blame-id)
(quote-syntax blame-stx)) ...)) (quote-syntax blame-stx)) ...))
(splicing-syntax-parameterize ([current-contract-region (λ (stx) #'blame-stx)]) new-stx
(with-contract-helper (marked-p ...) (marked-u ...) . #,(marker #'body))) (define-values (ctc-id ...)
(define-values (ctc-id ...) (values (verify-contract 'with-contract ctc) ...))
(values (verify-contract 'with-contract ctc) ...)) (define-values ()
(define-values () (begin (contract ctc-id
(begin (contract ctc-id marked-p
marked-p blame-stx
blame-stx 'cant-happen
'cant-happen src-info)
src-info) ...
... (values)))
(values))) (define-syntaxes (p ...)
(define-syntaxes (u ... p ...) (values (make-contracted-id-transformer
(values (make-rename-transformer #'marked-u) ... (quote-syntax marked-p)
(make-contracted-id-transformer (quote-syntax ctc-id)
(quote-syntax marked-p) (quote-syntax blame-stx)
(quote-syntax ctc-id) (quote-syntax blame-id)) ...)))))))]
(quote-syntax blame-stx)
(quote-syntax blame-id)) ...)))))))]
[(_ #:type type blame (arg ...) #:freevar x c . body) [(_ #:type type blame (arg ...) #:freevar x c . body)
(syntax/loc stx (syntax/loc stx
(with-contract #:type type blame (arg ...) #:freevars ([x c]) . body))] (with-contract #:type type blame (arg ...) #:freevars ([x c]) . body))]

8
collects/scribblings/reference/contracts.scrbl
View File

@ -743,7 +743,6 @@ ensure that the exported functions are treated parametrically.
@defform/subs[ @defform/subs[
(with-contract blame-id (wc-export ...) free-var-list body ...+) (with-contract blame-id (wc-export ...) free-var-list body ...+)
([wc-export ([wc-export
id
(id contract-expr)] (id contract-expr)]
[free-var-list [free-var-list
code:blank code:blank
@ -752,10 +751,9 @@ ensure that the exported functions are treated parametrically.
Generates a local contract boundary. The @scheme[contract-expr] Generates a local contract boundary. The @scheme[contract-expr]
form cannot appear in expression position. The @scheme[body] of the form cannot appear in expression position. The @scheme[body] of the
form allows definition/expression interleaving like a @scheme[module] form allows definition/expression interleaving like a @scheme[module]
body. Names bound within the @scheme[body] must be exported to be body. All names defined within the @scheme[with-contract] form are
accessible from outside the @scheme[with-contract] form. Such visible externally, but those names listed in the @scheme[wc-export]
@scheme[id]s can either be paired with a @scheme[contract-expr] or list are protected with the corresponding contract.
exported without a contract.
The @scheme[blame-id] is used for the positive positions of The @scheme[blame-id] is used for the positive positions of
contracts paired with exported @scheme[id]s. Contracts broken contracts paired with exported @scheme[id]s. Contracts broken

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

@ -2940,9 +2940,30 @@
(test/spec-passed (test/spec-passed
'with-contract9 'with-contract9
'(let () '(let ()
(with-contract region1 (f) (with-contract region1 ()
(define f 3)) (define f 3))
f)) f))
(test/spec-failed
'with-contract10
'(let ()
(with-contract r
([x number?])
(define x 3)
(define-values ()
(begin (set! x #f) (values))))
x)
"(region r)")
(test/spec-failed
'with-contract11
'(let ()
(with-contract r
([x number?])
(define x 3))
(set! x #f)
x)
"top-level")
; ;
; ;