From 2f323578def1504977a1238d3d5c5fbfece9cd1e Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Thu, 29 Jan 2009 07:19:23 +0000
Subject: [PATCH] Disallow unit/new-import-export if contracts are involved. 
 This is not planned to be permanent, but until I've figured out how to
 implement the fix, just say no.

svn: r13311
---
 collects/mzlib/unit.ss                      | 44 +++++++++++++-------
 collects/tests/units/test-unit-contracts.ss | 46 ++++++++++++++++++++-
 2 files changed, 75 insertions(+), 15 deletions(-)

diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss
index e2d1b30118..c4557dcd5e 100644
--- a/collects/mzlib/unit.ss
+++ b/collects/mzlib/unit.ss
@@ -762,29 +762,45 @@
          (define v
            #`(hash-table-get #,table-stx #,(car (tagged-info->keys tagged-info))))
          (for-each
-          (lambda (int/ext-name index)
+          (lambda (int/ext-name index ctc)
             (bound-identifier-mapping-put! def-table
                                            (car int/ext-name)
-                                           #`(vector-ref #,v #,index)))
+                                           (cons #`(vector-ref #,v #,index) ctc)))
           (car sig)
-          (iota (length (car sig)))))
+          (iota (length (car sig)))
+          (cadddr sig)))
        import-tagged-infos
        import-sigs)
       (with-syntax ((((eloc ...) ...) 
                      (map
                       (lambda (target-sig)
                         (map
-                         (lambda (target-int/ext-name)
-                           (bound-identifier-mapping-get
-                            def-table
-                            (car target-int/ext-name)
-                            (lambda ()
-                              (raise-stx-err
-                               (format (if import?
-                                           "identifier ~a is not present in new imports"
-                                           "identifier ~a is not present in old export")
-                                       (syntax-e (car target-int/ext-name)))))))
-                         (car target-sig)))
+                         (lambda (target-int/ext-name target-ctc)
+                           (when target-ctc
+                             (raise-stx-err
+                              (format (if import?
+                                          "identifier ~a is contracted in old imports"
+                                          "identifier ~a is contracted in new exports")
+                                      (syntax-e (car target-int/ext-name)))))
+                           (let ([vref/ctc
+                                  (bound-identifier-mapping-get
+                                   def-table
+                                   (car target-int/ext-name)
+                                   (lambda ()
+                                     (raise-stx-err
+                                      (format (if import?
+                                                  "identifier ~a is not present in new imports"
+                                                  "identifier ~a is not present in old exports")
+                                              (syntax-e (car target-int/ext-name))))))])
+                             (when (cdr vref/ctc)
+                               (raise-stx-err
+                                (format (if import?
+                                            "identifier ~a is contracted in new imports"
+                                            "identifier ~a is contracted in old exports")
+                                        (syntax-e (car target-int/ext-name)))))
+                             (car vref/ctc)))
+                         (car target-sig)
+                         (cadddr target-sig)))
                       target-import-sigs))
                     (((export-keys ...) ...) 
                      (map tagged-info->keys target-import-tagged-infos)))
diff --git a/collects/tests/units/test-unit-contracts.ss b/collects/tests/units/test-unit-contracts.ss
index 4b8538ba6d..fc128da73d 100644
--- a/collects/tests/units/test-unit-contracts.ss
+++ b/collects/tests/units/test-unit-contracts.ss
@@ -194,4 +194,48 @@
   (test-runtime-error exn:fail:contract? "unit11 provides improper f"
     (f 3))
   (test-runtime-error exn:fail:contract? "top-level misuses f"
-    (f #t)))
\ No newline at end of file
+    (f #t)))
+
+;; eventually we can hopefully fix this so these are allowed, but for right
+;; now, test that they fail during unit/new-import-export
+
+(define-signature sig7 (x))
+(define-signature sig8 ((contracted [x number?])))
+
+(define-unit unit12
+  (import sig7)
+  (export)
+  x)
+(define-unit unit13
+  (import sig8)
+  (export)
+  x)
+(define-unit unit14
+  (import)
+  (export sig8)
+  (define x 3))
+(define-unit unit15
+  (import)
+  (export sig7)
+  (define x 3))
+
+(test-syntax-error "not contracted in old import -> contracted in new"
+  (unit/new-import-export
+   (import sig8)
+   (export)
+   (() unit12 sig7)))
+(test-syntax-error "contracted in old import -> not contracted in new"
+  (unit/new-import-export
+   (import sig7)
+   (export)
+   (() unit13 sig8)))
+(test-syntax-error "not contracted in old export -> contracted in new"
+  (unit/new-import-export
+   (import)
+   (export sig8)
+   ((sig7) unit14)))  
+(test-syntax-error "contracted in old export -> not contracted in new"
+  (unit/new-import-export
+   (import)
+   (export sig7)
+   ((sig8) unit15)))