From 873e71a9dd99e2850b717b69d40ed4c1c467c593 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Thu, 2 Mar 2006 02:48:40 +0000
Subject: [PATCH] fixed PR 7927

svn: r2341
---
 collects/mzlib/private/contract.ss       | 63 ++++++++++++------------
 collects/tests/mzscheme/contract-test.ss | 22 +++++++++
 2 files changed, 53 insertions(+), 32 deletions(-)

diff --git a/collects/mzlib/private/contract.ss b/collects/mzlib/private/contract.ss
index 1c492c65d2..09fe0a93b5 100644
--- a/collects/mzlib/private/contract.ss
+++ b/collects/mzlib/private/contract.ss
@@ -1214,44 +1214,43 @@ add struct contracts for immutable structs?
        (and (identifier? (syntax struct-name))
             (syntax-local-value (syntax struct-name) (lambda () #f)))
        (with-syntax ([(ctc-x ...) (generate-temporaries (syntax (args ...)))]
-                     [(ctc-proc-x ...) (generate-temporaries (syntax (args ...)))]
+                     [(ctc-name-x ...) (generate-temporaries (syntax (args ...)))]
+                     [(ctc-pred-x ...) (generate-temporaries (syntax (args ...)))]
                      [(ctc-app-x ...) (generate-temporaries (syntax (args ...)))]
+                     [(field-numbers ...)
+                      (let loop ([i 0]
+                                 [l (syntax->list (syntax (args ...)))])
+                        (cond
+                          [(null? l) '()]
+                          [else (cons i (loop (+ i 1) (cdr l)))]))]
                      [(type-desc-id 
                        constructor-id 
                        predicate-id 
-                       (selector-id ...)
+                       (rev-selector-id ...)
                        (mutator-id ...)
                        super-id)
                       (syntax-local-value (syntax struct-name))])
-         (syntax
-          (let ([ctc-x (coerce-contract struct/c args)] ...)
-            
-            (unless predicate-id
-              (error 'struct/c "could not determine predicate for ~s" 'struct-name))
-            (unless (and selector-id ...)
-              (error 'struct/c "could not determine selectors for ~s" 'struct-name))
-            
-            (unless (flat-contract? ctc-x)
-              (error 'struct/c "expected flat contracts as arguments, got ~e" ctc-x))
-            ...
-            
-            (let ([ctc-proc-x (contract-proc ctc-x)] ...)
-              (make-contract
-               (build-compound-type-name 'struct/c 'struct-name ctc-x ...)
-               (lambda (pos neg src-info orig-str)
-                 (let ([ctc-app-x (ctc-proc-x pos neg src-info orig-str)] ...)
-                   (lambda (val)
-                     (unless (predicate-id val)
-                       (raise-contract-error
-                        val
-                        src-info
-                        pos
-                        neg
-                        orig-str
-                        "expected <~a>, given: ~e"
-                        'struct-name
-                        val))
-                    (ctc-app-x (selector-id val)) ...
-                     val))))))))]
+         (with-syntax ([(selector-id ...) (reverse (syntax->list (syntax (rev-selector-id ...))))])
+           (syntax
+            (let ([ctc-x (coerce-contract struct/c args)] ...)
+              
+              (unless predicate-id
+                (error 'struct/c "could not determine predicate for ~s" 'struct-name))
+              (unless (and selector-id ...)
+                (error 'struct/c "could not determine selectors for ~s" 'struct-name))
+              
+              (unless (flat-contract? ctc-x)
+                (error 'struct/c "expected flat contracts as arguments, got ~e" args))
+              ...
+              
+              (let ([ctc-pred-x (flat-contract-predicate ctc-x)] 
+                    ...
+                    [ctc-name-x (contract-name ctc-x)]
+                    ...)
+                (build-flat-contract
+                 (build-compound-type-name 'struct/c 'struct-name ctc-x ...)
+                 (λ (val)
+                   (and (predicate-id val)
+                        (ctc-pred-x (selector-id val)) ...))))))))]
       [(_ struct-name anything ...)
        (raise-syntax-error 'struct/c "expected a struct identifier" stx (syntax struct-name))])))
diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss
index 0272e46239..e35d2b0dd3 100644
--- a/collects/tests/mzscheme/contract-test.ss
+++ b/collects/tests/mzscheme/contract-test.ss
@@ -3115,6 +3115,24 @@
                 1
                 'pos
                 'neg)))
+  
+  (test/spec-passed
+   'struct/c3
+   '(let ()
+      (define-struct s (a b))
+      (contract (struct/c s integer? (struct/c s integer? boolean?))
+                (make-s 1 (make-s 2 #t))
+                'pos
+                'neg)))
+  
+  (test/pos-blame
+   'struct/c3
+   '(let ()
+      (define-struct s (a b))
+      (contract (struct/c s integer? (struct/c s integer? boolean?))
+                (make-s 1 (make-s 2 3))
+                'pos
+                'neg)))
 
   (test/spec-passed
    'recursive-contract1
@@ -3162,6 +3180,10 @@
   (test #t flat-contract? (and/c number? integer?))
   (test #t flat-contract? (and/c (flat-contract number?)
 				 (flat-contract integer?)))
+  (test #t flat-contract? (let ()
+                            (define-struct s (a b))
+                            (struct/c s any/c any/c)))
+  
   (test-flat-contract '(and/c number? integer?) 1 3/2)
 
   (test-flat-contract '(not/c integer?) #t 1)