90 lines
3.6 KiB
Racket
90 lines
3.6 KiB
Racket
(module a-unit mzscheme
|
|
(require "unit.rkt")
|
|
(require-for-syntax syntax/kerncase)
|
|
|
|
(provide (rename module-begin #%module-begin)
|
|
(all-from-except mzscheme #%module-begin)
|
|
(all-from "unit.rkt"))
|
|
|
|
(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-object
|
|
stx
|
|
(make-name (syntax-property stx 'enclosing-module-name))
|
|
stx))
|
|
(orig-stx stx))
|
|
(datum->syntax-object
|
|
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
|
|
#'require-for-syntax
|
|
#'require-for-template
|
|
(kernel-form-identifier-list))))])
|
|
(syntax-case e (begin)
|
|
[(req r ...)
|
|
(or (module-identifier=? #'req #'require)
|
|
(module-identifier=? #'req #'require-for-syntax)
|
|
(module-identifier=? #'req #'require-for-template))
|
|
#'(begin
|
|
(req 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 ...))]
|
|
[_else
|
|
(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 ...))])))
|
|
|