Adding unit/s and define-unit/s, which is the inferred version of
unit-new-import-export etc. svn: r13860
This commit is contained in:
parent
db70d62ca7
commit
cf005e3297
|
@ -1,6 +1,5 @@
|
||||||
(module unit mzscheme
|
(module unit mzscheme
|
||||||
(require-for-syntax mzlib/list
|
(require-for-syntax mzlib/list
|
||||||
scheme/pretty
|
|
||||||
stxclass
|
stxclass
|
||||||
syntax/boundmap
|
syntax/boundmap
|
||||||
syntax/context
|
syntax/context
|
||||||
|
@ -31,6 +30,7 @@
|
||||||
unit-from-context define-unit-from-context
|
unit-from-context define-unit-from-context
|
||||||
define-unit-binding
|
define-unit-binding
|
||||||
unit/new-import-export define-unit/new-import-export
|
unit/new-import-export define-unit/new-import-export
|
||||||
|
unit/s define-unit/s
|
||||||
unit/c define-unit/contract)
|
unit/c define-unit/contract)
|
||||||
|
|
||||||
(define-syntax/err-param (define-signature-form stx)
|
(define-syntax/err-param (define-signature-form stx)
|
||||||
|
@ -1793,5 +1793,28 @@
|
||||||
(format "expected syntax matching (~a <define-unit-identifier>)"
|
(format "expected syntax matching (~a <define-unit-identifier>)"
|
||||||
(syntax-e (stx-car stx)))))))
|
(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")
|
;(load "test-unit.ss")
|
||||||
|
|
|
@ -578,6 +578,28 @@ each of the bindings implied by an @scheme[export]
|
||||||
Like @scheme[unit/new-import-export], but binds static information to
|
Like @scheme[unit/new-import-export], but binds static information to
|
||||||
@scheme[unit-id] like @scheme[define-unit].}
|
@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}
|
@section[#:tag "define-sig-form"]{Extending the Syntax of Signatures}
|
||||||
|
|
Loading…
Reference in New Issue
Block a user