From 44b62899fa81e3daec0c9fa4a077f02c214a7f64 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Tue, 2 Sep 2008 16:12:13 +0000
Subject: [PATCH] improved blame error message when there is no source location

svn: r11526
---
 collects/redex/private/matcher-test.ss         | 6 ++++++
 collects/scheme/private/contract-guts.ss       | 3 ++-
 collects/scheme/private/contract.ss            | 6 +++---
 collects/scribblings/reference/contracts.scrbl | 4 ++--
 collects/tests/mzscheme/contract-mzlib-test.ss | 4 ++--
 5 files changed, 15 insertions(+), 8 deletions(-)

diff --git a/collects/redex/private/matcher-test.ss b/collects/redex/private/matcher-test.ss
index 42313f6ee6..a2a559e448 100644
--- a/collects/redex/private/matcher-test.ss
+++ b/collects/redex/private/matcher-test.ss
@@ -290,11 +290,17 @@
                                       '((1 1) (1 1)) 
                                       none)))
     
+    (test-empty '((variable_1 variable_1) ...)
+                '((x y))
+                #f)
+    
+    
     (test-empty '(number ...) '()
                 (list (make-test-mtch (make-bindings (list (make-bind 'number '()))) '() none)))
     (test-ab '(aa ...) '()
              (list (make-test-mtch (make-bindings (list (make-bind 'aa '()))) '() none)))
     
+    
     ;; testing block-in-hole
     (test-empty '(hide-hole a) 'b #f)
     (test-empty '(hide-hole a) 'a (list (make-test-mtch (make-bindings '()) 'a none)))
diff --git a/collects/scheme/private/contract-guts.ss b/collects/scheme/private/contract-guts.ss
index a4239fd4c7..522a87e254 100644
--- a/collects/scheme/private/contract-guts.ss
+++ b/collects/scheme/private/contract-guts.ss
@@ -199,6 +199,7 @@
     (string-append (format "~a~a broke the contract ~a~a; "
                            blame-src
                            (cond
+                             [(not to-blame) "<<unknown>>"]
                              [(and (pair? to-blame)
                                    (pair? (cdr to-blame))
                                    (null? (cddr to-blame))
@@ -251,7 +252,7 @@
             (string-append src-loc-str  ": ")
             ""))
       ""))
-
+       
 ;                                                      
 ;                                                      
 ;                                                      
diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss
index d9ad79b93d..c786c45f9e 100644
--- a/collects/scheme/private/contract.ss
+++ b/collects/scheme/private/contract.ss
@@ -62,7 +62,7 @@ improve method arity mismatch contract violation error messages?
 (define-for-syntax (make-define/contract-transformer contract-id id)
   (make-set!-transformer
    (λ (stx)
-     (with-syntax ([neg-blame-str (or (a:build-src-loc-string stx) "")]
+     (with-syntax ([neg-blame-str (a:build-src-loc-string stx)]
                    [contract-id contract-id]
                    [id id])
        (syntax-case stx (set!)
@@ -76,7 +76,7 @@ improve method arity mismatch contract violation error messages?
             ((-contract contract-id
                         id
                         (syntax->datum (quote-syntax f))
-                        (string->symbol neg-blame-str)
+                        neg-blame-str
                         (quote-syntax f))
              arg
              ...))]
@@ -86,7 +86,7 @@ improve method arity mismatch contract violation error messages?
             (-contract contract-id
                        id
                        (syntax->datum (quote-syntax ident)) 
-                       (string->symbol neg-blame-str)
+                       neg-blame-str
                        (quote-syntax ident)))])))))
 
 ;; id->contract-src-info : identifier -> syntax
diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl
index 494112a36f..347acf7549 100644
--- a/collects/scribblings/reference/contracts.scrbl
+++ b/collects/scribblings/reference/contracts.scrbl
@@ -987,7 +987,7 @@ name @scheme[sexp-name] when signaling a contract violation.}
 
 @defparam[contract-violation->string 
           proc 
-          (-> any/c any/c any/c any/c string? string?)]{
+          (-> any/c any/c (or/c false/c any/c) any/c string? string?)]{
 
 This is a parameter that is used when constructing a
 contract violation error. Its value is procedure that
@@ -996,7 +996,7 @@ accepts five arguments:
 @item{the value that the contract applies to,}
 @item{a syntax object representing the source location where
 the contract was established, }
-@item{the name of the party that violated the contract, }
+@item{the name of the party that violated the contract (@scheme[#f] indicates that the party is not known, not that the party's name is @scheme[#f]), }
 @item{an sexpression representing the contract, and }
 @item{a message indicating the kind of violation.
 }}
diff --git a/collects/tests/mzscheme/contract-mzlib-test.ss b/collects/tests/mzscheme/contract-mzlib-test.ss
index e55bfbd7c2..c32dc4c0af 100644
--- a/collects/tests/mzscheme/contract-mzlib-test.ss
+++ b/collects/tests/mzscheme/contract-mzlib-test.ss
@@ -1591,14 +1591,14 @@ of the contract library does not change over time.
    '(let ()
       (define/contract i (-> integer? integer?) (lambda (x) 1))
       (i #f))
-   "")
+   "<<unknown>>")
   
   (test/spec-failed
    'define/contract5
    '(let ()
       (define/contract i (-> integer? integer?) (lambda (x) (i #t)))
       (i 1))
-   "")
+   "<<unknown>>")
   
   (test/spec-passed
    'define/contract6