diff --git a/collects/r6rs/doc.txt b/collects/r6rs/doc.txt index 14617fe81b..107480c7e2 100644 --- a/collects/r6rs/doc.txt +++ b/collects/r6rs/doc.txt @@ -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 diff --git a/collects/r6rs/library-module.ss b/collects/r6rs/library-module.ss index 470e0203ce..c7fdbdd17e 100644 --- a/collects/r6rs/library-module.ss +++ b/collects/r6rs/library-module.ss @@ -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))]))]))) diff --git a/collects/r6rs/private/helpers.ss b/collects/r6rs/private/helpers.ss index f454b956ed..a5b2a90b97 100644 --- a/collects/r6rs/private/helpers.ss +++ b/collects/r6rs/private/helpers.ss @@ -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