From 74dad6d8d4210ee9b48ad65b62332117b5acc383 Mon Sep 17 00:00:00 2001 From: Stevie Strickland 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 original commit: cf005e3297f845dadedda0c6c55f86d2ec8bb661 --- collects/mzlib/unit.ss | 25 ++++++++++++++++++++++++- 1 file changed, 24 insertions(+), 1 deletion(-) diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index b93bc54..546e8a0 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 )" (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")