From 9b7e1767ddf9b77d74203a64fcb1618c07bef8bc Mon Sep 17 00:00:00 2001
From: Daniel Feltey <dfeltey@gmail.com>
Date: Tue, 25 Aug 2015 17:01:04 -0500
Subject: [PATCH] Add syntax property with static init-depend information to
 compound-unit/infer results

---
 .../racket/private/unit-compiletime.rkt       | 17 ++++++-
 racket/collects/racket/unit.rkt               | 49 ++++++++++---------
 2 files changed, 43 insertions(+), 23 deletions(-)

diff --git a/racket/collects/racket/private/unit-compiletime.rkt b/racket/collects/racket/private/unit-compiletime.rkt
index c1b66fd30f..916b869e83 100644
--- a/racket/collects/racket/private/unit-compiletime.rkt
+++ b/racket/collects/racket/private/unit-compiletime.rkt
@@ -22,7 +22,8 @@
          map-sig split-requires split-requires* apply-mac complete-exports complete-imports check-duplicate-subs
          process-spec
          make-relative-introducer
-         bind-at)
+         bind-at
+         build-init-depend-property)
 
 (define-syntax (apply-mac stx)
   (syntax-case stx ()
@@ -594,3 +595,17 @@
          sstx
          (cons unbox-stx #'x)
          sstx)]))))
+
+;; This utility function returns a list of natural numbers for use as a syntax
+;; property needed to support units in Typed Racket
+(define (build-init-depend-property init-depends imports)
+  ;; Typed Racket does not support tagged imports or exports
+  ;; so drop the tags from init-depends and imports
+  (let ([id-sigs (map cdr init-depends)]
+        [import-sigs (map cdr imports)])
+    (let loop ([i 0] [imports import-sigs])
+      (cond
+        [(null? imports) '()]
+        [else (if (member (car imports) id-sigs free-identifier=?)
+                  (cons i (loop (add1 i) (cdr imports)))
+                  (loop (add1 i) (cdr imports)))]))))
\ No newline at end of file
diff --git a/racket/collects/racket/unit.rkt b/racket/collects/racket/unit.rkt
index 950dcf46c2..65c18bf01f 100644
--- a/racket/collects/racket/unit.rkt
+++ b/racket/collects/racket/unit.rkt
@@ -1645,29 +1645,34 @@
                            (syntax->list #'((((sub-in-key sub-in-code) ...) ...) ...))))
                          )
              (values
-              (quasisyntax/loc (error-syntax)
-                (let ([deps '()]
-                      [sub-tmp sub-exp] ...)
-                  check-sub-exp ...
-                  (make-unit
-                   'name
-                   (vector-immutable
-                    (cons 'import-name
-                          (vector-immutable import-key ...))
-                    ...)
-                   (vector-immutable
-                    (cons 'export-name
-                          (vector-immutable export-key ...))
-                    ...)
-                   deps
-                   (lambda ()
-                     (let-values ([(sub-tmp sub-export-table-tmp) ((unit-go sub-tmp))]
+              (syntax-property
+               (quasisyntax/loc (error-syntax)
+                 (let ([deps '()]
+                       [sub-tmp sub-exp] ...)
+                   check-sub-exp ...
+                   (make-unit
+                    'name
+                    (vector-immutable
+                     (cons 'import-name
+                           (vector-immutable import-key ...))
+                     ...)
+                    (vector-immutable
+                     (cons 'export-name
+                           (vector-immutable export-key ...))
+                     ...)
+                    deps
+                    (lambda ()
+                      (let-values ([(sub-tmp sub-export-table-tmp) ((unit-go sub-tmp))]
+                                   ...)
+                        (values (lambda (import-table-id)
+                                  (void)
+                                  (sub-tmp (equal-hash-table sub-in-key-code-workaround ...))
                                   ...)
-                       (values (lambda (import-table-id)
-                                 (void)
-                                 (sub-tmp (equal-hash-table sub-in-key-code-workaround ...))
-                                 ...)
-                               (unit-export ((export-key ...) export-code) ...)))))))
+                                (unit-export ((export-key ...) export-code) ...)))))))
+               'tr:inferred-init-depend-property
+               (build-init-depend-property
+                static-dep-info
+                (map syntax-e (syntax->list #'((import-tag . import-sigid) ...)))))
               (map syntax-e (syntax->list #'((import-tag . import-sigid) ...)))
               (map syntax-e (syntax->list #'((export-tag . export-sigid) ...)))
               static-dep-info))))))