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

43
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,16 +140,15 @@ 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!)
@ -156,21 +158,21 @@ improve method arity mismatch contract violation error messages?
stx stx
(syntax id))] (syntax id))]
[(f arg ...) [(f arg ...)
(syntax/loc stx (quasisyntax/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))
(syntax/loc stx (quasisyntax/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 introducer (syntax->list (syntax (name ...))))] (map (lambda (n)
(a:mangle-id stx "with-contract-id" n))
(syntax->list (syntax (name ...))))]
[(contract-id ...) [(contract-id ...)
(map (lambda (n) (map (lambda (n)
(a:mangle-id stx "with-contract-contract-id" n)) (a:mangle-id stx "with-contract-contract-id" n))
(syntax->list (syntax (name ...))))] (syntax->list (syntax (name ...))))])
[(new-body ...)
(map introducer
(syntax->list (syntax (body0 body ...))))])
(syntax/loc stx (syntax/loc stx
(begin (begin
(define-values (id ...)
(syntax-parameterize ([current-contract-region (quote blame)])
body0 body ...
(values name ...)))
(define contract-id contract-expr) ... (define contract-id contract-expr) ...
(define-syntax name (define-syntax name
(make-with-contract-transformer (make-with-contract-transformer
(quote-syntax contract-id) (quote-syntax contract-id)
(quote-syntax id) (quote-syntax id)
(quote-syntax blame))) ... (quote-syntax (quote blame)))) ...)))])))
new-body ...))))])))
; ;
; ;