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

allow macros to expand to require in a-unit.ss

Browse Source 
svn: r5055
This commit is contained in:
Matthew Flatt 2006-12-07 03:04:19 +00:00
parent c64028a057
commit 4f75452dbd
1 changed files with 76 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

91
collects/mzlib/a-unit.ss
View File

@ -1,7 +1,6 @@
(module a-unit mzscheme
(require-for-syntax "private/unit-compiletime.ss"
"private/unit-syntax.ss")
(require "unit.ss")
(require-for-syntax (lib "kerncase.ss" "syntax"))
(provide (rename module-begin #%module-begin)
(all-from-except mzscheme #%module-begin)
@ -12,17 +11,79 @@
(string-append (regexp-replace "-unit$" (symbol->string s) "")
"@")))
;; Look for `import' and `export', and start processing the body:
(define-syntax (module-begin stx)
(parameterize ((error-syntax stx))
(with-syntax ((name (make-name (syntax-property stx 'enclosing-module-name))))
(syntax-case stx ()
((_ . x)
(with-syntax ((((reqs ...) . (body ...))
(split-requires (checked-syntax->list #'x))))
(datum->syntax-object
stx
(syntax-e #'(#%module-begin
reqs ...
(provide name)
(define-unit name body ...)))
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 #'here))))])
(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 ...))])))