From bf308563d2aee6524013f837ccf27f94d3c1a35c Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Sun, 31 Jan 2010 01:47:48 +0000 Subject: [PATCH] Hide make-blame; remove blame-positive and blame-negative; make blame objects transparent (but allow equal?). svn: r17907 --- collects/scheme/contract/private/blame.ss | 21 ++++++++++++++++++--- 1 file changed, 18 insertions(+), 3 deletions(-) diff --git a/collects/scheme/contract/private/blame.ss b/collects/scheme/contract/private/blame.ss index 22f63a0de1..3a3dd187fd 100644 --- a/collects/scheme/contract/private/blame.ss +++ b/collects/scheme/contract/private/blame.ss @@ -9,8 +9,6 @@ blame-innocent blame-contract blame-value - blame-positive - blame-negative blame-swapped? blame-swap @@ -18,9 +16,26 @@ current-blame-format (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)) + (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)))) + +(define (blame-hash b hash/recur) + (bitwise-xor (hash/recur (blame-guilty b)) + (hash/recur (blame-innocent b)) + (hash/recur (blame-contract b)) + (hash/recur (blame-value b)) + (hash/recur (blame-source b)) + (hash/recur (blame-swapped? b)))) + (define-struct blame [source value contract positive negative swapped?] - #:transparent) + #:property prop:equal+hash + (list blame=? blame-hash blame-hash)) (define (blame-guilty b) (if (blame-swapped? b)