r6rs library form improvements
svn: r468
This commit is contained in:
Matthew Flatt
parent
266e6c75cd
commit
d3056a39f3
|
|
@ -43,12 +43,6 @@ Limitations:
|
|||
- doesn't enforce that a for-run import isn't also
|
||||
a for-expand import in a different import-spec
|
||||
|
||||
- doesn't enforce that idenfiers in a macro expansion
|
||||
are only the ones declared by indirect-export
|
||||
|
||||
- doesn't check that an identifiers in an indirect-export
|
||||
declaration are actually defined
|
||||
|
||||
- reader adjusts only string, character, and quoted-symbol
|
||||
syntax (as in SRFI-75), for now
|
||||
|
||||
|
|
|
|||
|
|
@ -2,7 +2,11 @@
|
|||
(module library-module mzscheme
|
||||
(require-for-syntax "private/helpers.ss"
|
||||
(lib "kerncase.ss" "syntax")
|
||||
(lib "context.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)
|
||||
|
|
@ -33,41 +37,29 @@
|
|||
(define-for-syntax (split-bodies bodies)
|
||||
(let loop ([bodies bodies]
|
||||
[imports null]
|
||||
[exports null]
|
||||
[indirect-exports null])
|
||||
[exports null])
|
||||
(if (null? bodies)
|
||||
(values (reverse imports)
|
||||
(reverse exports)
|
||||
(reverse indirect-exports)
|
||||
null)
|
||||
(syntax-case (car bodies) (import export indirect-export)
|
||||
(syntax-case (car bodies) (import export)
|
||||
[(import in ...)
|
||||
(loop (cdr bodies)
|
||||
(append (syntax->list #'(in ...)) imports)
|
||||
exports
|
||||
indirect-exports)]
|
||||
exports)]
|
||||
[(import . rest)
|
||||
(raise-syntax-error #f "bad syntax" (car bodies))]
|
||||
[(export out ...)
|
||||
(loop (cdr bodies)
|
||||
imports
|
||||
(append (syntax->list #'(out ...)) exports)
|
||||
indirect-exports)]
|
||||
(append (syntax->list #'(out ...)) 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)
|
||||
(define-for-syntax (make-unboxer id in-src-module-id)
|
||||
(with-syntax ([id id])
|
||||
(make-set!-transformer
|
||||
(lambda (stx)
|
||||
|
|
@ -76,6 +68,44 @@
|
|||
[(_ 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 ...))
|
||||
|
|
@ -95,18 +125,30 @@
|
|||
stx
|
||||
#'lang))
|
||||
(let ([bodies (syntax->list #'(body ...))])
|
||||
(let-values ([(imports exports indirect-exports bodies)
|
||||
(let-values ([(imports 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)))))]
|
||||
(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
|
||||
|
|
@ -121,29 +163,149 @@
|
|||
|
||||
(define-syntax (begin-library-body stx)
|
||||
(syntax-case stx ()
|
||||
[(_ indirects ())
|
||||
#'(begin)]
|
||||
[(_ indirects (body0 body ...))
|
||||
[(_ 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)
|
||||
(syntax-case comdef (begin define-syntaxes define-values indirect-export)
|
||||
[(begin comdef ...)
|
||||
#`(begin-library-body indirects (comdef ... body ...))]
|
||||
#`(begin-library-body in-src-module
|
||||
export-info
|
||||
indirects
|
||||
(comdef ... body ...)
|
||||
define-macro-ids
|
||||
defined-ids)]
|
||||
[(define-syntaxes (id ...) rhs)
|
||||
#`(begin (define-syntaxes (id ...) rhs)
|
||||
(begin-library-body indirects (body ...)))]
|
||||
(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 ...))])
|
||||
(with-syntax ([(gen-id ...) (generate-temporaries #'(id ...))]
|
||||
[(boxdef-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 ...))))]
|
||||
(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
|
||||
;; begin0 forces an expression (not defn):
|
||||
;; syntax-parameterize forces an expression (not defn):
|
||||
#`(begin
|
||||
(begin0 expr)
|
||||
(begin-library-body indirects (body ...)))]))])))
|
||||
(syntax-parameterize ([in-src-module #t])
|
||||
expr)
|
||||
(begin-library-body in-src-module
|
||||
export-info
|
||||
indirects
|
||||
(body ...)
|
||||
define-macro-ids
|
||||
defined-ids))]))])))
|
||||
|
|
|
|||
|
|
@ -45,11 +45,11 @@
|
|||
[(bound-identifier=? id (caar renames)) (cdar renames)]
|
||||
[else (locate-rename id (cdr renames))]))
|
||||
|
||||
(define (apply-rename new-names old-names name-pairs)
|
||||
(define (apply-rename new-names old-names name-pairs rcons)
|
||||
(map (lambda (i)
|
||||
(or (ormap (lambda (new old)
|
||||
(and (bound-identifier=? (car i) new)
|
||||
(cons old (cdr i))))
|
||||
(rcons old (cdr i))))
|
||||
new-names old-names)
|
||||
i))
|
||||
name-pairs))
|
||||
|
|
@ -153,51 +153,52 @@
|
|||
(translate-impexp
|
||||
i orig-i
|
||||
(lambda (i exceptions onlys renames extra-prefix)
|
||||
(syntax-case* i (all-defined) (lambda (a b) (eq? (syntax-e a) (syntax-e b)))
|
||||
[(all-defined)
|
||||
(cond
|
||||
[onlys
|
||||
#`(provide #,@(map (lambda (name-pair)
|
||||
#`(rename #,(car name-pair) #,(cdr name-pair)))
|
||||
onlys))]
|
||||
[(or exceptions (pair? renames))
|
||||
;; First import non-renamed, then renamed:
|
||||
#`(provide (#,(if extra-prefix #'prefix-all-defined-except #'all-defined-except)
|
||||
#,@(if extra-prefix (list extra-prefix) null)
|
||||
#,@(append (map car (or exceptions null))
|
||||
(map car renames)))
|
||||
#,@(map (lambda (i)
|
||||
#`(rename #,(car i) #,(cdr i)))
|
||||
renames))]
|
||||
[extra-prefix
|
||||
#`(provide (prefix-all-defined #,extra-prefix))]
|
||||
[else
|
||||
#`(provide (all-defined))])]
|
||||
[(all-defined . _)
|
||||
(raise-syntax-error #f "bad syntax" i)]
|
||||
(define (result l)
|
||||
(when exceptions
|
||||
(check-present orig-i "except not" "identifier" values exceptions l))
|
||||
(when onlys
|
||||
(check-present orig-i "only not" "identifier" values onlys l))
|
||||
(when renames
|
||||
(check-present orig-i "rename not" "identifier" values renames l))
|
||||
(let* ([l (if exceptions
|
||||
(filter (lambda (i)
|
||||
(not (ormap (lambda (x) (bound-identifier=? (car x) i))
|
||||
exceptions)))
|
||||
l)
|
||||
l)]
|
||||
[name-pairs (if onlys
|
||||
onlys
|
||||
(apply-rename (map car renames) (map cdr renames)
|
||||
(map cons l
|
||||
(map (lambda (i) (add-prefix extra-prefix i)) l))
|
||||
(lambda (b a) (cons a b))))])
|
||||
(if (andmap (lambda (p) (eq? (car p) (cdr p)))
|
||||
name-pairs)
|
||||
#`(provide #,@(map car name-pairs))
|
||||
#`(provide #,@(map (lambda (p)
|
||||
#`(rename #,(car p) #,(cdr p)))
|
||||
name-pairs)))))
|
||||
(syntax-case* i (set) (lambda (a b) (eq? (syntax-e a) (syntax-e b)))
|
||||
[(set id ...)
|
||||
(let ([ids (syntax->list #'(id ...))])
|
||||
(for-each (lambda (x)
|
||||
(unless (identifier? x)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"expected an identifier"
|
||||
i
|
||||
x)))
|
||||
ids)
|
||||
(result ids))]
|
||||
[_else
|
||||
(begin
|
||||
(unless (identifier? i)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"expected an identifier or an `all-defined', `only', `except', `add-prefix', or `rename' form"
|
||||
"expected an identifier or a `set', `only', `except', `add-prefix', or `rename' form"
|
||||
orig-i
|
||||
i))
|
||||
(when exceptions
|
||||
(check-present orig-i "except not" "identifier" values exceptions (list i)))
|
||||
(when onlys
|
||||
(check-present orig-i "only not" "identifier" values onlys (list i)))
|
||||
(when renames
|
||||
(check-present orig-i "rename not" "identifier" values renames (list i)))
|
||||
(cond
|
||||
[(pair? exceptions)
|
||||
;; Must be the only exception, so nothing is exported
|
||||
#'(provide)]
|
||||
[(pair? renames)
|
||||
#`(provide (rename #,(caar renames) #,(cdar renames)))]
|
||||
[extra-prefix
|
||||
#`(provide (rename #,i #,(add-prefix extra-prefix i)))]
|
||||
[else #`(provide #,i)]))]))))
|
||||
(result (list i)))]))))
|
||||
|
||||
(define (translate-impexp i orig-i k)
|
||||
(let loop ([i i]
|
||||
|
|
@ -290,7 +291,7 @@
|
|||
(check-unique-names orig-i "`rename' source" old-names)
|
||||
(let ([combine-renames
|
||||
(lambda ()
|
||||
(let ([renames (apply-rename new-names old-names renames)])
|
||||
(let ([renames (apply-rename new-names old-names renames cons)])
|
||||
(append
|
||||
renames
|
||||
(remove* renames name-pairs
|
||||
|
|
@ -299,14 +300,14 @@
|
|||
(cond
|
||||
[exceptions
|
||||
(loop #'sub
|
||||
(apply-rename new-names old-names exceptions)
|
||||
(apply-rename new-names old-names exceptions cons)
|
||||
#f
|
||||
(combine-renames)
|
||||
extra-prefix)]
|
||||
[onlys
|
||||
(loop #'sub
|
||||
#f
|
||||
(apply-rename new-names old-names onlys)
|
||||
(apply-rename new-names old-names onlys cons)
|
||||
null
|
||||
#f)]
|
||||
[else
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user