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

Handle strings as blame, now add a description of the type of contract

Browse Source 
boundary that triggered the contract error.

svn: r11695
This commit is contained in:
Stevie Strickland 2008-09-12 18:49:08 +00:00
parent b309ced851
commit 019c2c8c34
2 changed files with 28 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
collects/scheme/private/contract-guts.ss
View File

@ -204,8 +204,9 @@
(pair? (cdr to-blame)) (pair? (cdr to-blame))
(null? (cddr to-blame)) (null? (cddr to-blame))
(equal? 'quote (car to-blame))) (equal? 'quote (car to-blame)))
(format "'~s" (cadr to-blame))] (format "module '~s" (cadr to-blame))]
[else (format "~s" to-blame)]) [(string? to-blame) to-blame]
[else (format "module ~s" to-blame)])
formatted-contract-sexp formatted-contract-sexp
specific-blame) specific-blame)
msg))) msg)))

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

@ -90,7 +90,7 @@ improve method arity mismatch contract violation error messages?
define-stx)] define-stx)]
[(_ name contract-expr expr) [(_ name contract-expr expr)
(identifier? (syntax name)) (identifier? (syntax name))
#'(with-contract name #'(with-contract #:type function name
([name (verify-contract 'define/contract contract-expr)]) ([name (verify-contract 'define/contract contract-expr)])
(define name expr))] (define name expr))]
[(_ name contract-expr expr0 expr ...) [(_ name contract-expr expr0 expr ...)
@ -132,7 +132,7 @@ improve method arity mismatch contract violation error messages?
(make-set!-transformer (make-set!-transformer
(lambda (stx) (lambda (stx)
(with-syntax ([neg-blame-id (or (syntax-parameter-value #'current-contract-region) (with-syntax ([neg-blame-id (or (syntax-parameter-value #'current-contract-region)
(a:module-source-as-symbol id))] #`(quote #,(a:module-source-as-symbol id)))]
[pos-blame-id pos-blame-id] [pos-blame-id pos-blame-id]
[contract-id contract-id] [contract-id contract-id]
[id id]) [id id])
@ -147,7 +147,7 @@ improve method arity mismatch contract violation error messages?
((-contract contract-id ((-contract contract-id
id id
pos-blame-id pos-blame-id
'neg-blame-id neg-blame-id
#'f) #'f)
arg ...))] arg ...))]
[ident [ident
@ -156,7 +156,7 @@ improve method arity mismatch contract violation error messages?
(-contract contract-id (-contract contract-id
id id
pos-blame-id pos-blame-id
'neg-blame-id neg-blame-id
#'ident))]))))) #'ident))])))))
(define-for-syntax (check-and-split-with-contract-args args) (define-for-syntax (check-and-split-with-contract-args args)
@ -194,8 +194,9 @@ improve method arity mismatch contract violation error messages?
"used in expression context" "used in expression context"
stx)) stx))
(syntax-case stx () (syntax-case stx ()
[(_ blame (arg ...) body0 body ...) [(_ #:type type blame (arg ...) body0 body ...)
(identifier? (syntax blame)) (and (identifier? #'blame)
(identifier? #'type))
(let-values ([(unprotected protected protections) (let-values ([(unprotected protected protections)
(check-and-split-with-contract-args (syntax->list #'(arg ...)))]) (check-and-split-with-contract-args (syntax->list #'(arg ...)))])
(with-syntax ([((protected-id id contract-id) ...) (with-syntax ([((protected-id id contract-id) ...)
@ -204,12 +205,13 @@ improve method arity mismatch contract violation error messages?
(a:mangle-id stx "with-contract-id" n) (a:mangle-id stx "with-contract-id" n)
(a:mangle-id stx "with-contract-contract-id" n))) (a:mangle-id stx "with-contract-contract-id" n)))
protected)] protected)]
[blame-str (format "~a ~a" (syntax-e #'type) (syntax-e #'blame))]
[(contract-expr ...) protections] [(contract-expr ...) protections]
[(unprotected-id ...) unprotected]) [(unprotected-id ...) unprotected])
(syntax/loc stx (syntax/loc stx
(begin (begin
(define-values (unprotected-id ... id ...) (define-values (unprotected-id ... id ...)
(syntax-parameterize ([current-contract-region (quote blame)]) (syntax-parameterize ([current-contract-region blame-str])
(begin-with-definitions (begin-with-definitions
body0 body ... body0 body ...
(values unprotected-id ... protected-id ...)))) (values unprotected-id ... protected-id ...))))
@ -218,19 +220,30 @@ improve method arity mismatch contract violation error messages?
(make-with-contract-transformer (make-with-contract-transformer
(quote-syntax contract-id) (quote-syntax contract-id)
(quote-syntax id) (quote-syntax id)
(quote-syntax (quote blame)))) ...))))] blame-str)) ...))))]
[(_ blame (arg ...) body0 body ...) [(_ #:type type blame (arg ...) body0 body ...)
(identifier? #'blame)
(raise-syntax-error 'with-contract (raise-syntax-error 'with-contract
"expected identifier" "expected identifier for type"
#'type)]
[(_ #:type type blame (arg ...) body0 body ...)
(raise-syntax-error 'with-contract
"expected identifier for blame"
#'blame)] #'blame)]
[(_ blame (arg ...) body0 body ...)
#'(with-contract #:type region blame (arg ...) body0 body ...)]
[(_ blame (arg ...)) [(_ blame (arg ...))
(raise-syntax-error 'with-contract (raise-syntax-error 'with-contract
"empty body" "empty body"
stx)] stx)]
[(_ blame bad-args body0 body ...) [(_ blame bad-args etc ...)
(raise-syntax-error 'with-contract (raise-syntax-error 'with-contract
"expected list of identifier and/or (identifier contract)" "expected list of identifier and/or (identifier contract)"
#'bad-args)])) #'bad-args)]
[(_ blame)
(raise-syntax-error 'with-contract
"only blame"
stx)]))
; ;
; ;