From f6493e1c3265627799d62d422a252dd20f14675b Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Sat, 31 Jan 2009 01:39:23 +0000
Subject: [PATCH] Abstraction of the boxes used for unit imports/exports to
 allow for adding contracts in an already created unit.

svn: r13331
---
 collects/mzlib/unit.ss                      |  83 +++--
 collects/tests/units/test-unit-contracts.ss | 352 ++++++++++++++++++--
 2 files changed, 369 insertions(+), 66 deletions(-)

diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss
index c4557dcd5e..9136ece466 100644
--- a/collects/mzlib/unit.ss
+++ b/collects/mzlib/unit.ss
@@ -472,12 +472,12 @@
   (define-for-syntax (make-import-unboxing var loc ctc)
     (if ctc
         (quasisyntax/loc (error-syntax)
-          (quote-syntax (let ([v/c (unbox #,loc)])
+          (quote-syntax (let ([v/c ((car #,loc))])
                           (contract #,ctc (car v/c) (cdr v/c)
                                     (current-contract-region)
                                     #,(id->contract-src-info var)))))
         (quasisyntax/loc (error-syntax)
-          (quote-syntax (unbox #,loc)))))
+          (quote-syntax ((car #,loc))))))
   
   ;; build-unit : syntax-object -> 
   ;;             (values syntax-object (listof identifier) (listof identifier))
@@ -557,7 +557,10 @@
                (list (cons 'dept depr) ...)
                (syntax-parameterize ([current-contract-region (lambda (stx) #'(quote (unit name)))])
                  (lambda ()
-                   (let ([eloc (box undefined)] ... ...)
+                   (let ([eloc (let ([loc (box undefined)])
+                                 (cons
+                                  (λ () (unbox loc))
+                                  (λ (v) (set-box! loc v))))] ... ...)
                      (values 
                       (lambda (import-table)
                         (let-values ([(iloc ...)
@@ -731,12 +734,12 @@
                                                                                         (current-contract-region)
                                                                                         'cant-happen
                                                                                         #,(id->contract-src-info id))
-                                                                              (set-box! #,export-loc 
-                                                                                        (let ([#,id #,tmp])
-                                                                                          (cons #,id (current-contract-region))))))
+                                                                              ((cdr #,export-loc) 
+                                                                               (let ([#,id #,tmp])
+                                                                                 (cons #,id (current-contract-region))))))
                                                                           (quasisyntax/loc defn-or-expr
-                                                                            (set-box! #,export-loc 
-                                                                                      (let ([#,id #,tmp]) #,id))))
+                                                                            ((cdr #,export-loc) 
+                                                                             (let ([#,id #,tmp]) #,id))))
                                                                       (quasisyntax/loc defn-or-expr
                                                                         (define-syntax #,id 
                                                                           (make-id-mapper (quote-syntax #,tmp)))))))]
@@ -776,12 +779,6 @@
                       (lambda (target-sig)
                         (map
                          (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
@@ -792,13 +789,26 @@
                                                   "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)))
+                             (let ([old-cl (car vref/ctc)])
+                               #`(cons
+                                  (λ ()
+                                    (let ([old-v #,(if (cdr vref/ctc)
+                                                       #`(let ([old-v/c ((car #,old-cl))])
+                                                           (contract #,(cdr vref/ctc) (car old-v/c) 
+                                                                     (cdr old-v/c) (current-contract-region)
+                                                                     #,(id->contract-src-info (car target-int/ext-name))))
+                                                       #`((car #,old-cl)))])
+                                      #,(if target-ctc
+                                            #'(cons old-v (current-contract-region))
+                                            #'old-v)))
+                                  (λ (v) (let ([new-v #,(if (cdr vref/ctc)
+                                                            #`(contract #,(cdr vref/ctc) (car v)
+                                                                        (current-contract-region) (cdr v)
+                                                                        #,(id->contract-src-info (car target-int/ext-name)))
+                                                            #'v)])
+                                           #,(if target-ctc
+                                                 #`((cdr #,old-cl) (cons new-v (current-contract-region)))
+                                                 #`((cdr #,old-cl) new-v))))))))
                          (car target-sig)
                          (cadddr target-sig)))
                       target-import-sigs))
@@ -902,19 +912,20 @@
                    (vector-immutable (cons 'export-name 
                                            (vector-immutable export-key ...)) ...)
                    (list (cons 'dept depr) ...)
-                   (lambda ()
-                     (let-values ([(unit-fn export-table) ((unit-go unit-tmp))])
-                       (values (lambda (import-table)
-                                 (unit-fn #,(redirect-imports #'import-table
-                                                              import-tagged-infos
-                                                              import-sigs
-                                                              orig-import-tagged-infos
-                                                              orig-import-sigs)))
-                               #,(redirect-exports #'export-table
-                                                   orig-export-tagged-infos
-                                                   orig-export-sigs
-                                                   export-tagged-infos
-                                                   export-sigs)))))))
+                   (syntax-parameterize ([current-contract-region (lambda (stx) #'(quote (unit name)))])
+                     (lambda ()
+                       (let-values ([(unit-fn export-table) ((unit-go unit-tmp))])
+                         (values (lambda (import-table)
+                                   (unit-fn #,(redirect-imports #'import-table
+                                                                import-tagged-infos
+                                                                import-sigs
+                                                                orig-import-tagged-infos
+                                                                orig-import-sigs)))
+                                 #,(redirect-exports #'export-table
+                                                     orig-export-tagged-infos
+                                                     orig-export-sigs
+                                                     export-tagged-infos
+                                                     export-sigs))))))))
               import-tagged-sigids
               export-tagged-sigids
               dep-tagged-sigids)))))))
@@ -1238,11 +1249,11 @@
                            (map 
                             (lambda (i v c)
                               (if c
-                                  #`(let ([v/c (unbox (vector-ref #,ov #,i))])
+                                  #`(let ([v/c ((car (vector-ref #,ov #,i)))])
                                       (contract #,c (car v/c) (cdr v/c)
                                                 (current-contract-region)
                                                 #,(id->contract-src-info v)))
-                                  #`(unbox (vector-ref #,ov #,i))))
+                                  #`((car (vector-ref #,ov #,i)))))
                             (iota (length (car os)))
                             (map car (car os))
                             (cadddr os)))
diff --git a/collects/tests/units/test-unit-contracts.ss b/collects/tests/units/test-unit-contracts.ss
index fc128da73d..4332adc2b1 100644
--- a/collects/tests/units/test-unit-contracts.ss
+++ b/collects/tests/units/test-unit-contracts.ss
@@ -196,46 +196,338 @@
   (test-runtime-error exn:fail:contract? "top-level misuses f"
     (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
+;; unit/new-import-export tests
 
-(define-signature sig7 (x))
-(define-signature sig8 ((contracted [x number?])))
+(define-signature sig7 (f))
+(define-signature sig8 ((contracted [f (-> number? number?)])))
+(define-signature sig9 ((contracted [f (-> number? number?)])))
 
+;; All units that play nicely
 (define-unit unit12
   (import sig7)
   (export)
-  x)
+  (f 3))
 (define-unit unit13
   (import sig8)
   (export)
-  x)
+  (f 3))
 (define-unit unit14
   (import)
-  (export sig8)
-  (define x 3))
+  (export sig7)
+  (define f (λ (n) 3)))
 (define-unit unit15
   (import)
-  (export sig7)
-  (define x 3))
+  (export sig8)
+  (define f (λ (n) 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)))
+;; All units that don't play nicely (or won't after converted)
+(define-unit unit16
+  (import sig7)
+  (export)
+  (f #t))
+(define-unit unit17
+  (import sig8)
+  (export)
+  (f #t))
+(define-unit unit18
+  (import)
+  (export sig7)
+  (define f (λ (n) #t)))
+(define-unit unit19
+  (import)
+  (export sig8)
+  (define f (λ (n) #t)))
+
+;; Converting units without internal contract violations
+
+;; uncontracted import -> contracted import
+(define-unit/new-import-export unit20
+  (import sig8)
+  (export)
+  (() unit12 sig7))
+(let ()
+  (define-compound-unit unit21
+    (import)
+    (export)
+    (link [((S : sig8)) unit15]
+          [() unit20 S]))
+  (invoke-unit unit21))
+(let ()
+  (define-compound-unit unit22
+    (import)
+    (export)
+    (link [((S : sig8)) unit19]
+          [() unit20 S]))
+  (test-runtime-error exn:fail:contract? "unit19 provides bad f"
+    (invoke-unit unit22)))
+
+;; contracted import -> uncontracted import
+(define-unit/new-import-export unit23
+  (import sig7)
+  (export)
+  (() unit13 sig8))
+(let ()
+  (define-compound-unit unit24
+    (import)
+    (export)
+    (link [((S : sig7)) unit14]
+          [() unit23 S]))
+  (invoke-unit unit24))
+(let ()
+  (define-compound-unit unit25
+    (import)
+    (export)
+    (link [((S : sig7)) unit18]
+          [() unit23 S]))
+  (test-runtime-error exn:fail:contract? "unit23 provides f with no protection into a bad context"
+    (invoke-unit unit25)))
+
+;; contracted import -> contracted import
+(define-unit/new-import-export unit26
+  (import sig9)
+  (export)
+  (() unit13 sig8))
+(let ()
+  (define-unit unit27-1
+    (import)
+    (export sig9)
+    (define (f n) 3))
+  (define-compound-unit unit27-2
+    (import)
+    (export)
+    (link [((S : sig9)) unit27-1]
+          [() unit26 S]))
+  (invoke-unit unit27-2))
+(let ()
+  (define-unit unit28-1
+    (import)
+    (export sig9)
+    (define (f n) #f))
+  (define-compound-unit unit28-2
+    (import)
+    (export)
+    (link [((S : sig9)) unit28-1]
+          [() unit26 S]))
+  (test-runtime-error exn:fail:contract? "unit28-1 broke contract on f"
+    (invoke-unit unit28-2)))
+
+;; uncontracted export -> contracted export
+(define-unit/new-import-export unit29
+  (import)
+  (export sig8)
+  ((sig7) unit14))
+(let ()
+  (define-compound-unit unit30
+    (import)
+    (export)
+    (link [((S : sig8)) unit29]
+          [() unit13 S]))
+  (invoke-unit unit30))
+(let ()
+  (define-compound-unit unit31
+    (import)
+    (export)
+    (link [((S : sig8)) unit29]
+          [() unit17 S]))
+  (test-runtime-error exn:fail:contract? "unit17 misuses f"
+    (invoke-unit unit31)))
+
+;; contracted export -> uncontracted export
+(define-unit/new-import-export unit32
+  (import)
+  (export sig7)
+  ((sig8) unit15))
+(let ()
+  (define-compound-unit unit33
+    (import)
+    (export)
+    (link [((S : sig7)) unit32]
+          [() unit14 S]))
+  (invoke-unit unit33))
+(let ()
+  (define-compound-unit unit34
+    (import)
+    (export)
+    (link [((S : sig7)) unit32]
+          [() unit16 S]))
+  (test-runtime-error exn:fail:contract? "unit32 provides f with no protection into bad context"
+    (invoke-unit unit34)))
+
+;; contracted export -> contracted export
+(define-unit/new-import-export unit35
+  (import)
+  (export sig9)
+  ((sig8) unit15))
+(let ()
+  (define-unit unit36-1
+    (import sig9)
+    (export)
+    (f 3))
+  (define-compound-unit unit36-2
+    (import)
+    (export)
+    (link [((S : sig9)) unit35]
+          [() unit36-1 S]))
+  (invoke-unit unit36-2))
+(let ()
+  (define-unit unit37-1
+    (import sig9)
+    (export)
+    (f #f))
+  (define-compound-unit unit37-2
+    (import)
+    (export)
+    (link [((S : sig9)) unit35]
+          [() unit37-1 S]))
+  (test-runtime-error exn:fail:contract? "unit37-1 broke contract on f"
+    (invoke-unit unit37-2)))
+
+;; Converting units with internal contract violations
+
+;; uncontracted import -> contracted import
+(define-unit/new-import-export unit38
+  (import sig8)
+  (export)
+  (() unit16 sig7))
+(let ()
+  (define-compound-unit unit39
+    (import)
+    (export)
+    (link [((S : sig8)) unit15]
+          [() unit38 S]))
+  (test-runtime-error exn:fail:contract? "unit38 allowed f to flow into uncontracted bad context"
+    (invoke-unit unit39)))
+(let ()
+  (define-compound-unit unit40
+    (import)
+    (export)
+    (link [((S : sig8)) unit19]
+          [() unit38 S]))
+  (test-runtime-error exn:fail:contract? "unit38 allowed f to flow into uncontracted bad context"
+    (invoke-unit unit40)))
+
+;; contracted import -> uncontracted import
+(define-unit/new-import-export unit41
+  (import sig7)
+  (export)
+  (() unit17 sig8))
+(let ()
+  (define-compound-unit unit42
+    (import)
+    (export)
+    (link [((S : sig7)) unit14]
+          [() unit41 S]))
+  (test-runtime-error exn:fail:contract? "unit17 misuses f"
+    (invoke-unit unit42)))
+(let ()
+  (define-compound-unit unit43
+    (import)
+    (export)
+    (link [((S : sig7)) unit18]
+          [() unit41 S]))
+  (test-runtime-error exn:fail:contract? "unit17 misuses f"
+    (invoke-unit unit43)))
+
+;; contracted import -> contracted import
+(define-unit/new-import-export unit44
+  (import sig9)
+  (export)
+  (() unit17 sig8))
+(let ()
+  (define-unit unit45-1
+    (import)
+    (export sig9)
+    (define (f n) 3))
+  (define-compound-unit unit45-2
+    (import)
+    (export)
+    (link [((S : sig9)) unit45-1]
+          [() unit44 S]))
+  (test-runtime-error exn:fail:contract? "unit17 misuses f"
+    (invoke-unit unit45-2)))
+(let ()
+  (define-unit unit46-1
+    (import)
+    (export sig9)
+    (define (f n) #t))
+  (define-compound-unit unit46-2
+    (import)
+    (export)
+    (link [((S : sig9)) unit46-1]
+          [() unit44 S]))
+  (test-runtime-error exn:fail:contract? "unit17 misuses f"
+    (invoke-unit unit46-2)))
+
+;; uncontracted export -> contracted export
+(define-unit/new-import-export unit47
+  (import)
+  (export sig8)
+  ((sig7) unit18))
+(let ()
+  (define-compound-unit unit48
+    (import)
+    (export)
+    (link [((S : sig8)) unit47]
+          [() unit13 S]))
+  (test-runtime-error exn:fail:contract? "unit47 provided bad f"
+    (invoke-unit unit48)))
+(let ()
+  (define-compound-unit unit49
+    (import)
+    (export)
+    (link [((S : sig8)) unit47]
+          [() unit17 S]))
+  (test-runtime-error exn:fail:contract? "unit17 misuses f"
+    (invoke-unit unit49)))
+
+;; contracted import -> uncontracted import
+(define-unit/new-import-export unit50
+  (import)
+  (export sig7)
+  ((sig8) unit19))
+(let ()
+  (define-compound-unit unit51
+    (import)
+    (export)
+    (link [((S : sig7)) unit50]
+          [() unit12 S]))
+  (test-runtime-error exn:fail:contract? "unit19 provides bad f"
+    (invoke-unit unit51)))
+(let ()
+  (define-compound-unit unit52
+    (import)
+    (export)
+    (link [((S : sig7)) unit50]
+          [() unit16 S]))
+  (test-runtime-error exn:fail:contract? "unit50 provides unprotected f into bad context"
+    (invoke-unit unit52)))
+
+;; contracted export -> contracted export
+(define-unit/new-import-export unit53
+  (import)
+  (export sig9)
+  ((sig8) unit19))
+(let ()
+  (define-unit unit54-1
+    (import sig9)
+    (export)
+    (f 3))
+  (define-compound-unit unit54-2
+    (import)
+    (export)
+    (link [((S : sig9)) unit53]
+          [() unit54-1 S]))
+  (test-runtime-error exn:fail:contract? "unit19 provides bad f"
+    (invoke-unit unit54-2)))
+(let ()
+  (define-unit unit55-1
+    (import sig9)
+    (export)
+    (f #t))
+  (define-compound-unit unit55-2
+    (import)
+    (export)
+    (link [((S : sig9)) unit53]
+          [() unit55-1 S]))
+  (test-runtime-error exn:fail:contract? "unit55-1 misuses f"
+    (invoke-unit unit55-2)))
\ No newline at end of file