suzanne.soy/compatibility
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Adding unit/s and define-unit/s, which is the inferred version of

Browse Source 
unit-new-import-export etc.

svn: r13860

original commit: cf005e3297f845dadedda0c6c55f86d2ec8bb661
This commit is contained in:
Stevie Strickland 2009-02-26 22:52:08 +00:00
parent dd8e3a30af
commit 74dad6d8d4
1 changed files with 24 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
collects/mzlib/unit.ss
View File

@ -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")