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

Thanks to Sam and Carl, finally got this working like I wanted it.

Browse Source 
svn: r11645
This commit is contained in:
Stevie Strickland 2008-09-11 16:51:36 +00:00
parent 2d6f787865
commit cb07ceefff
1 changed files with 53 additions and 50 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

103
collects/scheme/private/contract.ss
View File

@ -13,12 +13,15 @@ improve method arity mismatch contract violation error messages?
recursive-contract recursive-contract
provide/contract provide/contract
define/contract define/contract
with-contract) with-contract
current-contract-region)
(require (for-syntax scheme/base) (require (for-syntax scheme/base)
(for-syntax "contract-opt-guts.ss") (for-syntax "contract-opt-guts.ss")
(for-syntax scheme/struct-info) (for-syntax scheme/struct-info)
(for-syntax scheme/list) (for-syntax scheme/list)
scheme/stxparam
scheme/stxparam-exptime
scheme/promise) scheme/promise)
(require "contract-arrow.ss" (require "contract-arrow.ss"
@ -137,40 +140,39 @@ improve method arity mismatch contract violation error messages?
; ;
; ;
(define-for-syntax current-contract-region (make-parameter #f)) (define-syntax-parameter current-contract-region #f)
(define-for-syntax (make-with-contract-transformer contract-id id pos-blame-id) (define-for-syntax (make-with-contract-transformer contract-id id pos-blame-id)
(make-set!-transformer (make-set!-transformer
(lambda (stx) (lambda (stx)
(let ([neg-blame-id (cond #;(printf "~a\n" (syntax-parameter-value #'current-contract-region))
[(current-contract-region) => values] (with-syntax ([neg-blame-id (or (syntax-parameter-value #'current-contract-region)
[else #`(module-source-as-symbol #'#,id)])]) (a:module-source-as-symbol id))]
(with-syntax ([neg-blame-id neg-blame-id] [pos-blame-id pos-blame-id]
[pos-blame-id #`(quote #,(syntax-e pos-blame-id))] [contract-id contract-id]
[contract-id contract-id] [id id])
[id id]) (syntax-case stx (set!)
(syntax-case stx (set!) [(set! id arg)
[(set! id arg) (raise-syntax-error 'with-contract
(raise-syntax-error 'with-contract "cannot set! a with-contract variable"
"cannot set! a with-contract variable" stx
stx (syntax id))]
(syntax id))] [(f arg ...)
[(f arg ...) (quasisyntax/loc stx
(syntax/loc stx ((-contract contract-id
((-contract contract-id id
id pos-blame-id
pos-blame-id 'neg-blame-id
neg-blame-id (quote-syntax f))
(quote-syntax f)) arg ...))]
arg ...))] [ident
[ident (identifier? (syntax ident))
(identifier? (syntax ident)) (quasisyntax/loc stx
(syntax/loc stx (-contract contract-id
(-contract contract-id id
id pos-blame-id
pos-blame-id 'neg-blame-id
neg-blame-id (quote-syntax ident)))])))))
(quote-syntax ident)))]))))))
(define-syntax (with-contract stx) (define-syntax (with-contract stx)
(let ([introducer (make-syntax-introducer)]) (let ([introducer (make-syntax-introducer)])
@ -178,25 +180,26 @@ improve method arity mismatch contract violation error messages?
[(_ blame ([name contract-expr] ...) body0 body ...) [(_ blame ([name contract-expr] ...) body0 body ...)
(and (identifier? (syntax blame)) (and (identifier? (syntax blame))
(andmap identifier? (syntax->list (syntax (name ...))))) (andmap identifier? (syntax->list (syntax (name ...)))))
(parameterize ([current-contract-region (syntax-e (syntax blame))]) (with-syntax ([(id ...)
(with-syntax ([(id ...) (map (lambda (n)
(map introducer (syntax->list (syntax (name ...))))] (a:mangle-id stx "with-contract-id" n))
[(contract-id ...) (syntax->list (syntax (name ...))))]
(map (lambda (n) [(contract-id ...)
(a:mangle-id stx "with-contract-contract-id" n)) (map (lambda (n)
(syntax->list (syntax (name ...))))] (a:mangle-id stx "with-contract-contract-id" n))
[(new-body ...) (syntax->list (syntax (name ...))))])
(map introducer (syntax/loc stx
(syntax->list (syntax (body0 body ...))))]) (begin
(syntax/loc stx (define-values (id ...)
(begin (syntax-parameterize ([current-contract-region (quote blame)])
(define contract-id contract-expr) ... body0 body ...
(define-syntax name (values name ...)))
(make-with-contract-transformer (define contract-id contract-expr) ...
(quote-syntax contract-id) (define-syntax name
(quote-syntax id) (make-with-contract-transformer
(quote-syntax blame))) ... (quote-syntax contract-id)
new-body ...))))]))) (quote-syntax id)
(quote-syntax (quote blame)))) ...)))])))
; ;
; ;