From beb5f195300b0db3dda7c4f8273563ecaeba65f0 Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Fri, 5 Dec 2008 17:55:47 +0000
Subject: [PATCH] Now to move the contract info appropriately into sigs from
 signatures.

svn: r12712
---
 collects/mzlib/private/unit-compiletime.ss | 20 +++++++++++++++++---
 collects/mzlib/unit.ss                     |  3 ++-
 2 files changed, 19 insertions(+), 4 deletions(-)

diff --git a/collects/mzlib/private/unit-compiletime.ss b/collects/mzlib/private/unit-compiletime.ss
index bf8b306a46..079764d012 100644
--- a/collects/mzlib/private/unit-compiletime.ss
+++ b/collects/mzlib/private/unit-compiletime.ss
@@ -57,8 +57,10 @@
   ;; - (cons identifier identifier)
   ;; A def is
   ;; - (listof (cons (listof int/ext) syntax-object))
+  ;; A ctc-pair is
+  ;; - (cons int/ext syntax-object)
   ;; A sig is
-  ;; - (list (listof int/ext) (listof def) (listof def))
+  ;; - (list (listof int/ext) (listof def) (listof def) (listof ctc-pair))
   ;; A tagged-sig is 
   ;; - (listof (cons #f siginfo) (cons #f identifier) sig)
   ;; - (listof (cons symbol siginfo) (cons symbol identifier) sig)
@@ -220,6 +222,7 @@
            (vars (signature-vars sig))
            (vals (signature-val-defs sig))
            (stxs (signature-stx-defs sig))
+           (cps  (signature-ctc-pairs sig))
            (delta-introduce (if bind?
                                 (let ([f (syntax-local-make-delta-introducer
                                           spec)])
@@ -244,7 +247,12 @@
                         (cons (map (λ (id) (cons id id))
                                    (car stx))
                               (cdr stx)))
-                      stxs)))))
+                      stxs)
+                     (map
+                      (λ (cp)
+                        (cons (cons (car cp) (car cp))
+                              (cdr cp)))
+                      cps)))))
   
   (define (sig-names sig)
     (append (car sig)
@@ -265,12 +273,18 @@
                (car def))
           (g (cdr def))))
   
+  ;; map-ctc-pair : (identifier -> identifier) (syntax-object -> syntax-object) ctc-pair -> ctc-pair
+  (define (map-ctc-pair f g cp)
+    (cons (cons (f (caar cp)) (g (cdar cp)))
+          (g (cdr cp))))
+  
   ;; map-sig : (identifier -> identifier) (sytnax-object -> syntax-object)  sig -> sig
   ;; applies f to the internal parts, and g to the external parts.
   (define (map-sig f g sig)
     (list (map (lambda (x) (cons (f (car x)) (g (cdr x)))) (car sig))
           (map (lambda (x) (map-def f g x)) (cadr sig))
-          (map (lambda (x) (map-def f g x)) (caddr sig))))
+          (map (lambda (x) (map-def f g x)) (caddr sig))
+          (map (lambda (x) (map-ctc-pair f g x)) (cadddr sig))))
   
   ;; An import-spec is one of
   ;; - signature-name
diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss
index 8a2d8299c8..48ba22921b 100644
--- a/collects/mzlib/unit.ss
+++ b/collects/mzlib/unit.ss
@@ -123,7 +123,8 @@
   (define-for-syntax (build-val+macro-defs sig)
     (with-syntax ([(((int-ivar . ext-ivar) ...)
                     ((((int-vid . ext-vid) ...) . vbody) ...)
-                    ((((int-sid . ext-sid) ...) . sbody) ...))
+                    ((((int-sid . ext-sid) ...) . sbody) ...)
+                    (((int-cid . ext-cid) . cbody) ...))
                    (map-sig (lambda (x) x)
                             (make-syntax-introducer)
                             sig)])