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

Use old inefficient implementation for top-level for now.

Browse Source
This commit is contained in:
Stevie Strickland 2013-03-09 09:08:17 -05:00
parent b1db073ab8
commit 2fb49aca15
1 changed files with 122 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -559,6 +559,10 @@
(raise-syntax-error 'with-contract (raise-syntax-error 'with-contract
"no definition found for identifier" "no definition found for identifier"
#'p0)] #'p0)]
[(_ (p0 p ...))
(raise-syntax-error 'with-contract
"no definition found for identifier"
#'p0)]
;; p = internal id (transformer binding) ;; p = internal id (transformer binding)
;; b = bare (internal) id ;; b = bare (internal) id
;; e = bare (external) id ;; e = bare (external) id
@ -601,7 +605,38 @@
[else [else
(quasisyntax/loc stx (quasisyntax/loc stx
(begin #,expanded-body0 (begin #,expanded-body0
(with-contract-helper ((p b e e-expr) ...) body ...)))]))])) (with-contract-helper ((p b e e-expr) ...) body ...)))]))]
;; Old expansion, used for top-level
[(_ (p ...) body0 body ...)
(andmap identifier? (syntax->list #'(p ...)))
(let ([expanded-body0 (local-expand #'body0
(syntax-local-context)
(kernel-form-identifier-list))])
(define (filter-ids to-filter to-remove)
(filter (λ (id1)
(not (memf (λ (id2) (bound-identifier=? id1 id2)) to-remove)))
to-filter))
(syntax-case expanded-body0 (begin define-values define-syntaxes)
[(begin sub ...)
(syntax/loc stx
(with-contract-helper (p ...) sub ... body ...))]
[(define-syntaxes (id ...) expr)
(let ([ids (syntax->list #'(id ...))])
(with-syntax ([def expanded-body0]
[unused-ps (filter-ids (syntax->list #'(p ...)) ids)])
(syntax/loc stx
(begin def (with-contract-helper unused-ps body ...)))))]
[(define-values (id ...) expr)
(let ([ids (syntax->list #'(id ...))])
(with-syntax ([def expanded-body0]
[unused-ps (filter-ids (syntax->list #'(p ...)) ids)])
(syntax/loc stx
(begin def (with-contract-helper unused-ps body ...)))))]
[else
(quasisyntax/loc stx
(begin #,expanded-body0
(with-contract-helper (p ...) body ...)))]))]))
(define-syntax (with-contract stx) (define-syntax (with-contract stx)
(define-splicing-syntax-class region-clause (define-splicing-syntax-class region-clause
@ -736,49 +771,89 @@
(with-syntax ([new-stx (add-context #'(splicing-syntax-parameterize (with-syntax ([new-stx (add-context #'(splicing-syntax-parameterize
([current-contract-region (λ (stx) #'blame-stx)]) ([current-contract-region (λ (stx) #'blame-stx)])
. body))]) . body))])
(syntax/loc stx (if (eq? (syntax-local-context) 'top-level)
(begin (syntax/loc stx
(define-values (free-ctc-id ...) (begin
(values (verify-contract 'with-contract free-ctc) ...)) (define-values (free-ctc-id ...)
(define blame-id (values (verify-contract 'with-contract free-ctc) ...))
(current-contract-region)) (define blame-id
(define-values () (current-contract-region))
(begin (contract free-ctc-id (define-values ()
free-var (begin (contract free-ctc-id
blame-id free-var
'cant-happen blame-id
(quote free-var) 'cant-happen
(quote-srcloc free-var)) (quote free-var)
... (quote-srcloc free-var))
(values))) ...
(define-syntaxes (free-var-id ...) (values)))
(values (make-contracted-id-transformer (define-syntaxes (free-var-id ...)
(quote-syntax free-var) (values (make-contracted-id-transformer
(quote-syntax free-ctc-id) (quote-syntax free-var)
(quote-syntax blame-id) (quote-syntax free-ctc-id)
(quote-syntax blame-stx)) ...)) (quote-syntax blame-id)
(define-syntaxes (marked-p ...) (quote-syntax blame-stx)) ...))
(values (make-internal-contracted-id-transformer (with-contract-helper (marked-p ...) new-stx)
(quote-syntax true-p) (define-values (ctc-id ...)
(quote-syntax ext-id) (values (verify-contract 'with-contract ctc) ...))
(quote-syntax ctc-id) (define-values ()
(quote-syntax blame-stx) (begin (contract ctc-id
(quote-syntax blame-id)) ...)) marked-p
(with-contract-helper ((marked-p blame-stx
true-p 'cant-happen
ext-id (quote marked-p)
(λ () (quote-srcloc marked-p))
(let ([x (contract ctc-id true-p blame-stx blame-id (quote ext-id) (quote-srcloc ext-id))]) ...
(set! ext-id (λ () x)) (values)))
x))) (define-syntaxes (p ...)
...) (values (make-contracted-id-transformer
new-stx) (quote-syntax marked-p)
(define-values (ctc-id ...) (quote-syntax ctc-id)
(values (verify-contract 'with-contract ctc) ...)) (quote-syntax blame-stx)
(define-syntaxes (p ...) (quote-syntax blame-id)) ...))))
(values (make-external-contracted-id-transformer (syntax/loc stx
(quote-syntax true-p) (begin
(quote-syntax ext-id) (define-values (free-ctc-id ...)
(quote-syntax ctc-id) (values (verify-contract 'with-contract free-ctc) ...))
(quote-syntax blame-stx) (define blame-id
(quote-syntax blame-id)) ...)))))))])) (current-contract-region))
(define-values ()
(begin (contract free-ctc-id
free-var
blame-id
'cant-happen
(quote free-var)
(quote-srcloc 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)) ...))
(define-syntaxes (marked-p ...)
(values (make-internal-contracted-id-transformer
(quote-syntax true-p)
(quote-syntax ext-id)
(quote-syntax ctc-id)
(quote-syntax blame-stx)
(quote-syntax blame-id)) ...))
(with-contract-helper ((marked-p
true-p
ext-id
(λ ()
(let ([x (contract ctc-id true-p blame-stx blame-id (quote ext-id) (quote-srcloc ext-id))])
(set! ext-id (λ () x))
x)))
...)
new-stx)
(define-values (ctc-id ...)
(values (verify-contract 'with-contract ctc) ...))
(define-syntaxes (p ...)
(values (make-external-contracted-id-transformer
(quote-syntax true-p)
(quote-syntax ext-id)
(quote-syntax ctc-id)
(quote-syntax blame-stx)
(quote-syntax blame-id)) ...))))))))]))