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

Add with-contract for expression positions.

Browse Source 
svn: r18372
This commit is contained in:
Stevie Strickland 2010-02-27 01:05:03 +00:00
parent e54f1c3a5e
commit 7dacfaea85
3 changed files with 207 additions and 137 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -9,8 +9,11 @@
scheme/struct-info scheme/struct-info
syntax/define syntax/define
syntax/kerncase syntax/kerncase
syntax/parse
unstable/syntax
(prefix-in a: "private/helpers.ss")) (prefix-in a: "private/helpers.ss"))
scheme/splicing scheme/splicing
scheme/stxparam
"private/arrow.ss" "private/arrow.ss"
"private/base.ss" "private/base.ss"
"private/guts.ss") "private/guts.ss")
@ -87,7 +90,7 @@
[body-expr body-expr] [body-expr body-expr]
[type (if (identifier? #'name+arg-list) 'definition 'function)]) [type (if (identifier? #'name+arg-list) 'definition 'function)])
(syntax/loc define-stx (syntax/loc define-stx
(with-contract #:type type name (with-contract #:region type name
([name contract]) ([name contract])
#:freevars args #:freevars args
(define name body-expr))))))] (define name body-expr))))))]
@ -337,7 +340,7 @@
(values super-fields ... non-auto-name ...)) (values super-fields ... non-auto-name ...))
(define blame-id (define blame-id
(current-contract-region)) (current-contract-region))
(with-contract #:type struct struct-name (with-contract #:region struct struct-name
ctc-bindings ctc-bindings
(define-struct/derived orig name (field ...) (define-struct/derived orig name (field ...)
kwds ... kwds ...
@ -404,28 +407,6 @@
(quote #,id) (quote #,id)
(quote-syntax #,id)))])))) (quote-syntax #,id)))]))))
(define-for-syntax (check-and-split-with-contracts args)
(let loop ([args args]
[protected null]
[protections null])
(cond
[(null? args)
(values protected protections)]
[(let ([lst (syntax->list (car args))])
(and (list? lst)
(= (length lst) 2)
(identifier? (first lst))
lst))
=>
(lambda (l)
(loop (cdr args)
(cons (first l) protected)
(cons (second l) protections)))]
[else
(raise-syntax-error 'with-contract
"expected (identifier contract)"
(car args))])))
(define-syntax (with-contract-helper stx) (define-syntax (with-contract-helper stx)
(syntax-case stx () (syntax-case stx ()
[(_ ()) [(_ ())
@ -467,39 +448,110 @@
(with-contract-helper (p ...) body ...)))]))])) (with-contract-helper (p ...) body ...)))]))]))
(define-syntax (with-contract stx) (define-syntax (with-contract stx)
(when (eq? (syntax-local-context) 'expression) (define-splicing-syntax-class region-clause
(raise-syntax-error 'with-contract #:description "contract region type"
"used in expression context" [pattern (~seq #:region region:id)])
stx)) (define-splicing-syntax-class fv-clause
(syntax-case stx () #:description "a free variable clause"
[(_ #:type type etc ...) #:attributes ([var 1] [ctc 1])
(not (identifier? #'type)) [pattern (~seq #:freevars ([var:id ctc:expr] ...))]
(raise-syntax-error 'with-contract [pattern (~seq #:freevar v:id c:expr)
"expected identifier for type" #:with (var ...) (list #'v)
#'type)] #:with (ctc ...) (list #'c)])
[(_ #:type type args etc ...) (define-splicing-syntax-class fvs
(not (identifier? #'args)) #:description "a sequence of free variable clauses"
(raise-syntax-error 'with-contract #:attributes ([var 1] [ctc 1])
"expected identifier for blame" [pattern (~seq f:fv-clause ...)
#'args)] #:with (var ...) #'(f.var ... ...)
[(_ #:type type blame (arg ...) #:freevars (fv ...) #:freevar x c . body) #:with (ctc ...) #'(f.ctc ... ...)
(identifier? #'x) #:fail-when (check-duplicate-identifier (syntax->list #'(var ...)))
(syntax/loc stx (format "duplicate imported name ~a"
(with-contract #:type type blame (arg ...) #:freevars (fv ... [x c]) . body))] (syntax-e (check-duplicate-identifier (syntax->list #'(var ...)))))])
[(_ #:type type blame (arg ...) #:freevars (fv ...) #:freevar x c . body) (define-syntax-class export-clause
(raise-syntax-error 'with-contract #:description "a name/contract pair"
"use of #:freevar with non-identifier" [pattern (var:id ctc:expr)])
#'x)] (define-syntax-class exports-clause
[(_ #:type type blame (arg ...) #:freevars (fv ...) . body) #:attributes ([var 1] [ctc 1])
(and (identifier? #'blame) #:description "a sequence of name/contract pairs"
(identifier? #'type)) [pattern (ec:export-clause ...)
#:with (var ...) #'(ec.var ...)
#:with (ctc ...) #'(ec.ctc ...)
#:fail-when (check-duplicate-identifier (syntax->list #'(var ...)))
(format "duplicate exported name ~a"
(syntax-e (check-duplicate-identifier (syntax->list #'(var ...)))))])
(define-splicing-syntax-class result-clause
#:description "a results clause"
[pattern (~seq #:result ctc:expr)])
(syntax-parse stx
[(_ (~optional :region-clause #:defaults ([region #'region])) blame:id rc:result-clause fv:fvs . body)
(if (not (eq? (syntax-local-context) 'expression))
(quasisyntax/loc stx (#%expression #,stx))
(let*-values ([(intdef) (syntax-local-make-definition-context)]
[(ctx) (list (gensym 'intdef))]
[(cid-marker) (make-syntax-introducer)]
[(free-vars free-ctcs)
(values (syntax->list #'(fv.var ...))
(syntax->list #'(fv.ctc ...)))])
(define (add-context stx)
(let ([ctx-added-stx (local-expand #`(quote #,stx)
ctx
(list #'quote)
intdef)])
(syntax-case ctx-added-stx ()
[(_ expr) #'expr])))
(syntax-local-bind-syntaxes free-vars #f intdef)
(internal-definition-context-seal intdef)
(with-syntax ([blame-stx #''(region blame)]
[blame-id (generate-temporary)]
[(free-var ...) free-vars]
[(free-var-id ...) (add-context #`#,free-vars)]
[(free-ctc-id ...) (map cid-marker free-vars)]
[(free-ctc ...) (map (λ (c v)
(syntax-property c 'inferred-name v))
free-ctcs
free-vars)])
(with-syntax ([new-stx (add-context #'(syntax-parameterize
([current-contract-region (λ (stx) #'blame-stx)])
(contract (verify-contract 'with-contract rc.ctc)
(let () . body)
blame-stx
blame-id)))])
(quasisyntax/loc stx
(let ()
(define-values (free-ctc-id ...)
(values (verify-contract 'with-contract free-ctc) ...))
(define blame-id
(current-contract-region))
(define-values ()
(begin (contract free-ctc-id
free-var
blame-id
'cant-happen
(quote free-var)
(quote-syntax free-var))
...
(values)))
(define-syntaxes (free-var-id ...)
(values (make-contracted-id-transformer
(quote-syntax free-var)
(quote-syntax free-ctc-id)
(quote-syntax blame-id)
(quote-syntax blame-stx)) ...))
new-stx))))))]
[(_ (~optional :region-clause #:defaults ([region #'region])) blame:id ec:exports-clause fv:fvs . body)
(when (memq (syntax-local-context) '(expression module-begin))
(raise-syntax-error 'with-contract
"not used in definition context"
stx))
(let*-values ([(intdef) (syntax-local-make-definition-context)] (let*-values ([(intdef) (syntax-local-make-definition-context)]
[(ctx) (list (gensym 'intdef))] [(ctx) (list (gensym 'intdef))]
[(cid-marker) (make-syntax-introducer)] [(cid-marker) (make-syntax-introducer)]
[(free-vars free-ctcs) [(free-vars free-ctcs)
(check-and-split-with-contracts (syntax->list #'(fv ...)))] (values (syntax->list #'(fv.var ...))
(syntax->list #'(fv.ctc ...)))]
[(protected protections) [(protected protections)
(check-and-split-with-contracts (syntax->list #'(arg ...)))]) (values (syntax->list #'(ec.var ...))
(syntax->list #'(ec.ctc ...)))])
(define (add-context stx) (define (add-context stx)
(let ([ctx-added-stx (local-expand #`(quote #,stx) (let ([ctx-added-stx (local-expand #`(quote #,stx)
ctx ctx
@ -507,20 +559,11 @@
intdef)]) intdef)])
(syntax-case ctx-added-stx () (syntax-case ctx-added-stx ()
[(_ expr) #'expr]))) [(_ expr) #'expr])))
(when (eq? (syntax-local-context) 'expression)
(raise-syntax-error 'with-contract
"cannot use in an expression context"
stx))
(let ([dupd-id (check-duplicate-identifier protected)])
(when dupd-id
(raise-syntax-error 'with-contract
"identifier appears twice in exports"
dupd-id)))
(syntax-local-bind-syntaxes protected #f intdef) (syntax-local-bind-syntaxes protected #f intdef)
(syntax-local-bind-syntaxes free-vars #f intdef) (syntax-local-bind-syntaxes free-vars #f intdef)
(internal-definition-context-seal intdef) (internal-definition-context-seal intdef)
(with-syntax ([blame-stx #''(type blame)] (with-syntax ([blame-stx #''(region blame)]
[blame-id (car (generate-temporaries (list #t)))] [blame-id (generate-temporary)]
[(free-var ...) free-vars] [(free-var ...) free-vars]
[(free-var-id ...) (add-context #`#,free-vars)] [(free-var-id ...) (add-context #`#,free-vars)]
[(free-ctc-id ...) (map cid-marker free-vars)] [(free-ctc-id ...) (map cid-marker free-vars)]
@ -539,58 +582,41 @@
([current-contract-region (λ (stx) #'blame-stx)]) ([current-contract-region (λ (stx) #'blame-stx)])
. body))]) . 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
(quote free-var) (quote free-var)
(quote-syntax free-var)) (quote-syntax free-var))
... ...
(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)) ...))
(with-contract-helper (marked-p ...) new-stx) (with-contract-helper (marked-p ...) new-stx)
(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
(quote marked-p) (quote marked-p)
(quote-syntax marked-p)) (quote-syntax marked-p))
... ...
(values))) (values)))
(define-syntaxes (p ...) (define-syntaxes (p ...)
(values (make-contracted-id-transformer (values (make-contracted-id-transformer
(quote-syntax marked-p) (quote-syntax marked-p)
(quote-syntax ctc-id) (quote-syntax ctc-id)
(quote-syntax blame-stx) (quote-syntax blame-stx)
(quote-syntax blame-id)) ...)))))))] (quote-syntax blame-id)) ...)))))))]))
[(_ #:type type blame (arg ...) #:freevar x c . body)
(syntax/loc stx
(with-contract #:type type blame (arg ...) #:freevars ([x c]) . body))]
[(_ #:type type blame (arg ...) . body)
(syntax/loc stx
(with-contract #:type type blame (arg ...) #:freevars () . body))]
[(_ #:type type blame bad-args etc ...)
(raise-syntax-error 'with-contract
"expected list of identifier and/or (identifier contract)"
#'bad-args)]
[(_ #:type type blame)
(raise-syntax-error 'with-contract
"only blame"
stx)]
[(_ etc ...)
(syntax/loc stx
(with-contract #:type region etc ...))]))

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

@ -743,20 +743,28 @@ expression to new contracts that hide the values they accept and
ensure that the exported functions are treated parametrically. 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 ...+)
(with-contract blame-id result-spec free-var-list ... body ...+)
([wc-export ([wc-export
(id contract-expr)] (id contract-expr)]
[result-spec
(code:line #:result contract-expr)]
[free-var-list [free-var-list
code:blank
(code:line #:freevars ([id contract-expr] ...)) (code:line #:freevars ([id contract-expr] ...))
(code:line #:freevar id contract-expr)])]{ (code:line #:freevar id contract-expr)])]{
Generates a local contract boundary. The @scheme[contract-expr] Generates a local contract boundary.
form cannot appear in expression position. The @scheme[body] of the
form allows definition/expression interleaving like a @scheme[module] The first @scheme[with-contract] form cannot appear in expression position.
body. All names defined within the @scheme[with-contract] form are All names defined within the first @scheme[with-contract] form are
visible externally, but those names listed in the @scheme[wc-export] visible externally, but those names listed in the @scheme[wc-export]
list are protected with the corresponding contract. list are protected with the corresponding contract. The @scheme[body] of
the form allows definition/expression interleaving if its context does.
The second @scheme[with-contract] form must appear in expression position.
The result of the final @scheme[body] expression is contracted with
the contract listed in the @scheme[result-spec]. The sequence of @scheme[body]
forms is treated as for @scheme[let].
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

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

@ -2878,7 +2878,7 @@
; ;
(test/spec-passed (test/spec-passed
'with-contract1 'with-contract-def-1
'(let () '(let ()
(with-contract odd-even (with-contract odd-even
([oddp (-> number? boolean?)] ([oddp (-> number? boolean?)]
@ -2890,7 +2890,7 @@
(oddp 5))) (oddp 5)))
(test/spec-failed (test/spec-failed
'with-contract2 'with-contract-def-2
'(let () '(let ()
(with-contract odd-even (with-contract odd-even
([oddp (-> number? boolean?)] ([oddp (-> number? boolean?)]
@ -2903,7 +2903,7 @@
"top-level") "top-level")
(test/spec-failed (test/spec-failed
'with-contract3 'with-contract-def-3
'(let () '(let ()
(with-contract odd-even (with-contract odd-even
([oddp (-> number? boolean?)] ([oddp (-> number? boolean?)]
@ -2920,7 +2920,7 @@
;; call odd? with a boolean, even though its contract in ;; call odd? with a boolean, even though its contract in
;; the odd-even contract says it only takes numbers. ;; the odd-even contract says it only takes numbers.
(test/spec-passed (test/spec-passed
'with-contract4 'with-contract-def-4
'(let () '(let ()
(with-contract odd-even (with-contract odd-even
([oddp (-> number? boolean?)] ([oddp (-> number? boolean?)]
@ -2935,7 +2935,7 @@
(oddp 5))) (oddp 5)))
(test/spec-passed (test/spec-passed
'with-contract5 'with-contract-def-5
'(let () '(let ()
(with-contract region1 (with-contract region1
([x (-> number? number?)]) ([x (-> number? number?)])
@ -2946,7 +2946,7 @@
(x 4))) (x 4)))
(test/spec-failed (test/spec-failed
'with-contract6 'with-contract-def-6
'(let () '(let ()
(with-contract region1 (with-contract region1
([x (-> number? number?)]) ([x (-> number? number?)])
@ -2958,7 +2958,7 @@
"(region region1)") "(region region1)")
(test/spec-failed (test/spec-failed
'with-contract7 'with-contract-def-7
'(let () '(let ()
(with-contract region1 (with-contract region1
([x (-> number? number?)]) ([x (-> number? number?)])
@ -2970,7 +2970,7 @@
"(region region1)") "(region region1)")
(test/spec-failed (test/spec-failed
'with-contract8 'with-contract-def-8
'(let () '(let ()
(with-contract region1 (with-contract region1
([x (-> number? number?)]) ([x (-> number? number?)])
@ -2983,14 +2983,14 @@
;; make sure uncontracted exports make it out ;; make sure uncontracted exports make it out
(test/spec-passed (test/spec-passed
'with-contract9 'with-contract-def-9
'(let () '(let ()
(with-contract region1 () (with-contract region1 ()
(define f 3)) (define f 3))
f)) f))
(test/spec-failed (test/spec-failed
'with-contract10 'with-contract-def-10
'(let () '(let ()
(with-contract r (with-contract r
([x number?]) ([x number?])
@ -3001,7 +3001,7 @@
"(region r)") "(region r)")
(test/spec-failed (test/spec-failed
'with-contract11 'with-contract-def-11
'(let () '(let ()
(with-contract r (with-contract r
([x number?]) ([x number?])
@ -3009,6 +3009,42 @@
(set! x #f) (set! x #f)
x) x)
"top-level") "top-level")
(test/spec-passed
'with-contract-exp-1
'(with-contract r
#:result number?
3))
(test/spec-failed
'with-contract-exp-2
'(with-contract r
#:result number?
"foo")
"(region r)")
(test/spec-passed
'with-contract-exp-3
'((with-contract r
#:result (-> number? number?)
(λ (x) 5))
3))
(test/spec-failed
'with-contract-exp-4
'((with-contract r
#:result (-> number? number?)
(λ (x) (zero? x)))
3)
"(region r)")
(test/spec-failed
'with-contract-exp-5
'((with-contract r
#:result (-> number? number?)
(λ (x) 5))
#t)
"top-level")
; ;
; ;