From bad9c0f731fea3531f4df6cabac0dcc9e94dd21f Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Wed, 17 Jul 2002 05:53:01 +0000
Subject: [PATCH] ..

original commit: c47c873c27f031a2f5ee2677271dcd5d21814279
---
 collects/mzlib/contracts.ss           |  45 +--
 collects/tests/framework/spec-test.ss | 429 --------------------------
 2 files changed, 27 insertions(+), 447 deletions(-)
 delete mode 100644 collects/tests/framework/spec-test.ss

diff --git a/collects/mzlib/contracts.ss b/collects/mzlib/contracts.ss
index 7686c0d..8fa0ab6 100644
--- a/collects/mzlib/contracts.ss
+++ b/collects/mzlib/contracts.ss
@@ -192,7 +192,7 @@
                          pos-blame
                          a-contract 
                          name))
-                (check-contract a-contract name pos-blame neg-blame src-info)))))])))
+                (check-contract a-contract name pos-blame neg-blame src-info #f)))))])))
   
   (define-syntaxes (-> ->* ->d ->d* case->)
     (let ()
@@ -245,7 +245,7 @@
 			      (syntax
 			       ((arg-x ...)
 				(val
-				 (check-contract dom-x arg-x neg-blame pos-blame src-info)
+				 (check-contract dom-x arg-x neg-blame pos-blame src-info #f)
 				 ...)))))
 			  (lambda (stx)
 			    (->*make-body stx)))))))))]))
@@ -288,14 +288,15 @@
                    ((arg-x ...)
                     (let-values ([(res-x ...)
                                   (val
-                                   (check-contract dom-x arg-x neg-blame pos-blame src-info)
+                                   (check-contract dom-x arg-x neg-blame pos-blame src-info #f)
                                    ...)])
                       (values (check-contract
                                rng-x 
                                res-x
                                pos-blame
                                neg-blame
-                               src-info)
+                               src-info
+                               #f)
                               ...))))))))]
           [(_ (dom ...) rest (rng ...))
            (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))]
@@ -335,15 +336,16 @@
                     (let-values ([(res-x ...)
                                   (apply
                                    val
-                                   (check-contract dom-x arg-x neg-blame pos-blame src-info)
+                                   (check-contract dom-x arg-x neg-blame pos-blame src-info #f)
                                    ...
-                                   (check-contract dom-rest-x rest-arg-x neg-blame pos-blame src-info))])
+                                   (check-contract dom-rest-x rest-arg-x neg-blame pos-blame src-info #f))])
                       (values (check-contract
                                rng-x 
                                res-x
                                pos-blame
                                neg-blame
-                               src-info)
+                               src-info
+                               #f)
                               ...))))))))]))
       
       ;; ->d/h : stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
@@ -392,10 +394,11 @@
                                  rng-contract))
                         (check-contract 
                          rng-contract
-                         (val (check-contract dom-x arg-x neg-blame pos-blame src-info) ...)
+                         (val (check-contract dom-x arg-x neg-blame pos-blame src-info #f) ...)
                          pos-blame
                          neg-blame
-                         src-info)))))))))]))
+                         src-info
+                         #f)))))))))]))
       
       ;; ->d*/h : stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
       (define (->d*/h stx)
@@ -440,7 +443,7 @@
                        (call-with-values
                         (lambda ()
                           (val
-                           (check-contract dom-x arg-x neg-blame pos-blame src-info)
+                           (check-contract dom-x arg-x neg-blame pos-blame src-info #f)
                            ...))
                         (lambda results
                           (unless (= (length results) (length rng-contracts))
@@ -455,7 +458,8 @@
                                    result
                                    pos-blame
                                    neg-blame
-                                   src-info))
+                                   src-info
+                                   #f))
                                 rng-contracts
                                 results))))))))))))]
           [(_ (dom ...) rest rng-mk)
@@ -500,9 +504,9 @@
                         (lambda ()
                           (apply 
                            val
-                           (check-contract dom-x arg-x neg-blame pos-blame src-info)
+                           (check-contract dom-x arg-x neg-blame pos-blame src-info #f)
                            ...
-                           (check-contract dom-rest-x rest-arg-x neg-blame pos-blame src-info)))
+                           (check-contract dom-rest-x rest-arg-x neg-blame pos-blame src-info #f)))
                         (lambda results
                           (unless (= (length results) (length rng-contracts))
                             (error '->d* 
@@ -516,7 +520,8 @@
                                    result
                                    pos-blame
                                    neg-blame
-                                   src-info))
+                                   src-info 
+                                   #f))
                                 rng-contracts
                                 results))))))))))))]))
 
@@ -658,8 +663,9 @@
                  (and (procedure? val)
                       (procedure-arity-includes? val 1))))])
       contract?))
-  
-  (define (check-contract contract val pos neg src-info)
+
+  ;; check-contract : contract any symbol symbol syntax (union false? string?)
+  (define (check-contract contract val pos neg src-info extra-message)
     (cond
       [(contract? contract)
        ((contract-f contract) val pos neg src-info)]
@@ -680,9 +686,12 @@
             src-info
             pos
 	    neg
-            "~agiven: ~e"
+            "~agiven: ~e~a"
 	    (predicate->type-name contract)
-	    val))]))
+	    val
+            (if extra-message
+                extra-message
+                "")))]))
 
   ;; predicate->type-name : function -> string
   ;; if the function has a name and the name ends
diff --git a/collects/tests/framework/spec-test.ss b/collects/tests/framework/spec-test.ss
deleted file mode 100644
index 9faa862..0000000
--- a/collects/tests/framework/spec-test.ss
+++ /dev/null
@@ -1,429 +0,0 @@
-(module spec-test mzscheme
-  (require "test-suite-utils.ss")
-  
-  (load-framework-automatically #f)
-  (send-sexp-to-mred '(require (lib "specs.ss" "framework")))
-  (send-sexp-to-mred '(require (lib "pretty.ss")))
-  
-  ;; test/spec-passed : symbol sexp -> void
-  ;; tests a passing specification
-  (define (test/spec-passed name expression)
-    (test name
-          (lambda (x) (eq? x 'passed))
-          (lambda ()
-            (send-sexp-to-mred `(begin ,expression 'passed)))))
-  
-  ;; test/spec-failed : symbol sexp string -> void
-  ;; tests a failing specification with blame assigned to `blame'
-  (define (test/spec-failed name expression blame)
-    (test name
-          (lambda (x) 
-            (and (string? x)
-                 (let ([m (regexp-match ": (.*) failed contract:" x)])
-                   (equal? (cadr m) blame))))
-          (lambda ()
-            (send-sexp-to-mred `(with-handlers ([(lambda (x) (and (not-break-exn? x) (exn? x)))
-                                                 exn-message])
-                                  ,expression
-                                  'failed/expected-exn-got-normal-termination)))))
-
-  (test/spec-passed
-   'contract-flat1 
-   '(contract not #f 'pos 'neg))
-  
-  (test/spec-failed
-   'contract-flat2 
-   '(contract not #t 'pos 'neg)
-   "pos")
-  
-  (test/spec-passed
-   'contract-arrow-star0a
-   '(contract (->* (integer?) (integer?))
-              (lambda (x) x)
-              'pos
-              'neg))
-  
-  (test/spec-failed
-   'contract-arrow-star0b
-   '((contract (->* (integer?) (integer?))
-               (lambda (x) x)
-               'pos
-               'neg)
-     #f)
-   "neg")
-  
-  (test/spec-failed
-   'contract-arrow-star0c
-   '((contract (->* (integer?) (integer?))
-               (lambda (x) #f)
-               'pos
-               'neg)
-     1)
-   "pos")
-  
-  (test/spec-passed
-   'contract-arrow-star1
-   '(let-values ([(a b) ((contract (->* (integer?) (integer? integer?))
-                                   (lambda (x) (values x x))
-                                   'pos
-                                   'neg)
-                         2)])
-      1))
-  
-  (test/spec-failed
-   'contract-arrow-star2
-   '((contract (->* (integer?) (integer? integer?))
-               (lambda (x) (values x x))
-               'pos
-               'neg)
-     #f)
-   "neg")
-  
-  (test/spec-failed
-   'contract-arrow-star3
-   '((contract (->* (integer?) (integer? integer?))
-               (lambda (x) (values 1 #t))
-               'pos
-               'neg)
-     1)
-   "pos")
-  
-  (test/spec-failed
-   'contract-arrow-star4
-   '((contract (->* (integer?) (integer? integer?))
-               (lambda (x) (values #t 1))
-               'pos
-               'neg)
-     1)
-   "pos")
-  
-  
-  (test/spec-passed
-   'contract-arrow-star5
-   '(let-values ([(a b) ((contract (->* (integer?) 
-                                        (listof integer?)
-                                        (integer? integer?))
-                                   (lambda (x) (values x x))
-                                   'pos
-                                   'neg)
-                         2)])
-      1))
-  
-  (test/spec-failed
-   'contract-arrow-star6
-   '((contract (->* (integer?) (listof integer?) (integer? integer?))
-               (lambda (x) (values x x))
-               'pos
-               'neg)
-     #f)
-   "neg")
-  
-  (test/spec-failed
-   'contract-arrow-star7
-   '((contract (->* (integer?) (listof integer?) (integer? integer?))
-               (lambda (x) (values 1 #t))
-               'pos
-               'neg)
-     1)
-   "pos")
-  
-  (test/spec-failed
-   'contract-arrow-star8
-   '((contract (->* (integer?) (listof integer?) (integer? integer?))
-               (lambda (x) (values #t 1))
-               'pos
-               'neg)
-     1)
-   "pos")
-  
-  (test/spec-passed
-   'contract-arrow-star9
-   '((contract (->* (integer?) (listof integer?) (integer?))
-               (lambda (x . y) 1)
-               'pos
-               'neg)
-     1 2))
-  
-  (test/spec-failed
-   'contract-arrow-star10
-   '((contract (->* (integer?) (listof integer?) (integer?))
-               (lambda (x . y) 1)
-               'pos
-               'neg)
-     1 2 'bad)
-   "neg")
-
-  (test/spec-failed
-   'contract-d1
-   '(contract (integer? . ->d . (lambda (x) (lambda (y) (= x y))))
-              1
-              'pos
-              'neg)
-   "pos")
-  
-  (test/spec-passed
-   'contract-d2
-   '(contract (integer? . ->d . (lambda (x) (lambda (y) (= x y))))
-              (lambda (x) x)
-              'pos
-              'neg))
-  
-  (test/spec-failed
-   'contract-d2
-   '((contract (integer? . ->d . (lambda (x) (lambda (y) (= x y))))
-               (lambda (x) (+ x 1))
-               'pos
-               'neg)
-     2)
-   "pos")
-
-  (test/spec-passed
-   'contract-arrow1
-   '(contract (integer? . -> . integer?) (lambda (x) x) 'pos 'neg))
-  
-  (test/spec-failed
-   'contract-arrow2
-   '(contract (integer? . -> . integer?) (lambda (x y) x) 'pos 'neg)
-   "pos")
-  
-  (test/spec-failed
-   'contract-arrow3
-   '((contract (integer? . -> . integer?) (lambda (x) #f) 'pos 'neg) #t)
-   "neg")
-  
-  (test/spec-failed
-   'contract-arrow4
-   '((contract (integer? . -> . integer?) (lambda (x) #f) 'pos 'neg) 1)
-   "pos")
-
-
-  (test/spec-passed
-   'contract-arrow-any1
-   '(contract (integer? . -> . any) (lambda (x) x) 'pos 'neg))
-  
-  (test/spec-failed
-   'contract-arrow-any2
-   '(contract (integer? . -> . any) (lambda (x y) x) 'pos 'neg)
-   "pos")
-  
-  (test/spec-failed
-   'contract-arrow-any3
-   '((contract (integer? . -> . any) (lambda (x) #f) 'pos 'neg) #t)
-   "neg")
-
-  (test/spec-passed
-   'contract-arrow-star-d1
-   '((contract (->d* (integer?) (lambda (arg) (lambda (res) (= arg res))))
-               (lambda (x) x)
-               'pos
-               'neg)
-     1))
-  
-  (test/spec-passed
-   'contract-arrow-star-d2
-   '((contract (->d* (integer?) (lambda (arg) 
-                                  (values (lambda (res) (= arg res)) 
-                                          (lambda (res) (= arg res)))))
-               (lambda (x) (values x x))
-               'pos
-               'neg)
-     1))
-  
-  (test/spec-failed
-   'contract-arrow-star-d3
-   '((contract (->d* (integer?) (lambda (arg) 
-                                  (values (lambda (res) (= arg res)) 
-                                          (lambda (res) (= arg res)))))
-               (lambda (x) (values 1 2))
-               'pos
-               'neg)
-     2)
-   "pos")
-  
-  (test/spec-failed
-   'contract-arrow-star-d4
-   '((contract (->d* (integer?) (lambda (arg) 
-                                  (values (lambda (res) (= arg res)) 
-                                          (lambda (res) (= arg res)))))
-               (lambda (x) (values 2 1))
-               'pos
-               'neg)
-     2)
-   "pos")
-  
-  (test/spec-passed
-   'contract-arrow-star-d5
-   '((contract (->d* ()
-                     (listof integer?)
-                     (lambda (arg) (lambda (res) (= arg res))))
-               (lambda (x) x)
-               'pos
-               'neg)
-     1))
-  
-  (test/spec-passed
-   'contract-arrow-star-d6
-   '((contract (->d* () 
-                     (listof integer?)
-                     (lambda (arg) 
-                       (values (lambda (res) (= arg res)) 
-                               (lambda (res) (= arg res)))))
-               (lambda (x) (values x x))
-               'pos
-               'neg)
-     1))
-  
-  (test/spec-failed
-   'contract-arrow-star-d7
-   '((contract (->d* () 
-                     (listof integer?)
-                     (lambda (arg) 
-                       (values (lambda (res) (= arg res)) 
-                               (lambda (res) (= arg res)))))
-               (lambda (x) (values 1 2))
-               'pos
-               'neg)
-     2)
-   "pos")
-  
-  (test/spec-failed
-   'contract-arrow-star-d8
-   '((contract (->d* ()
-                     (listof integer?)
-                     (lambda (arg) 
-                       (values (lambda (res) (= arg res)) 
-                               (lambda (res) (= arg res)))))
-               (lambda (x) (values 2 1))
-               'pos
-               'neg)
-     2)
-   "pos")
-  
-  (test/spec-failed
-   'contract-case->1
-   '(contract (case-> (integer? integer? . -> . integer?) (integer? . -> . integer?))
-              (lambda (x) x)
-              'pos
-              'neg)
-   "pos")
-  
-  (test/spec-failed
-   'contract-case->2
-   '((contract (case-> (integer? integer? . -> . integer?) (integer? . -> . integer?))
-               (case-lambda 
-                 [(x y) 'case1]
-                 [(x) 'case2])
-               'pos
-               'neg)
-     1 2)
-   "pos")
-  
-  (test/spec-failed
-   'contract-case->3
-   '((contract (case-> (integer? integer? . -> . integer?) (integer? . -> . integer?))
-               (case-lambda 
-                 [(x y) 'case1]
-                 [(x) 'case2])
-               'pos
-               'neg)
-     1)
-   "pos")
-  
-  (test/spec-failed
-   'contract-case->4
-   '((contract (case-> (integer? integer? . -> . integer?) (integer? . -> . integer?))
-               (case-lambda 
-                 [(x y) 'case1]
-                 [(x) 'case2])
-               'pos
-               'neg)
-     'a 2)
-   "neg")
-  
-  (test/spec-failed
-   'contract-case->5
-   '((contract (case-> (integer? integer? . -> . integer?) (integer? . -> . integer?))
-               (case-lambda 
-                 [(x y) 'case1]
-                 [(x) 'case2])
-               'pos
-               'neg)
-     2 'a)
-   "neg")
-  
-  (test/spec-failed
-   'contract-case->6
-   '((contract (case-> (integer? integer? . -> . integer?) (integer? . -> . integer?))
-               (case-lambda 
-                 [(x y) 'case1]
-                 [(x) 'case2])
-               'pos
-               'neg)
-     #t)
-   "neg")
-  
-  (test/spec-failed
-   'contract-d-protect-shared-state
-   '(let ([x 1])
-      ((contract ((->d (lambda () (let ([pre-x x]) (lambda (res) (= x pre-x)))))
-                  . -> .
-                  (lambda (x) #t))
-                 (lambda (thnk) (thnk))
-                 'pos
-                 'neg)
-       (lambda () (set! x 2))))
-   "neg")
- 
-  (test/spec-failed
-   'combo1
-   '(let ([cf (contract (case->
-                         ((class? . ->d . (lambda (%) (lambda (x) #f))) . -> . void?)
-                         ((class? . ->d . (lambda (%) (lambda (x) #f))) boolean? . -> . void?))
-                        (letrec ([c% (class object% (super-instantiate ()))]
-                                 [f
-                                  (case-lambda
-                                    [(class-maker) (f class-maker #t)]
-                                    [(class-maker b) 
-                                     (class-maker c%)
-                                     (void)])])
-                          f)
-                        'pos
-                        'neg)])
-      (cf (lambda (x%) 'going-to-be-bad)))
-   "neg")   
-
-  (test/spec-failed
-   'union1
-   '(contract (union false?) #t 'pos 'neg)
-   "pos")
-
-  (test/spec-passed
-   'union2
-   '(contract (union false?) #f 'pos 'neg))
-
-  (test/spec-passed
-   'union3
-   '((contract (union (-> integer? integer?)) (lambda (x) x) 'pos 'neg) 1))
-  
-  (test/spec-failed
-   'union4
-   '((contract (union (-> integer? integer?)) (lambda (x) x) 'pos 'neg) #f)
-   "neg")
-  
-  (test/spec-failed
-   'union5
-   '((contract (union (-> integer? integer?)) (lambda (x) #f) 'pos 'neg) 1)
-   "pos")
-  
-  (test/spec-passed
-   'union6
-   '(contract (union false? (-> integer? integer?)) #f 'pos 'neg))
-  
-  (test/spec-passed
-   'union7
-   '((contract (union false? (-> integer? integer?)) (lambda (x) x) 'pos 'neg) 1))
-
-  )
-  
-  
- 
\ No newline at end of file