diff --git a/collects/drscheme/private/debug.ss b/collects/drscheme/private/debug.ss index 18a44362d0..9bc312d2cf 100644 --- a/collects/drscheme/private/debug.ss +++ b/collects/drscheme/private/debug.ss @@ -337,7 +337,7 @@ profile todo: (define (print-planet-icon-to-stderr exn) (when (exn:fail:contract:blame? exn) (let ([table (parse-gp exn - (blame-guilty + (blame-positive (exn:fail:contract:blame-object exn)))]) (when table (let ([gp-url (bug-info->ticket-url table)]) diff --git a/collects/mzlib/private/unit-contract.ss b/collects/mzlib/private/unit-contract.ss index 966e059a18..d21c0c2e79 100644 --- a/collects/mzlib/private/unit-contract.ss +++ b/collects/mzlib/private/unit-contract.ss @@ -39,9 +39,9 @@ var)]) #`(let ([old-v/c (#,vref)]) (contract sig-ctc-stx (car old-v/c) - (cdr old-v/c) (blame-guilty #,blame-id) + (cdr old-v/c) (blame-positive #,blame-id) (quote #,var) (quote-syntax #,var))))) - (blame-innocent #,blame-id)) + (blame-negative #,blame-id)) (wrap-with-proj ctc #`(#,vref)))) vref))) (for ([tagged-info (in-list import-tagged-infos)] @@ -53,7 +53,7 @@ #`(vector-ref #,v #,index))))) (with-syntax ((((eloc ...) ...) (for/list ([target-sig import-sigs]) - (let ([rename-bindings (get-member-bindings def-table target-sig #`(blame-guilty #,blame-id))]) + (let ([rename-bindings (get-member-bindings def-table target-sig #`(blame-positive #,blame-id))]) (for/list ([target-int/ext-name (in-list (car target-sig))] [sig-ctc (in-list (cadddr target-sig))]) (let* ([var (car target-int/ext-name)] diff --git a/collects/scheme/contract/private/base.ss b/collects/scheme/contract/private/base.ss index c29f3192b1..570b20b421 100644 --- a/collects/scheme/contract/private/base.ss +++ b/collects/scheme/contract/private/base.ss @@ -55,7 +55,7 @@ improve method arity mismatch contract violation error messages? (let* ([c (coerce-contract 'contract c)]) (check-source-location! 'contract loc) (((contract-projection c) - (make-blame loc name (contract-name c) pos neg #f)) + (make-blame loc name (contract-name c) pos neg #t)) v))) (define-syntax (recursive-contract stx) diff --git a/collects/scheme/contract/private/blame.ss b/collects/scheme/contract/private/blame.ss index 3a3dd187fd..9c917adb34 100644 --- a/collects/scheme/contract/private/blame.ss +++ b/collects/scheme/contract/private/blame.ss @@ -5,10 +5,11 @@ (provide blame? make-blame blame-source - blame-guilty - blame-innocent + blame-positive + blame-negative blame-contract blame-value + blame-original? blame-swapped? blame-swap @@ -17,38 +18,35 @@ (struct-out exn:fail:contract:blame)) (define (blame=? a b equal?/recur) - (and (equal?/recur (blame-guilty a) (blame-guilty b)) - (equal?/recur (blame-innocent a) (blame-innocent b)) + (and (equal?/recur (blame-positive a) (blame-positive b)) + (equal?/recur (blame-negative a) (blame-negative b)) (equal?/recur (blame-contract a) (blame-contract b)) (equal?/recur (blame-value a) (blame-value b)) (equal?/recur (blame-source a) (blame-source b)) - (equal?/recur (blame-swapped? a) (blame-swapped? b)))) + (equal?/recur (blame-original? a) (blame-original? b)))) (define (blame-hash b hash/recur) - (bitwise-xor (hash/recur (blame-guilty b)) - (hash/recur (blame-innocent b)) + (bitwise-xor (hash/recur (blame-positive b)) + (hash/recur (blame-negative b)) (hash/recur (blame-contract b)) (hash/recur (blame-value b)) (hash/recur (blame-source b)) - (hash/recur (blame-swapped? b)))) + (hash/recur (blame-original? b)))) (define-struct blame - [source value contract positive negative swapped?] + [source value contract positive negative original?] #:property prop:equal+hash (list blame=? blame-hash blame-hash)) -(define (blame-guilty b) - (if (blame-swapped? b) - (blame-negative b) - (blame-positive b))) - -(define (blame-innocent b) - (if (blame-swapped? b) - (blame-positive b) - (blame-negative b))) - (define (blame-swap b) - (struct-copy blame b [swapped? (not (blame-swapped? b))])) + (struct-copy + blame b + [original? (not (blame-original? b))] + [positive (blame-negative b)] + [negative (blame-positive b)])) + +(define (blame-swapped? b) + (not (blame-original? b))) (define-struct (exn:fail:contract:blame exn:fail:contract) [object] #:transparent) @@ -62,14 +60,14 @@ (define (default-blame-format b x custom-message) (let* ([source-message (source-location->prefix (blame-source b))] - [guilty-message (show/display (blame-guilty b))] + [positive-message (show/display (blame-positive b))] [contract-message (show/write (blame-contract b))] [value-message (if (blame-value b) (format " on ~a" (show/display (blame-value b))) "")]) (format "~a~a broke the contract ~a~a; ~a" source-message - guilty-message + positive-message contract-message value-message custom-message))) diff --git a/collects/scheme/contract/private/legacy.ss b/collects/scheme/contract/private/legacy.ss index bf873d5b1e..3dcc229283 100644 --- a/collects/scheme/contract/private/legacy.ss +++ b/collects/scheme/contract/private/legacy.ss @@ -23,7 +23,7 @@ name (unpack-blame pos) "<>" - #f) + #t) x fmt args)) @@ -36,15 +36,15 @@ (cond [(procedure-arity-includes? proj 5) (lambda (blame) - (proj (blame-guilty blame) - (blame-innocent blame) + (proj (blame-positive blame) + (blame-negative blame) (list (blame-source blame) (blame-value blame)) (blame-contract blame) (not (blame-swapped? blame))))] [(procedure-arity-includes? proj 4) (lambda (blame) - (proj (blame-guilty blame) - (blame-innocent blame) + (proj (blame-positive blame) + (blame-negative blame) (list (blame-source blame) (blame-value blame)) (blame-contract blame)))] [else @@ -60,7 +60,7 @@ name (unpack-blame (if original? pos neg)) (unpack-blame (if original? neg pos)) - (not original?)))))) + original?))))) (define (legacy-property name) (define-values [ prop pred get ] diff --git a/collects/scheme/contract/private/object.ss b/collects/scheme/contract/private/object.ss index 5bf3e0b149..005a726288 100644 --- a/collects/scheme/contract/private/object.ss +++ b/collects/scheme/contract/private/object.ss @@ -18,9 +18,9 @@ (let* ([cm (syntax-parameterize ((making-a-method #t)) (-> any/c integer? integer?))] [cf (-> integer? integer?)] [m-proj ((contract-projection cm) - (make-blame #'here #f "whatever" 'pos 'neg #f))] + (make-blame #'here #f "whatever" 'pos 'neg #t))] [f-proj ((contract-projection cf) - (make-blame #'here #f "whatever" 'pos 'neg #f))] + (make-blame #'here #f "whatever" 'pos 'neg #t))] [cls (make-wrapper-class 'wrapper-class '(m) (list diff --git a/collects/tests/mzscheme/contract-mzlib-test.ss b/collects/tests/mzscheme/contract-mzlib-test.ss index fa7a9139af..f42cfe3396 100644 --- a/collects/tests/mzscheme/contract-mzlib-test.ss +++ b/collects/tests/mzscheme/contract-mzlib-test.ss @@ -5126,7 +5126,7 @@ so that propagation occurs. (contract-eval `(,test 'pos - (compose blame-guilty exn:fail:contract:blame-object) + (compose blame-positive exn:fail:contract:blame-object) (with-handlers ((void values)) (contract not #t 'pos 'neg)))) (report-errs) diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss index ed53e149bd..485b377237 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/collects/tests/mzscheme/contract-test.ss @@ -7158,7 +7158,7 @@ so that propagation occurs. (contract-eval `(,test 'pos - (compose blame-guilty exn:fail:contract:blame-object) + (compose blame-positive exn:fail:contract:blame-object) (with-handlers ((void values)) (contract not #t 'pos 'neg)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;