85 lines
3.2 KiB
Scheme
85 lines
3.2 KiB
Scheme
#lang scheme/base
|
|
|
|
(require scheme/unit
|
|
(for-syntax scheme/base
|
|
syntax/kerncase))
|
|
|
|
(provide (rename-out [module-begin #%module-begin])
|
|
(except-out (all-from-out scheme/base) #%module-begin)
|
|
(all-from-out scheme/unit))
|
|
|
|
(define-for-syntax (make-name s)
|
|
(string->symbol
|
|
(string-append (regexp-replace "-unit$" (symbol->string s) "")
|
|
"@")))
|
|
|
|
;; Look for `import' and `export', and start processing the body:
|
|
(define-syntax (module-begin stx)
|
|
(syntax-case stx ()
|
|
[(_ elem ...)
|
|
(with-syntax ([((elem ...) . (literal ...))
|
|
(let loop ([elems (syntax->list #'(elem ...))]
|
|
[accum null])
|
|
(syntax-case elems (import export)
|
|
[((import . _1) (export . _2) . _3)
|
|
(cons (reverse accum) elems)]
|
|
[((import . _1) . _2)
|
|
(raise-syntax-error
|
|
#f
|
|
"expected an `export' clause after `import'"
|
|
stx)]
|
|
[()
|
|
(raise-syntax-error
|
|
#f
|
|
"missing an `import' clause"
|
|
stx)]
|
|
[_else
|
|
(loop (cdr elems) (cons (car elems) accum))]))])
|
|
(with-syntax ((name (datum->syntax
|
|
stx
|
|
(make-name (syntax-property stx 'enclosing-module-name))
|
|
stx))
|
|
(orig-stx stx))
|
|
(datum->syntax
|
|
stx
|
|
(syntax-e
|
|
#'(#%module-begin (a-unit-module orig-stx finish-a-unit (import export)
|
|
"original import form"
|
|
name (elem ...) (literal ...))))
|
|
stx
|
|
stx)))]))
|
|
|
|
;; Process one `require' form (and make sure it's a require form):
|
|
(define-syntax (a-unit-module stx)
|
|
(syntax-case stx ()
|
|
[(_ orig-stx finish stops separator name (elem1 elem ...) (literal ...))
|
|
(let ([e (local-expand #'elem1
|
|
'module
|
|
(append
|
|
(syntax->list #'stops)
|
|
(list #'#%require)
|
|
(kernel-form-identifier-list)))])
|
|
(syntax-case e (begin #%require)
|
|
[(#%require r ...)
|
|
#'(begin
|
|
(#%require r ...)
|
|
(a-unit-module orig-stx finish stops separator name (elem ...) (literal ...)))]
|
|
[(begin b ...)
|
|
#'(a-unit-module orig-stx finish stops separator name (b ... elem ...) (literal ...))]
|
|
[_
|
|
(raise-syntax-error
|
|
#f
|
|
(format "non-require form before ~a" (syntax-e #'separator))
|
|
#'orig-stx
|
|
e)]))]
|
|
[(_ orig-stx finish stops separator name () (literal ...))
|
|
#'(finish orig-stx name literal ...)]))
|
|
|
|
;; All requires are done, so finish handling the unit:
|
|
(define-syntax (finish-a-unit stx)
|
|
(syntax-case stx (import export)
|
|
[(_ orig-stx name imports exports elem ...)
|
|
#'(begin
|
|
(provide name)
|
|
(define-unit name imports exports elem ...))]))
|