150 lines
4.4 KiB
Scheme
150 lines
4.4 KiB
Scheme
|
|
(module library-module mzscheme
|
|
(require-for-syntax "private/helpers.ss"
|
|
(lib "kerncase.ss" "syntax")
|
|
(lib "context.ss" "syntax"))
|
|
|
|
(provide (rename library-module-begin #%module-begin)
|
|
import)
|
|
|
|
(define-syntax define-impdef-placeholder
|
|
(syntax-rules ()
|
|
[(_ id) (begin
|
|
(define-syntax (id stx)
|
|
(raise-syntax-error
|
|
#f
|
|
"only allowed at the beginning of a `library' form"
|
|
stx))
|
|
(provide id))]))
|
|
|
|
(define-impdef-placeholder export)
|
|
(define-impdef-placeholder indirect-export)
|
|
|
|
(define-syntax (import stx)
|
|
(unless (eq? (syntax-local-context) 'top-level)
|
|
(raise-syntax-error
|
|
#f
|
|
"only allowed at the beginning of a `library' form or outside a library at the top level"
|
|
stx))
|
|
(syntax-case stx ()
|
|
[(_ i ...)
|
|
#`(begin #,@(map translate-import (syntax->list #'(i ...))))]))
|
|
|
|
(define-for-syntax (split-bodies bodies)
|
|
(let loop ([bodies bodies]
|
|
[imports null]
|
|
[exports null]
|
|
[indirect-exports null])
|
|
(if (null? bodies)
|
|
(values (reverse imports)
|
|
(reverse exports)
|
|
(reverse indirect-exports)
|
|
null)
|
|
(syntax-case (car bodies) (import export indirect-export)
|
|
[(import in ...)
|
|
(loop (cdr bodies)
|
|
(append (syntax->list #'(in ...)) imports)
|
|
exports
|
|
indirect-exports)]
|
|
[(import . rest)
|
|
(raise-syntax-error #f "bad syntax" (car bodies))]
|
|
[(export out ...)
|
|
(loop (cdr bodies)
|
|
imports
|
|
(append (syntax->list #'(out ...)) exports)
|
|
indirect-exports)]
|
|
[(export . rest)
|
|
(raise-syntax-error #f "bad syntax" (car bodies))]
|
|
[(indirect-export indirect ...)
|
|
(loop (cdr bodies)
|
|
imports
|
|
exports
|
|
(append (syntax->list #'(indirect ...)) indirect-exports))]
|
|
[(indirect-export . rest)
|
|
(raise-syntax-error #f "bad syntax" (car bodies))]
|
|
[else (values (reverse imports)
|
|
(reverse exports)
|
|
(reverse indirect-exports)
|
|
bodies)]))))
|
|
|
|
(define-for-syntax (make-unboxer id)
|
|
(with-syntax ([id id])
|
|
(make-set!-transformer
|
|
(lambda (stx)
|
|
(syntax-case stx (set!)
|
|
[(set! _ v) #'(set-box! id v)]
|
|
[(_ arg ...) #'((unbox id) arg ...)]
|
|
[_ #'(unbox id)])))))
|
|
|
|
(define-syntax (library-module-begin stx)
|
|
(syntax-case stx ()
|
|
[(_ (__ name lang body ...))
|
|
(let ([stx (syntax-case stx () [(_ o) #'o])])
|
|
(unless (and (string? (syntax-e #'name))
|
|
(uri? (syntax-e #'name)))
|
|
(raise-syntax-error
|
|
#f
|
|
"library name must be a URI"
|
|
stx
|
|
#'name))
|
|
(unless (and (string? (syntax-e #'lang))
|
|
(string=? "scheme://r6rs" (syntax-e #'lang)))
|
|
(raise-syntax-error
|
|
#f
|
|
"language position must be \"scheme://r6rs\""
|
|
stx
|
|
#'lang))
|
|
(let ([bodies (syntax->list #'(body ...))])
|
|
(let-values ([(imports exports indirect-exports bodies)
|
|
(split-bodies bodies)])
|
|
#`(#%plain-module-begin
|
|
(require #,(datum->syntax-object stx '(all-except (lib "r6rs.ss" "r6rs")
|
|
#%module-begin)))
|
|
(require-for-syntax #,(datum->syntax-object stx '(lib "r6rs.ss" "r6rs")))
|
|
(require #,(datum->syntax-object stx '(lib "library-module.ss" "r6rs")))
|
|
#,@(map translate-import imports)
|
|
#,@(map translate-export exports)
|
|
(begin-library-body
|
|
#,indirect-exports
|
|
#,bodies)))))]
|
|
[(_ x)
|
|
(raise-syntax-error
|
|
#f
|
|
"bad syntax"
|
|
#'x)]))
|
|
|
|
(define-for-syntax stops (list*
|
|
#'import
|
|
#'export
|
|
#'indirect-export
|
|
(kernel-form-identifier-list #'here)))
|
|
|
|
(define-syntax (begin-library-body stx)
|
|
(syntax-case stx ()
|
|
[(_ indirects ())
|
|
#'(begin)]
|
|
[(_ indirects (body0 body ...))
|
|
(let ([comdef (local-expand #'body0
|
|
'module
|
|
stops)])
|
|
(syntax-case comdef (begin define-syntaxes define-values)
|
|
[(begin comdef ...)
|
|
#`(begin-library-body indirects (comdef ... body ...))]
|
|
[(define-syntaxes (id ...) rhs)
|
|
#`(begin (define-syntaxes (id ...) rhs)
|
|
(begin-library-body indirects (body ...)))]
|
|
[(define-values (id ...) rhs)
|
|
(with-syntax ([(gen-id ...) (generate-temporaries #'(id ...))])
|
|
#`(begin
|
|
(define-values (gen-id ...)
|
|
(let-values ([(id ...) rhs])
|
|
(values (box id) ...)))
|
|
(define-syntaxes (id ...)
|
|
(values (make-unboxer (quote-syntax gen-id)) ...))
|
|
(begin-library-body indirects (body ...))))]
|
|
[expr
|
|
;; begin0 forces an expression (not defn):
|
|
#`(begin
|
|
(begin0 expr)
|
|
(begin-library-body indirects (body ...)))]))])))
|