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

r6rs library form improvements

Browse Source 
svn: r468
This commit is contained in:
Matthew Flatt 2005-07-27 18:50:30 +00:00
parent 266e6c75cd
commit d3056a39f3
3 changed files with 251 additions and 94 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
collects/r6rs/doc.txt
View File

@ -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

236
collects/r6rs/library-module.ss
View File

@ -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)])
(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)
#,@(map translate-export exports)
#,@provides
(define-syntax-parameter in-src-module #f)
(begin-library-body
#,indirect-exports
#,bodies)))))]
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 ...)
(syntax-parameterize ([in-src-module #t])
(let-values ([(id ...) rhs])
(values (box id) ...)))
(define-syntaxes (id ...)
(values (make-unboxer (quote-syntax gen-id)) ...))
(begin-library-body indirects (body ...))))]
(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))]))])))

87
collects/r6rs/private/helpers.ss
View File

@ -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