From b0266fa590fb6fed3d820f95bd5dac32fa22bdd9 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Fri, 12 Mar 2004 00:05:36 +0000
Subject: [PATCH] .

original commit: 405cb4839a3bc22112b9f96d29b0f1be52327799
---
 collects/mzlib/contract.ss               | 49 ++++++++++++++++++++++++
 collects/tests/mzscheme/contract-test.ss | 42 +++++++++++++++++++-
 2 files changed, 90 insertions(+), 1 deletion(-)

diff --git a/collects/mzlib/contract.ss b/collects/mzlib/contract.ss
index 0ac7655..df5bb5f 100644
--- a/collects/mzlib/contract.ss
+++ b/collects/mzlib/contract.ss
@@ -8,11 +8,16 @@ add struct contracts for immutable structs?
 |#
 
 (module contract mzscheme
+  
+  ;; no bytes in v206
+;  (define (bytes? x) #f)
+  
   (provide (rename -contract contract)
            ->
            ->d
            ->*
            ->d*
+           ->r
            case->
 	   opt->
            opt->*
@@ -646,6 +651,50 @@ add struct contracts for immutable structs?
 ;                                                                                   
 ;                                                                                   
 
+  (define-syntax (->r stx)
+    (syntax-case stx ()
+      [(-> ([x dom] ...) rng)
+       (and (andmap identifier? (syntax->list (syntax (x ...))))
+            (not (check-duplicate-identifier (syntax->list (syntax (x ...))))))
+       (with-syntax ([(dom-id ...) (generate-temporaries (syntax (x ...)))]
+                     [arity-count (length (syntax->list (syntax (x ...))))])
+         (syntax 
+          (make-contract 
+           "name"
+           (lambda (pos-blame neg-blame src-info orig-str)
+             (lambda (v)
+               (unless (procedure? v)
+                 (raise-contract-error src-info
+                                       pos-blame
+                                       neg-blame
+                                       orig-str
+                                       "expected a procedure, got ~e"
+                                       v))
+               (unless (procedure-arity-includes? v arity-count)
+                 (raise-contract-error src-info
+                                       pos-blame
+                                       neg-blame
+                                       orig-str
+                                       "expected a procedure of arity ~a, got ~e"
+                                       arity-count
+                                       v))
+               (lambda (x ...)
+                 (let ([dom-id ((coerce/select-contract ->r dom) pos-blame neg-blame src-info orig-str)]
+                       ...
+                       [rng-id ((coerce/select-contract ->r rng) pos-blame neg-blame src-info orig-str)])
+                   (rng-id (v (dom-id x) ...)))))))))]
+      [(-> ([x dom] ...) rng)
+       (andmap identifier? (syntax->list (syntax (x ...))))
+       (raise-syntax-error 
+        '->r
+        "duplicate identifier"
+        stx
+        (check-duplicate-identifier (syntax->list (syntax (x ...)))))]
+      [(-> ([x dom] ...) rng)
+       (for-each (lambda (x) (unless (identifier? x) (raise-syntax-error '->r "expected identifier" stx x)))
+                 (syntax->list (syntax (x ...))))]
+      [(-> x dom rng)
+       (raise-syntax-error '->r "expected list of identifiers and expression pairs" stx (syntax x))]))
   
   (define-syntax-set (-> ->* ->d ->d* case-> object-contract opt-> opt->*)
     
diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss
index e924a54..6841c13 100644
--- a/collects/tests/mzscheme/contract-test.ss
+++ b/collects/tests/mzscheme/contract-test.ss
@@ -596,7 +596,47 @@
                  'pos
                  'neg)
        (lambda () (set! x 2)))))
- 
+  
+  (test/spec-passed
+   '->r1
+   '((contract (->r () number?) (lambda () 1) 'pos 'neg)))
+  
+  (test/spec-passed
+   '->r2
+   '((contract (->r ([x number?]) number?) (lambda (x) (+ x 1)) 'pos 'neg) 1))
+
+  (test/pos-blame
+   '->r3
+   '((contract (->r () number?) 1 'pos 'neg)))
+  
+  (test/pos-blame
+   '->r4
+   '((contract (->r () number?) (lambda (x) x) 'pos 'neg)))
+  
+  (test/neg-blame
+   '->r5
+   '((contract (->r ([x number?]) (<=/c x)) (lambda (x) (+ x 1)) 'pos 'neg) #f))
+  
+  (test/pos-blame
+   '->r6
+   '((contract (->r ([x number?]) (<=/c x)) (lambda (x) (+ x 1)) 'pos 'neg) 1))
+  
+  (test/spec-passed
+   '->r7
+   '((contract (->r ([x number?][y (<=/c x)]) (<=/c x)) (lambda (x y) (- x 1)) 'pos 'neg) 1 0))
+  
+  (test/neg-blame
+   '->r8
+   '((contract (->r ([x number?][y (<=/c x)]) (<=/c x)) (lambda (x y) (+ x 1)) 'pos 'neg) 1 2))
+  
+  (test/spec-passed
+   '->r9
+   '((contract (->r ([y (<=/c x)][x number?]) (<=/c x)) (lambda (y x) (- x 1)) 'pos 'neg) 1 2))
+  
+  (test/neg-blame
+   '->r10
+   '((contract (->r ([y (<=/c x)][x number?]) (<=/c x)) (lambda (y x) (+ x 1)) 'pos 'neg) 1 0))
+  
   #;
   (test/neg-blame
    'combo1