From b01290c3efae6b79deea2946201e5596775aa814 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Thu, 21 Jul 2005 00:22:36 +0000
Subject: [PATCH] fixed bug in provide/contract

svn: r411
---
 collects/mzlib/private/contract.ss       | 70 ++++++++++++------------
 collects/tests/mzscheme/contract-test.ss | 19 ++++++-
 2 files changed, 51 insertions(+), 38 deletions(-)

diff --git a/collects/mzlib/private/contract.ss b/collects/mzlib/private/contract.ss
index d90601a008..7d3ae9012c 100644
--- a/collects/mzlib/private/contract.ss
+++ b/collects/mzlib/private/contract.ss
@@ -379,42 +379,40 @@ add struct contracts for immutable structs?
                              #f)]
                            [(field-contracts ...) field-contracts]
                            [(field-contract-ids ...) field-contract-ids])
-               (with-syntax ([struct-code 
-                              (with-syntax ([id-rename (a:mangle-id provide-stx 
-                                                                    "provide/contract-struct-expandsion-info-id"
-                                                                    struct-name)]
-                                            [struct-name struct-name]
-                                            [struct:struct-name struct:struct-name]
-                                            ;[(selector-id ...) selector-ids]
-                                            ;[(mutator-id ...) mutator-ids]
-                                            ;[predicate-id predicate-id]
-                                            ;[constructor-id constructor-id]
-                                            [super-id (if (boolean? super-id)
-                                                          super-id
-                                                          (with-syntax ([super-id super-id])
-                                                            (syntax #'super-id)))])
-                                (syntax (begin
-                                          #;
-                                          (provide struct-name)
-                                          
-                                          (provide (rename id-rename struct-name))
-                                          (define-syntax id-rename
-                                            (list-immutable #'struct:struct-name
-                                                            #'constructor-new-name
-                                                            #'predicate-new-name
-                                                            (list-immutable #'selector-new-names ...)
-                                                            (list-immutable #'mutator-new-names ...)
-                                                            super-id)))))]
-                             [struct:struct-name struct:struct-name])
-                 (syntax/loc stx
-                   (begin
-                     struct-code
-                     (define field-contract-ids field-contracts) ...
-                     selector-codes ...
-                     mutator-codes ...
-                     predicate-code
-                     constructor-code
-                     (provide struct:struct-name)))))))
+               (with-syntax ([(rev-selector-new-names ...) (reverse (syntax->list (syntax (selector-new-names ...))))]
+                             [(rev-mutator-new-names ...) (reverse (syntax->list (syntax (mutator-new-names ...))))])
+                 (with-syntax ([struct-code 
+                                (with-syntax ([id-rename (a:mangle-id provide-stx 
+                                                                      "provide/contract-struct-expandsion-info-id"
+                                                                      struct-name)]
+                                              [struct-name struct-name]
+                                              [struct:struct-name struct:struct-name]
+                                              [super-id (if (boolean? super-id)
+                                                            super-id
+                                                            (with-syntax ([super-id super-id])
+                                                              (syntax #'super-id)))])
+                                  (syntax (begin
+                                            #;
+                                            (provide struct-name)
+                                            
+                                            (provide (rename id-rename struct-name))
+                                            (define-syntax id-rename
+                                              (list-immutable #'struct:struct-name
+                                                              #'constructor-new-name
+                                                              #'predicate-new-name
+                                                              (list-immutable #'rev-selector-new-names ...)
+                                                              (list-immutable #'rev-mutator-new-names ...)
+                                                              super-id)))))]
+                               [struct:struct-name struct:struct-name])
+                   (syntax/loc stx
+                     (begin
+                       struct-code
+                       (define field-contract-ids field-contracts) ...
+                       selector-codes ...
+                       mutator-codes ...
+                       predicate-code
+                       constructor-code
+                       (provide struct:struct-name))))))))
  
          ;; map/count : (X Y int -> Z) (listof X) (listof Y) -> (listof Z)
          (define (map/count f l1 l2)
diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss
index e61e259860..5f626c82bd 100644
--- a/collects/tests/mzscheme/contract-test.ss
+++ b/collects/tests/mzscheme/contract-test.ss
@@ -1483,9 +1483,24 @@
    '(parameterize ([current-namespace (make-namespace)])
       (eval '(module m mzscheme
                (require (lib "contract.ss"))
-(define-struct (exn2 exn) ())
-(provide/contract (struct (exn2 exn) ((message any/c) (continuation-marks any/c))))))
+               (define-struct (exn2 exn) ())
+               (provide/contract (struct (exn2 exn) ((message any/c) (continuation-marks any/c))))))
       (eval '(require m))))
+  
+  (test/spec-passed/result
+   'provide/contract13
+   '(parameterize ([current-namespace (make-namespace)])
+      (eval '(module common-msg-structs mzscheme
+               (require (lib "contract.ss" "mzlib"))
+               (define-struct register (name type) (make-inspector))
+               (provide/contract (struct register ([name any/c] [type any/c])))))
+      
+      (eval '(require common-msg-structs))
+      (eval '(require (lib "plt-match.ss")))
+      (eval '(match (make-register 1 2)
+               [(struct register (name type))
+                (list name type)])))
+   (list 1 2))
 
   
 ;