From 9d27b21f914eac42ec248409223c948b3e5d4d6f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 24 Sep 2011 11:01:03 +0900 Subject: [PATCH] add provide pre-transformers --- collects/racket/private/reqprov.rkt | 205 +++++++++++------- collects/racket/provide-transform.rkt | 42 +++- .../scribblings/reference/stx-trans.scrbl | 106 ++++++--- collects/scribblings/reference/syntax.scrbl | 7 +- 4 files changed, 250 insertions(+), 110 deletions(-) diff --git a/collects/racket/private/reqprov.rkt b/collects/racket/private/reqprov.rkt index 03a6eee8f2..5891f9a715 100644 --- a/collects/racket/private/reqprov.rkt +++ b/collects/racket/private/reqprov.rkt @@ -127,14 +127,15 @@ (import-source-mode source)))) sources)))])) - (define-for-syntax (make-require+provide-transformer r p) + (define-for-syntax (make-require+provide-transformer r p pp) (let-values ([(s: mk s? s-ref s-set!) (make-struct-type 'req+prov #f 0 0 #f (list (cons prop:require-transformer (lambda (a) r)) - (cons prop:provide-transformer (lambda (a) p))))]) + (cons prop:provide-transformer (lambda (a) p)) + (cons prop:provide-pre-transformer (lambda (a) pp))))]) (mk))) (define-for-syntax (exports-at-phase stx modes mode) @@ -155,48 +156,65 @@ (lambda (stx) (shift-subs stx 1)) (lambda (stx modes) - (exports-at-phase stx modes 1)))) + (exports-at-phase stx modes 1)) + (lambda (stx modes) + (recur-pre stx (if (null? modes) '(1) (map add1 modes)))))) (define-syntax for-template (make-require+provide-transformer (lambda (stx) (shift-subs stx -1)) (lambda (stx modes) - (exports-at-phase stx modes -1)))) + (exports-at-phase stx modes -1)) + (lambda (stx modes) + (recur-pre stx (if (null? modes) '(-1) (map sub1 modes)))))) (define-syntax for-label (make-require+provide-transformer (lambda (stx) (shift-subs stx #f)) (lambda (stx modes) - (exports-at-phase stx modes #f)))) - - (define-syntax for-meta - (make-require+provide-transformer - (lambda (stx) - (syntax-case stx () - [(_ mode in ...) - (let ([base-mode (syntax-e #'mode)]) - (unless (or (not base-mode) - (exact-integer? base-mode)) - (raise-syntax-error - #f - "phase level must be #f or an exact integer" - stx - #'mode)) - (shift-subs #'(for-meta in ...) base-mode))])) + (exports-at-phase stx modes #f)) (lambda (stx modes) - (syntax-case stx () - [(_ mode out ...) - (let ([base-mode (syntax-e #'mode)]) - (unless (or (not base-mode) - (exact-integer? base-mode)) - (raise-syntax-error - #f - "phase level must be #f or an exact integer" - stx - #'mode)) - (exports-at-phase #'(for-meta out ...) modes base-mode))])))) + (recur-pre stx '(#f))))) + + (define-syntax for-meta + (let ([extract-phase + (lambda (stx mode) + (let ([base-mode (syntax-e mode)]) + (unless (or (not base-mode) + (exact-integer? base-mode)) + (raise-syntax-error + #f + "phase level must be #f or an exact integer" + stx + mode)) + base-mode))]) + (make-require+provide-transformer + (lambda (stx) + (syntax-case stx () + [(_ mode in ...) + (let ([base-mode (extract-phase stx #'mode)]) + (shift-subs #'(for-meta in ...) base-mode))])) + (lambda (stx modes) + (syntax-case stx () + [(_ mode out ...) + (let ([base-mode (extract-phase stx #'mode)]) + (exports-at-phase #'(for-meta out ...) modes base-mode))])) + (lambda (stx modes) + (syntax-case stx () + [(_ mode out ...) + (let* ([base-mode (extract-phase stx #'mode)] + [modes (if (null? modes) + (list base-mode) + (if (null? base-mode) + (list base-mode) + (map (lambda (v) (+ v base-mode)) modes)))]) + (with-syntax ([(out ...) (map (lambda (o) + (pre-expand-export o modes)) + (syntax->list #'(out ...)))]) + (syntax/loc stx + (for-meta mode out ...))))]))))) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; require @@ -591,12 +609,15 @@ (syntax-case stx () [(_ out ...) - (syntax-property - (quasisyntax/loc stx - (#%provide #,(syntax-property - #`(expand (provide-trampoline out ...)) - 'certify-mode 'transparent))) - 'certify-mode 'transparent)])) + (with-syntax ([(out ...) + (map (lambda (o) (pre-expand-export o null)) + (syntax->list #'(out ...)))]) + (syntax-property + (quasisyntax/loc stx + (#%provide #,(syntax-property + #`(expand (provide-trampoline out ...)) + 'certify-mode 'transparent))) + 'certify-mode 'transparent))])) (define-syntax (provide-trampoline stx) (syntax-case stx () @@ -631,6 +652,15 @@ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; provide transformers + (define-for-syntax (recur-pre stx modes) + (syntax-case stx () + [(fm out ...) + (with-syntax ([(out ...) (map (lambda (o) + (pre-expand-export o modes)) + (syntax->list #'(out ...)))]) + (syntax/loc stx + (fm out ...)))])) + (define-syntax all-defined-out (make-provide-transformer (lambda (stx modes) @@ -743,24 +773,25 @@ (apply append (map (lambda (mode) - (map (lambda (orig-id bind-id) - (unless (list? (identifier-binding orig-id mode)) - (raise-syntax-error - #f - (format "no binding~a for identifier" - (cond - [(eq? mode 0) ""] - [(not mode) " in the label phase level"] - [(not mode) (format " at phase level ~a" mode)] - [else ""])) - stx - orig-id)) - (make-export orig-id - (syntax-e bind-id) - mode - #f - bind-id)) - orig-ids bind-ids)) + (let ([abs-mode (and mode (+ mode (syntax-local-phase-level)))]) + (map (lambda (orig-id bind-id) + (unless (list? (identifier-binding orig-id abs-mode)) + (raise-syntax-error + #f + (format "no binding~a for identifier" + (cond + [(eq? mode 0) ""] + [(not mode) " in the label phase level"] + [(not mode) (format " at phase level ~a" mode)] + [else ""])) + stx + orig-id)) + (make-export orig-id + (syntax-e bind-id) + mode + #f + bind-id)) + orig-ids bind-ids))) (if (null? modes) '(0) modes))))])))) @@ -799,7 +830,9 @@ (export-local-id export) (export-mode export)))) exceptions))) - exports))])))) + exports))])) + (lambda (stx modes) + (recur-pre stx modes)))) (define-for-syntax (build-name id . parts) (datum->syntax @@ -925,7 +958,9 @@ append (map (lambda (out) (expand-export out modes)) - (syntax->list #'(out ...))))])))) + (syntax->list #'(out ...))))])) + (lambda (stx modes) + (recur-pre stx modes)))) (define-syntax protect-out (make-provide-transformer @@ -944,30 +979,42 @@ (export-mode e) #t (export-orig-stx e))) - exports))])))) + exports))])) + (lambda (stx modes) + (recur-pre stx modes)))) (define-syntax prefix-out - (make-provide-transformer - (lambda (stx modes) - (syntax-case stx () - [(_ pfx out) - (let ([exports (expand-export #'out modes)]) - (unless (identifier? #'pfx) - (raise-syntax-error - #f - "expected an for prefix, found something else" - stx - #'pfx)) - (map (lambda (e) - (make-export - (export-local-id e) - (string->symbol (format "~s~s" - (syntax-e #'pfx) - (export-out-sym e))) - (export-mode e) - (export-protect? e) - (export-orig-stx e))) - exports))])))) + (let ([check-prefix + (lambda (stx pfx) + (unless (identifier? pfx) + (raise-syntax-error + #f + "expected an for prefix, found something else" + stx + pfx)))]) + (make-provide-transformer + (lambda (stx modes) + (syntax-case stx () + [(_ pfx out) + (check-prefix stx #'pfx) + (let ([exports (expand-export #'out modes)]) + (map (lambda (e) + (make-export + (export-local-id e) + (string->symbol (format "~s~s" + (syntax-e #'pfx) + (export-out-sym e))) + (export-mode e) + (export-protect? e) + (export-orig-stx e))) + exports))])) + (lambda (stx modes) + (syntax-case stx () + [(_ pfx out) + (check-prefix stx #'pfx) + (with-syntax ([out (pre-expand-export #'out modes)]) + (syntax/loc stx (prefix-out pfx out)))]))))) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/collects/racket/provide-transform.rkt b/collects/racket/provide-transform.rkt index 6a600d9d08..0f639aab07 100644 --- a/collects/racket/provide-transform.rkt +++ b/collects/racket/provide-transform.rkt @@ -7,9 +7,10 @@ "private/small-scheme.rkt" "private/define.rkt") - (#%provide expand-export + (#%provide expand-export pre-expand-export syntax-local-provide-certifier make-provide-transformer prop:provide-transformer provide-transformer? + make-provide-pre-transformer prop:provide-pre-transformer provide-pre-transformer? ;; the export struct type: export struct:export make-export export? export-local-id export-out-sym export-orig-stx export-protect? export-mode) @@ -27,14 +28,30 @@ (raise-type-error 'make-export "syntax" stx)) (values i s mode (and protect? #t) stx))) + (define-values (prop:provide-pre-transformer provide-pre-transformer? provide-pre-transformer-get-proc) + (make-struct-type-property 'provide-pre-transformer)) + (define-values (prop:provide-transformer provide-transformer? provide-transformer-get-proc) (make-struct-type-property 'provide-transformer)) (define-struct* pt (proc) #:property prop:provide-transformer (lambda (t) (pt-proc t))) + (define-struct* p+t (pre-proc proc) + #:property prop:provide-transformer (lambda (t) (p+t-proc t)) + #:property prop:provide-pre-transformer (lambda (t) (p+t-pre-proc t))) - (define (make-provide-transformer proc) - (make-pt proc)) + (define make-provide-transformer + (case-lambda + [(proc) + (make-pt proc)] + [(proc pre-proc) + (make-p+t pre-proc proc)])) + + (define-struct* ppt (proc) + #:property prop:provide-pre-transformer (lambda (t) (ppt-proc t))) + + (define (make-provide-pre-transformer proc) + (make-ppt proc)) ;; For backward compatibility: (define (syntax-local-provide-certifier) @@ -45,6 +62,25 @@ (define orig-insp (variable-reference->module-declaration-inspector (#%variable-reference))) + (define (pre-expand-export stx modes) + (if (identifier? stx) + stx + (let ([disarmed-stx (syntax-disarm stx orig-insp)]) + (syntax-case disarmed-stx () + [(id . rest) + (identifier? #'id) + (let ([t (syntax-local-value #'id (lambda () #f))]) + (if (provide-pre-transformer? t) + (let ([v (((provide-pre-transformer-get-proc t) t) disarmed-stx modes)]) + (unless (syntax? v) + (raise-syntax-error + #f + "result from provide pre-transformer is not a list of exports" + stx)) + v) + stx))] + [_ stx])))) + ;; expand-export : stx -> (listof export) (define (expand-export stx modes) (if (identifier? stx) diff --git a/collects/scribblings/reference/stx-trans.scrbl b/collects/scribblings/reference/stx-trans.scrbl index f50279d7f9..b64332c6f2 100644 --- a/collects/scribblings/reference/stx-trans.scrbl +++ b/collects/scribblings/reference/stx-trans.scrbl @@ -814,9 +814,10 @@ The @racket[liberal-define-context?] predicate returns @racket[#t] if A @tech{transformer binding} whose value is a structure with the @racket[prop:require-transformer] property implements a derived -@racket[_require-spec] for @racket[require]. +@racket[_require-spec] for @racket[require] as a @deftech{require +transformer}. -The transformer is called with the syntax object representing its use +A @tech{require transformer} is called with the syntax object representing its use as a @racket[_require-spec] within a @racket[require] form, and the result must be two lists: a list of @racket[import]s and a list of @racket[import-source]s. @@ -847,14 +848,13 @@ former list).} (listof import-source?)))]) require-transformer?]{ -Creates a @deftech{require transformer} (i.e., a structure with the -@racket[prop:require-transformer] property) using the given procedure -as the transformer.} +Creates a @tech{require transformer} using the given procedure as the +transformer.} @defthing[prop:require-transformer struct-type-property?]{ -A property to identify @racket[require] transformers. The property +A property to identify @tech{require transformers}. The property value must be a procedure that takes a syntax object and returns import and import-source lists.} @@ -935,20 +935,41 @@ first argument.} A @tech{transformer binding} whose value is a structure with the @racket[prop:provide-transformer] property implements a derived -@racket[_provide-spec] for @racket[provide]. +@racket[_provide-spec] for @racket[provide] as a @deftech{provide transformer}. +A @tech{provide transformer} is applied as part of the last phase of +a module's expansion, after all other declarations and expressions within +the module are expanded. -The transformer is called with the syntax object representing its use -as a @racket[_provide-spec] within a @racket[provide] form and a list -of symbols representing the export modes specified by enclosing -@racket[_provide-spec]s. The result must be a list of -@racket[export]s. +A @tech{transformer binding} whose value is a structure with the +@racket[prop:provide-pre-transformer] property implements a derived +@racket[_provide-spec] for @racket[provide] as a @deftech{provide +pre-transformer}. A @tech{provide pre-transformer} is applied as part +of the first phase of a module's expansion. Since it is used in the +first phase, a @tech{provide pre-transformer} can use functions such +as @racket[syntax-local-lift-expression] to introduce expressions and +definitions in the enclosing module. -If the derived form contains a sub-form that is a -@racket[_provide-spec], then it can call @racket[expand-export] to -transform the sub-@racket[_provide-spec] to a list of exports. +An identifier can have a @tech{transformer binding} to a value that +acts both as a @tech{provide transformer} and @tech{provide +pre-transformer}. The result of a @tech{provide +pre-transformer} is @emph{not} automatically re-expanded, so a +@tech{provide pre-transformer} can usefully expand to itself in that case. + +A transformer is called with the syntax object representing its use as +a @racket[_provide-spec] within a @racket[provide] form and a list of +symbols representing the export modes specified by enclosing +@racket[_provide-spec]s. The result of a @tech{provide transformer} +must be a list of @racket[export]s, while the result of a +@tech{provide pre-transformer} is a syntax object to be used as a +@racket[_provide-spec] in the last phase of module expansion. + +If a derived form contains a sub-form that is a +@racket[_provide-spec], then it can call @racket[expand-export] or +@racket[pre-expand-export] to transform the sub-@racket[_provide-spec] +sub-form. See also @racket[define-provide-syntax], which supports macro-style -@racket[provide] transformers. +@tech{provide transformers}. @defproc[(expand-export [stx syntax?] [modes (listof (or/c exact-integer? #f))]) @@ -957,33 +978,68 @@ See also @racket[define-provide-syntax], which supports macro-style Expands the given @racket[_provide-spec] to a list of exports. The @racket[modes] list controls the expansion of sub-@racket[_provide-specs]; for example, an identifier refers to a -@tech{phase level} 0 binding unless the @racket[modes] list specifies -otherwise. Normally, @racket[modes] is either empty or contains a -single element.} +binding in the @tech{phase level} of the enclosing @racket[provide] +form, unless the @racket[modes] list specifies otherwise. Normally, +@racket[modes] is either empty or contains a single element.} -@defproc[(make-provide-transformer [proc (syntax? (listof (or/c exact-integer? #f)) - . -> . (listof export?))]) - provide-transformer?]{ +@defproc[(pre-expand-export [stx syntax?] [modes (listof (or/c exact-integer? #f))]) + syntax?]{ -Creates a @deftech{provide transformer} (i.e., a structure with the +Expands the given @racket[_provide-spec] at the level of @tech{provide +pre-transformers}. The @racket[modes] argument is the same as for +@racket[expand-export].} + + +@defproc*[([(make-provide-transformer [proc (syntax? (listof (or/c exact-integer? #f)) + . -> . (listof export?))]) + provide-transformer?] + [(make-provide-transformer [proc (syntax? (listof (or/c exact-integer? #f)) + . -> . (listof export?))] + [pre-proc (syntax? (listof (or/c exact-integer? #f)) + . -> . syntax?)]) + (and/c provide-transformer? provide-pre-transformer?)])]{ + +Creates a @tech{provide transformer} (i.e., a structure with the @racket[prop:provide-transformer] property) using the given procedure -as the transformer.} +as the transformer. If a @racket[pre-proc] is provided, then the result is also a +@tech{provide pre-transformer}.} + + +@defproc[(make-provide-pre-transformer [pre-proc (syntax? (listof (or/c exact-integer? #f)) + . -> . syntax?)]) + provide-pre-transformer?]{ + +Like @racket[make-provide-transformer], but for a value that is a +@tech{provide pre-transformer}, only.} @defthing[prop:provide-transformer struct-type-property?]{ -A property to identify @racket[provide] transformers. The property +A property to identify @tech{provide transformers}. The property value must be a procedure that takes a syntax object and mode list and returns an export list.} +@defthing[prop:provide-pre-transformer struct-type-property?]{ + +A property to identify @tech{provide pre-transformers}. The property +value must be a procedure that takes a syntax object and mode list and +returns a syntax object.} + + @defproc[(provide-transformer? [v any/c]) boolean?]{ Returns @racket[#t] if @racket[v] has the @racket[prop:provide-transformer] property, @racket[#f] otherwise.} +@defproc[(provide-pre-transformer? [v any/c]) boolean?]{ + +Returns @racket[#t] if @racket[v] has the +@racket[prop:provide-pre-transformer] property, @racket[#f] otherwise.} + + @defstruct[export ([local-id identifier?] [out-sym symbol?] [mode (or/c exact-integer? #f)] diff --git a/collects/scribblings/reference/syntax.scrbl b/collects/scribblings/reference/syntax.scrbl index 3ec647c7d6..9ee754dadc 100644 --- a/collects/scribblings/reference/syntax.scrbl +++ b/collects/scribblings/reference/syntax.scrbl @@ -722,9 +722,10 @@ default, the relevant phase level is the number of @racket[begin-for-syntax] forms that enclose the @racket[provide] form. -The syntax of @racket[provide-spec] can be extended via -@racket[define-provide-syntax], but the pre-defined forms are as -follows. +The syntax of @racket[provide-spec] can be extended by bindings to +@tech{provide transformers} or @tech{provide pre-transformers}, such +as via @racket[define-provide-syntax], but the pre-defined forms are +as follows. @specsubform[id]{ Exports @racket[id], which must be @tech{bound} within the module (i.e., either defined or imported) at the relevant