From cf005e3297f845dadedda0c6c55f86d2ec8bb661 Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Thu, 26 Feb 2009 22:52:08 +0000
Subject: [PATCH] Adding unit/s and define-unit/s, which is the inferred
 version of unit-new-import-export etc.

svn: r13860
---
 collects/mzlib/unit.ss                     | 25 +++++++++++++++++++++-
 collects/scribblings/reference/units.scrbl | 22 +++++++++++++++++++
 2 files changed, 46 insertions(+), 1 deletion(-)

diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss
index b93bc54627..546e8a033e 100644
--- a/collects/mzlib/unit.ss
+++ b/collects/mzlib/unit.ss
@@ -1,6 +1,5 @@
 (module unit mzscheme
   (require-for-syntax mzlib/list
-                      scheme/pretty
                       stxclass
                       syntax/boundmap
                       syntax/context
@@ -31,6 +30,7 @@
            unit-from-context define-unit-from-context
            define-unit-binding
            unit/new-import-export define-unit/new-import-export
+           unit/s define-unit/s
            unit/c define-unit/contract)
  
   (define-syntax/err-param (define-signature-form stx)
@@ -1793,5 +1793,28 @@
         (format "expected syntax matching (~a <define-unit-identifier>)"
                 (syntax-e (stx-car stx)))))))
   
+  (define-for-syntax (build-unit/s stx)
+    (syntax-case stx (import export init-depend)
+      [((import i ...) (export e ...) (init-depend d ...) u)
+       (let* ([ui (lookup-def-unit #'u)]
+              [unprocess (let ([i (make-syntax-delta-introducer #'u (unit-info-orig-binder ui))])
+                           (lambda (p)
+                             (unprocess-tagged-id (cons (car p) (i (cdr p))))))])
+         (with-syntax ([(isig ...) (map unprocess (unit-info-import-sig-ids ui))]
+                       [(esig ...) (map unprocess (unit-info-export-sig-ids ui))])
+           (build-unit/new-import-export
+            (syntax/loc stx
+              ((import i ...) (export e ...) (init-depend d ...) ((esig ...) u isig ...))))))]))
+
+  (define-syntax/err-param (define-unit/s stx)
+    (build-define-unit stx (λ (stx) (build-unit/s (check-unit-syntax stx)))
+      "missing unit name"))
+  
+  (define-syntax/err-param (unit/s stx)
+    (syntax-case stx ()
+      [(_ . stx)
+       (let-values ([(u x y z) (build-unit/s (check-unit-syntax #'stx))])
+         u)]))
+  
   )
 ;(load "test-unit.ss")
diff --git a/collects/scribblings/reference/units.scrbl b/collects/scribblings/reference/units.scrbl
index 1f3cf4eb6b..d216800d16 100644
--- a/collects/scribblings/reference/units.scrbl
+++ b/collects/scribblings/reference/units.scrbl
@@ -578,6 +578,28 @@ each of the bindings implied by an @scheme[export]
 Like @scheme[unit/new-import-export], but binds static information to
 @scheme[unit-id] like @scheme[define-unit].}
 
+@defform[
+#:literals (import export)
+(unit/s
+  (import tagged-sig-spec ...)
+  (export tagged-sig-spec ...)
+  init-depends-decl
+  unit-id)]{
+
+Like @scheme[unit/new-import-export], but the linking clause is
+inferred, so @scheme[unit-id] must have the appropriate static
+information.}
+@defform[
+#:literals (import export)
+(define-unit/s name-id
+  (import tagged-sig-spec ...)
+  (export tagged-sig-spec ...)
+  init-depends-decl
+  unit-id)]{
+
+Like @scheme[unit/s], but binds static information to @scheme[name-id]
+like @scheme[define-unit].}
+
 @; ------------------------------------------------------------------------
 
 @section[#:tag "define-sig-form"]{Extending the Syntax of Signatures}