added contract-violation->string parameter
svn: r2314
This commit is contained in:
Robby Findler
parent
2a9f556c8d
commit
3172ffd027
|
|
@ -647,11 +647,11 @@
|
|||
(object-interface
|
||||
val))])
|
||||
(void)
|
||||
(check-method 'method-name val-mtd-names src-info pos-blame neg-blame orig-str)
|
||||
(check-method val 'method-name val-mtd-names src-info pos-blame neg-blame orig-str)
|
||||
...)
|
||||
|
||||
(unless (field-bound? field-name val)
|
||||
(field-error 'field-name src-info pos-blame neg-blame orig-str)) ...
|
||||
(field-error val 'field-name src-info pos-blame neg-blame orig-str)) ...
|
||||
|
||||
(let ([vtable (extract-vtable val)]
|
||||
[method-ht (extract-method-ht val)])
|
||||
|
|
@ -1395,7 +1395,7 @@
|
|||
(syntax
|
||||
((x ...)
|
||||
(begin
|
||||
(check-pre-expr->pp/h pre-expr src-info pos-blame neg-blame orig-str)
|
||||
(check-pre-expr->pp/h val pre-expr src-info pos-blame neg-blame orig-str)
|
||||
(let ([dom-id ((coerce/select-contract stx-name dom) neg-blame pos-blame src-info orig-str)]
|
||||
...)
|
||||
(val (dom-id x) ...)))))]
|
||||
|
|
@ -1406,11 +1406,11 @@
|
|||
(syntax
|
||||
((x ...)
|
||||
(begin
|
||||
(check-pre-expr->pp/h pre-expr src-info pos-blame neg-blame orig-str)
|
||||
(check-pre-expr->pp/h val pre-expr src-info pos-blame neg-blame orig-str)
|
||||
(let ([dom-id ((coerce/select-contract stx-name dom) neg-blame pos-blame src-info orig-str)]
|
||||
...)
|
||||
(let-values ([(rng-ids ...) (val (dom-id x) ...)])
|
||||
(check-post-expr->pp/h post-expr src-info pos-blame neg-blame orig-str)
|
||||
(check-post-expr->pp/h val post-expr src-info pos-blame neg-blame orig-str)
|
||||
(let ([rng-ids-x ((coerce/select-contract stx-name rng-ctc)
|
||||
pos-blame neg-blame src-info orig-str)] ...)
|
||||
(values (rng-ids-x rng-ids) ...))))))))]
|
||||
|
|
@ -1429,12 +1429,12 @@
|
|||
(syntax
|
||||
((x ...)
|
||||
(begin
|
||||
(check-pre-expr->pp/h pre-expr src-info pos-blame neg-blame orig-str)
|
||||
(check-pre-expr->pp/h val pre-expr src-info pos-blame neg-blame orig-str)
|
||||
(let ([dom-id ((coerce/select-contract stx-name dom) neg-blame pos-blame src-info orig-str)]
|
||||
...
|
||||
[rng-id ((coerce/select-contract stx-name rng) pos-blame neg-blame src-info orig-str)])
|
||||
(let ([res-id (rng-id (val (dom-id x) ...))])
|
||||
(check-post-expr->pp/h post-expr src-info pos-blame neg-blame orig-str)
|
||||
(check-post-expr->pp/h val post-expr src-info pos-blame neg-blame orig-str)
|
||||
res-id)))))]
|
||||
[_
|
||||
(raise-syntax-error name "unknown result specification" stx (syntax result-stuff))]))))))]
|
||||
|
|
@ -1501,7 +1501,7 @@
|
|||
(syntax
|
||||
((x ... . rest-x)
|
||||
(begin
|
||||
(check-pre-expr->pp/h pre-expr src-info pos-blame neg-blame orig-str)
|
||||
(check-pre-expr->pp/h val pre-expr src-info pos-blame neg-blame orig-str)
|
||||
(let ([dom-id ((coerce/select-contract stx-name dom) neg-blame pos-blame src-info orig-str)]
|
||||
...
|
||||
[rest-id ((coerce/select-contract stx-name rest-dom) neg-blame pos-blame src-info orig-str)])
|
||||
|
|
@ -1515,12 +1515,12 @@
|
|||
(syntax
|
||||
((x ... . rest-x)
|
||||
(begin
|
||||
(check-pre-expr->pp/h pre-expr src-info pos-blame neg-blame orig-str)
|
||||
(check-pre-expr->pp/h val pre-expr src-info pos-blame neg-blame orig-str)
|
||||
(let ([dom-id ((coerce/select-contract stx-name dom) neg-blame pos-blame src-info orig-str)]
|
||||
...
|
||||
[rest-id ((coerce/select-contract stx-name rest-dom) neg-blame pos-blame src-info orig-str)])
|
||||
(let-values ([(rng-ids ...) (apply val (dom-id x) ... (rest-id rest-x))])
|
||||
(check-post-expr->pp/h post-expr src-info pos-blame neg-blame orig-str)
|
||||
(check-post-expr->pp/h val post-expr src-info pos-blame neg-blame orig-str)
|
||||
(let ([rng-ids-x ((coerce/select-contract stx-name rng-ctc)
|
||||
pos-blame neg-blame src-info orig-str)] ...)
|
||||
(values (rng-ids-x rng-ids) ...))))))))]
|
||||
|
|
@ -1544,13 +1544,13 @@
|
|||
(syntax
|
||||
((x ... . rest-x)
|
||||
(begin
|
||||
(check-pre-expr->pp/h pre-expr src-info pos-blame neg-blame orig-str)
|
||||
(check-pre-expr->pp/h val pre-expr src-info pos-blame neg-blame orig-str)
|
||||
(let ([dom-id ((coerce/select-contract stx-name dom) neg-blame pos-blame src-info orig-str)]
|
||||
...
|
||||
[rest-id ((coerce/select-contract stx-name rest-dom) neg-blame pos-blame src-info orig-str)]
|
||||
[rng-id ((coerce/select-contract stx-name rng) pos-blame neg-blame src-info orig-str)])
|
||||
(let ([res-id (rng-id (apply val (dom-id x) ... (rest-id rest-x)))])
|
||||
(check-post-expr->pp/h post-expr src-info pos-blame neg-blame orig-str)
|
||||
(check-post-expr->pp/h val post-expr src-info pos-blame neg-blame orig-str)
|
||||
res-id)))))]
|
||||
[(rng res-id post-expr)
|
||||
(not (identifier? (syntax res-id)))
|
||||
|
|
@ -1690,17 +1690,19 @@
|
|||
f)))
|
||||
|
||||
|
||||
(define (check-pre-expr->pp/h pre-expr src-info pos-blame neg-blame orig-str)
|
||||
(define (check-pre-expr->pp/h val pre-expr src-info pos-blame neg-blame orig-str)
|
||||
(unless pre-expr
|
||||
(raise-contract-error src-info
|
||||
(raise-contract-error val
|
||||
src-info
|
||||
neg-blame
|
||||
pos-blame
|
||||
orig-str
|
||||
"pre-condition expression failure")))
|
||||
|
||||
(define (check-post-expr->pp/h post-expr src-info pos-blame neg-blame orig-str)
|
||||
(define (check-post-expr->pp/h val post-expr src-info pos-blame neg-blame orig-str)
|
||||
(unless post-expr
|
||||
(raise-contract-error src-info
|
||||
(raise-contract-error val
|
||||
src-info
|
||||
pos-blame
|
||||
neg-blame
|
||||
orig-str
|
||||
|
|
@ -1710,6 +1712,7 @@
|
|||
(unless (and (procedure? val)
|
||||
(procedure-arity-includes? val dom-length))
|
||||
(raise-contract-error
|
||||
val
|
||||
src-info
|
||||
pos-blame
|
||||
neg-blame
|
||||
|
|
@ -1720,14 +1723,16 @@
|
|||
|
||||
(define (check-procedure/kind val arity kind-of-thing src-info pos-blame neg-blame orig-str)
|
||||
(unless (procedure? val)
|
||||
(raise-contract-error src-info
|
||||
(raise-contract-error val
|
||||
src-info
|
||||
pos-blame
|
||||
neg-blame
|
||||
orig-str
|
||||
"expected a procedure, got ~e"
|
||||
val))
|
||||
(unless (procedure-arity-includes? val arity)
|
||||
(raise-contract-error src-info
|
||||
(raise-contract-error val
|
||||
src-info
|
||||
pos-blame
|
||||
neg-blame
|
||||
orig-str
|
||||
|
|
@ -1739,14 +1744,16 @@
|
|||
|
||||
(define (check-procedure/more/kind val arity kind-of-thing src-info pos-blame neg-blame orig-str)
|
||||
(unless (procedure? val)
|
||||
(raise-contract-error src-info
|
||||
(raise-contract-error val
|
||||
src-info
|
||||
pos-blame
|
||||
neg-blame
|
||||
orig-str
|
||||
"expected a procedure, got ~e"
|
||||
val))
|
||||
(unless (procedure-accepts-and-more? val arity)
|
||||
(raise-contract-error src-info
|
||||
(raise-contract-error val
|
||||
src-info
|
||||
pos-blame
|
||||
neg-blame
|
||||
orig-str
|
||||
|
|
@ -1760,6 +1767,7 @@
|
|||
(unless (and (procedure? val)
|
||||
(procedure-accepts-and-more? val dom-length))
|
||||
(raise-contract-error
|
||||
val
|
||||
src-info
|
||||
pos-blame
|
||||
neg-blame
|
||||
|
|
@ -1792,24 +1800,27 @@
|
|||
|
||||
(define (check-object val src-info pos-blame neg-blame orig-str)
|
||||
(unless (object? val)
|
||||
(raise-contract-error src-info
|
||||
(raise-contract-error val
|
||||
src-info
|
||||
pos-blame
|
||||
neg-blame
|
||||
orig-str
|
||||
"expected an object, got ~e"
|
||||
val)))
|
||||
|
||||
(define (check-method method-name val-mtd-names src-info pos-blame neg-blame orig-str)
|
||||
(define (check-method val method-name val-mtd-names src-info pos-blame neg-blame orig-str)
|
||||
(unless (memq method-name val-mtd-names)
|
||||
(raise-contract-error src-info
|
||||
(raise-contract-error val
|
||||
src-info
|
||||
pos-blame
|
||||
neg-blame
|
||||
orig-str
|
||||
"expected an object with method ~s"
|
||||
method-name)))
|
||||
|
||||
(define (field-error field-name src-info pos-blame neg-blame orig-str)
|
||||
(raise-contract-error src-info
|
||||
(define (field-error val field-name src-info pos-blame neg-blame orig-str)
|
||||
(raise-contract-error val
|
||||
src-info
|
||||
pos-blame
|
||||
neg-blame
|
||||
orig-str
|
||||
|
|
|
|||
|
|
@ -4,6 +4,7 @@
|
|||
(lib "list.ss"))
|
||||
|
||||
(provide raise-contract-error
|
||||
contract-violation->string
|
||||
coerce-contract
|
||||
coerce/select-contract
|
||||
contract?
|
||||
|
|
@ -85,7 +86,7 @@
|
|||
exn:fail:contract2?
|
||||
(lambda (x) (get x 0)))))
|
||||
|
||||
(define (raise-contract-error src-info to-blame other-party contract-sexp fmt . args)
|
||||
(define (default-contract-violation->string val src-info to-blame other-party contract-sexp msg)
|
||||
(let ([blame-src (src-info-as-string src-info)]
|
||||
[formatted-contract-sexp
|
||||
(let ([one-line (format "~s" contract-sexp)])
|
||||
|
|
@ -102,26 +103,35 @@
|
|||
(if (symbol? datum)
|
||||
(format " on ~a" datum)
|
||||
""))])
|
||||
(raise
|
||||
(make-exn:fail:contract2
|
||||
(string->immutable-string
|
||||
(string-append (format "~a~a broke the contract ~ait had with ~a~a; "
|
||||
blame-src
|
||||
to-blame
|
||||
formatted-contract-sexp
|
||||
other-party
|
||||
specific-blame)
|
||||
(apply format fmt args)))
|
||||
(current-continuation-marks)
|
||||
(if src-info
|
||||
(list (make-srcloc
|
||||
(syntax-source src-info)
|
||||
(syntax-line src-info)
|
||||
(syntax-column src-info)
|
||||
(syntax-position src-info)
|
||||
(syntax-span src-info)))
|
||||
'())))))
|
||||
(string-append (format "~a~a broke the contract ~ait had with ~a~a; "
|
||||
blame-src
|
||||
to-blame
|
||||
formatted-contract-sexp
|
||||
other-party
|
||||
specific-blame)
|
||||
msg)))
|
||||
|
||||
(define contract-violation->string (make-parameter default-contract-violation->string))
|
||||
|
||||
(define (raise-contract-error val src-info to-blame other-party contract-sexp fmt . args)
|
||||
(raise
|
||||
(make-exn:fail:contract2
|
||||
(string->immutable-string
|
||||
((contract-violation->string) val
|
||||
src-info
|
||||
to-blame
|
||||
other-party
|
||||
contract-sexp
|
||||
(apply format fmt args)))
|
||||
(current-continuation-marks)
|
||||
(if src-info
|
||||
(list (make-srcloc
|
||||
(syntax-source src-info)
|
||||
(syntax-line src-info)
|
||||
(syntax-column src-info)
|
||||
(syntax-position src-info)
|
||||
(syntax-span src-info)))
|
||||
'()))))
|
||||
|
||||
(define print-contract-liner
|
||||
(let ([default (pretty-print-print-line)])
|
||||
|
|
@ -226,6 +236,7 @@
|
|||
(if (predicate val)
|
||||
val
|
||||
(raise-contract-error
|
||||
val
|
||||
src-info
|
||||
pos
|
||||
neg
|
||||
|
|
|
|||
|
|
@ -976,6 +976,7 @@ add struct contracts for immutable structs?
|
|||
(lambda (val)
|
||||
(unless (predicate?-name val)
|
||||
(raise-contract-error
|
||||
val
|
||||
src-info
|
||||
pos
|
||||
neg
|
||||
|
|
@ -1083,6 +1084,7 @@ add struct contracts for immutable structs?
|
|||
(predicate?-name v))
|
||||
(constructor-name (p-apps (selector-names v)) ...)
|
||||
(raise-contract-error
|
||||
v
|
||||
src-info
|
||||
pos
|
||||
neg
|
||||
|
|
@ -1116,6 +1118,7 @@ add struct contracts for immutable structs?
|
|||
(cons (p-app (selector-name v i))
|
||||
(loop (cdr p-apps) (+ i 1))))])))
|
||||
(raise-contract-error
|
||||
v
|
||||
src-info
|
||||
pos
|
||||
neg
|
||||
|
|
@ -1186,6 +1189,7 @@ add struct contracts for immutable structs?
|
|||
(lambda (val)
|
||||
(unless (promise? val)
|
||||
(raise-contract-error
|
||||
val
|
||||
src-info
|
||||
pos
|
||||
neg
|
||||
|
|
@ -1239,6 +1243,7 @@ add struct contracts for immutable structs?
|
|||
(lambda (val)
|
||||
(unless (predicate-id val)
|
||||
(raise-contract-error
|
||||
val
|
||||
src-info
|
||||
pos
|
||||
neg
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user