312 lines
9.8 KiB
Scheme
312 lines
9.8 KiB
Scheme
|
|
(module library-module mzscheme
|
|
(require-for-syntax "private/helpers.ss"
|
|
(lib "kerncase.ss" "syntax")
|
|
(lib "context.ss" "syntax")
|
|
(lib "boundmap.ss" "syntax")
|
|
(lib "stxparam.ss")
|
|
(lib "list.ss"))
|
|
(require (lib "stxparam.ss"))
|
|
|
|
(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])
|
|
(if (null? bodies)
|
|
(values (reverse imports)
|
|
(reverse exports)
|
|
null)
|
|
(syntax-case (car bodies) (import export)
|
|
[(import in ...)
|
|
(loop (cdr bodies)
|
|
(append (syntax->list #'(in ...)) imports)
|
|
exports)]
|
|
[(import . rest)
|
|
(raise-syntax-error #f "bad syntax" (car bodies))]
|
|
[(export out ...)
|
|
(loop (cdr bodies)
|
|
imports
|
|
(append (syntax->list #'(out ...)) exports))]
|
|
[(export . rest)
|
|
(raise-syntax-error #f "bad syntax" (car bodies))]
|
|
[else (values (reverse imports)
|
|
(reverse exports)
|
|
bodies)]))))
|
|
|
|
(define-for-syntax (make-unboxer id in-src-module-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-for-syntax (box-rhs stx)
|
|
(syntax-case stx ()
|
|
[(_ rhs) #'(box rhs)]))
|
|
|
|
(define-for-syntax (make-protected-unboxer id in-src-module-id)
|
|
(with-syntax ([id id])
|
|
(make-set!-transformer
|
|
(lambda (stx)
|
|
(unless (syntax-parameter-value in-src-module-id)
|
|
(raise-syntax-error
|
|
#f
|
|
"reference to non-exported identifier allowed only within its source library"
|
|
stx))
|
|
(syntax-case stx (set!)
|
|
[(set! _ v) #'(set! id v)]
|
|
[(_ arg ...) #'(id arg ...)]
|
|
[_ #'id])))))
|
|
|
|
(define-for-syntax (no-box-rhs stx)
|
|
(syntax-case stx ()
|
|
[(_ rhs) #'rhs]))
|
|
|
|
(define-for-syntax (check-exported-macro f ok?)
|
|
(let ([wrap (lambda (f)
|
|
(lambda (stx)
|
|
(unless (ok?)
|
|
(raise-syntax-error
|
|
#f
|
|
"reference to non-exported identifier allowed only within its source library"
|
|
stx))
|
|
(f stx)))])
|
|
(cond
|
|
[(and (procedure? f) (procedure-arity-includes? f 1))
|
|
(wrap f)]
|
|
[(set!-transformer? f)
|
|
(make-set!-transformer (wrap (set!-transformer-procedure f)))]
|
|
[else f])))
|
|
|
|
(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 bodies)
|
|
(split-bodies bodies)])
|
|
(let ([provides (map translate-export exports)])
|
|
#`(#%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)
|
|
#,@provides
|
|
(define-syntax-parameter in-src-module #f)
|
|
(begin-library-body
|
|
in-src-module
|
|
#,(apply append (map (lambda (prov)
|
|
(map (lambda (p)
|
|
(syntax-case p ()
|
|
[(_ loc ext) #'loc]
|
|
[_else p]))
|
|
(cdr (syntax->list prov))))
|
|
provides))
|
|
()
|
|
#,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 ()
|
|
[(_ in-src-module export-info ((macro-id ind-id ...) ...)
|
|
() ; no body forms left
|
|
((def-macro-id check-id) ...)
|
|
((id gen-id boxdef-id) ...))
|
|
;; We've processed the whole body, and now we need to
|
|
;; create unboxers for the defined names:
|
|
(let ([macro-ids (syntax->list #'(macro-id ...))]
|
|
[ind-idss (map syntax->list (syntax->list #'((ind-id ...) ...)))])
|
|
;; Check that each inidirect-export id was defined
|
|
(let ([t (make-bound-identifier-mapping)])
|
|
(for-each (lambda (id)
|
|
(bound-identifier-mapping-put! t id #t))
|
|
(syntax->list #'(def-macro-id ...)))
|
|
(for-each (lambda (macro-id)
|
|
(unless (bound-identifier-mapping-get t macro-id (lambda () #f))
|
|
(raise-syntax-error
|
|
#f
|
|
"id to trigger indirect exports not defined as syntax in the library"
|
|
macro-id)))
|
|
macro-ids)
|
|
(for-each (lambda (id)
|
|
(bound-identifier-mapping-put! t id #t))
|
|
(syntax->list #'(id ...)))
|
|
(for-each (lambda (id)
|
|
(unless (bound-identifier-mapping-get t id (lambda () #f))
|
|
(raise-syntax-error
|
|
#f
|
|
"indirect export not defined in the library"
|
|
id)))
|
|
(apply append ind-idss)))
|
|
;; Add each explicitly exported id to a table
|
|
(let ([t (make-bound-identifier-mapping)])
|
|
(for-each (lambda (id)
|
|
(bound-identifier-mapping-put! t id #t))
|
|
(syntax->list #'export-info))
|
|
;; Find fixpoint, adding indirect ids when the macro id is
|
|
;; exported:
|
|
(let loop ([macro-ids macro-ids]
|
|
[ind-idss ind-idss]
|
|
[next-macro-ids null]
|
|
[next-ind-idss null]
|
|
[added? #f])
|
|
(cond
|
|
[(null? macro-ids)
|
|
(when added?
|
|
(loop next-macro-ids next-ind-idss null null #f))]
|
|
[(bound-identifier-mapping-get t (car macro-ids) (lambda () #f))
|
|
(for-each (lambda (ind-id)
|
|
(bound-identifier-mapping-put! t ind-id #t))
|
|
(car ind-idss))
|
|
(loop (cdr macro-ids) (cdr ind-idss) next-macro-ids next-ind-idss #t)]
|
|
[else
|
|
(loop (cdr macro-ids) (cdr ind-idss)
|
|
(cons (car macro-ids) next-macro-ids)
|
|
(cons (car ind-idss) next-ind-idss)
|
|
added?)]))
|
|
;; For each defined id, select an unboxer:
|
|
(with-syntax ([((make-an-unboxer . box-a-def) ...)
|
|
(map (lambda (id)
|
|
(if (bound-identifier-mapping-get t id (lambda () #f))
|
|
#'(make-unboxer . box-rhs)
|
|
#'(make-protected-unboxer . no-box-rhs)))
|
|
(syntax->list #'(id ...)))])
|
|
;; For each unexported macro id, add compile-time set!:
|
|
(with-syntax ([(check-id ...)
|
|
(map cdr (filter (lambda (p)
|
|
(not (bound-identifier-mapping-get t (car p) (lambda () #f))))
|
|
(map cons
|
|
(syntax->list #'(def-macro-id ...))
|
|
(syntax->list #'(check-id ...)))))])
|
|
#'(begin
|
|
(begin-for-syntax (set! check-id #f) ...)
|
|
(define-syntaxes (boxdef-id) box-a-def) ...
|
|
(define-syntaxes (id ...)
|
|
(values (make-an-unboxer (quote-syntax gen-id) (quote-syntax in-src-module)) ...)))))))]
|
|
[(_ in-src-module export-info indirects (body0 body ...) define-macro-ids defined-ids)
|
|
;; Process one body form, body0
|
|
(let ([comdef (local-expand #'body0
|
|
'module
|
|
stops)])
|
|
(syntax-case comdef (begin define-syntaxes define-values indirect-export)
|
|
[(begin comdef ...)
|
|
#`(begin-library-body in-src-module
|
|
export-info
|
|
indirects
|
|
(comdef ... body ...)
|
|
define-macro-ids
|
|
defined-ids)]
|
|
[(define-syntaxes (id ...) rhs)
|
|
(with-syntax ([(check-id ...) (generate-temporaries #'(id ...))])
|
|
#`(begin (define-for-syntax check-id #t) ...
|
|
(define-syntaxes (id ...)
|
|
(let-values ([(id ...) rhs])
|
|
(values (check-exported-macro id (lambda () check-id)) ...)))
|
|
(begin-library-body in-src-module
|
|
export-info
|
|
indirects
|
|
(body ...)
|
|
((id check-id) ... . define-macro-ids)
|
|
defined-ids)))]
|
|
[(define-values (id ...) rhs)
|
|
(with-syntax ([(gen-id ...) (generate-temporaries #'(id ...))]
|
|
[(boxdef-id ...) (generate-temporaries #'(id ...))])
|
|
#`(begin
|
|
(define-values (gen-id ...)
|
|
(syntax-parameterize ([in-src-module #t])
|
|
(let-values ([(id ...) rhs])
|
|
(values (boxdef-id id) ...))))
|
|
(begin-library-body in-src-module
|
|
export-info
|
|
indirects
|
|
(body ...)
|
|
define-macro-ids
|
|
((id gen-id boxdef-id) ... . defined-ids))))]
|
|
[(indirect-export (macro-id id ...) ...)
|
|
(begin
|
|
(for-each (lambda (x)
|
|
(unless (identifier? x)
|
|
(raise-syntax-error
|
|
#f
|
|
"expected an identifier"
|
|
comdef
|
|
x)))
|
|
(syntax->list #'(macro-id ... id ... ...)))
|
|
#`(begin-library-body in-src-module
|
|
export-info
|
|
((macro-id id ...) ... . indirects)
|
|
(body ...)
|
|
define-macro-ids
|
|
defined-ids))]
|
|
[(indirect-export . _)
|
|
(raise-syntax-error
|
|
#f
|
|
"bad syntax"
|
|
comdef)]
|
|
[expr
|
|
;; syntax-parameterize forces an expression (not defn):
|
|
#`(begin
|
|
(syntax-parameterize ([in-src-module #t])
|
|
expr)
|
|
(begin-library-body in-src-module
|
|
export-info
|
|
indirects
|
|
(body ...)
|
|
define-macro-ids
|
|
defined-ids))]))])))
|