From 80bd64532570f5032914d75ca87d94c4a2cd1133 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 12 Feb 2024 14:26:24 -0700 Subject: [PATCH] use `syntax-local-apply-transformer` Switch enforestation-level expansion away from a custom expansion step and scope management, and use `syntax-local-apply-transformer`, instead. Thanks to @michaelballantyne for reminding me how this is supposed to work. --- enforest/main.rkt | 10 ++- enforest/name-root.rkt | 25 +++--- enforest/operator.rkt | 72 +++++++++-------- enforest/private/transform.rkt | 45 ++++++----- enforest/sequence.rkt | 18 +++-- enforest/transformer.rkt | 9 +-- rhombus/private/binding.rkt | 13 ++-- rhombus/private/export.rkt | 18 ++--- rhombus/private/expr-macro.rkt | 7 +- rhombus/private/import.rkt | 6 +- rhombus/private/name-root-ref.rkt | 6 +- rhombus/private/namespace.rkt | 2 +- rhombus/private/parse.rkt | 123 ++++++++++++++---------------- rhombus/private/space-macro.rkt | 4 +- rhombus/private/syntax-meta.rkt | 2 +- 15 files changed, 184 insertions(+), 176 deletions(-) diff --git a/enforest/main.rkt b/enforest/main.rkt index 3ab6bce56..d04876148 100644 --- a/enforest/main.rkt +++ b/enforest/main.rkt @@ -211,11 +211,12 @@ [() (raise-syntax-error #f (format "missing ~a" form-kind-str) stxes)] [(head::name . tail) (define name-path? (starts-like-name-path? #'head #'tail)) + (define head-name (and name-path? (in-name-root-space #'head.name))) (cond [(and name-path? - (syntax-local-value* (in-name-root-space #'head.name) name-root-ref)) + (syntax-local-value* head-name name-root-ref)) => (lambda (v) - (define-values (head tail) (apply-name-root #'head.name v in-space stxes)) + (define-values (head tail) (apply-name-root head-name v in-space stxes)) (enforest-step (datum->syntax #f (cons head tail)) current-op current-op-stx stop-on-unbound?))] [else (define head-id (in-space #'head.name)) @@ -271,11 +272,12 @@ [() (values init-form stxes)] [(head::name . tail) (define name-path? (starts-like-name-path? #'head #'tail)) + (define head-name (and name-path? (in-name-root-space #'head.name))) (cond [(and name-path? - (syntax-local-value* (in-name-root-space #'head.name) name-root-ref)) + (syntax-local-value* head-name name-root-ref)) => (lambda (v) - (define-values (head tail) (apply-name-root #'head.name v in-space stxes)) + (define-values (head tail) (apply-name-root head-name v in-space stxes)) (enforest-step init-form (datum->syntax #f (cons head tail)) current-op current-op-stx stop-on-unbound?))] [else (define head-id (in-space #'head.name)) diff --git a/enforest/name-root.rkt b/enforest/name-root.rkt index 6a025063a..04040fc48 100644 --- a/enforest/name-root.rkt +++ b/enforest/name-root.rkt @@ -17,17 +17,20 @@ (define (apply-name-root op-stx lxc in-space stxes) (define proc (name-root-proc lxc)) - (call-as-transformer - op-stx - syntax-track-origin - (lambda (in out) - (define-values (target tail) (proc in-space (in stxes))) - (unless (or (identifier? target) - (and (syntax? target) - (pair? (syntax-e target)) - (eq? 'op (syntax-e (car (syntax-e target)))))) - (raise-result-error (proc-name proc) "identifier-or-operator?" target)) - (check-transformer-result (out target) (out tail) proc)))) + (define-values (target tail) + (call-as-transformer + op-stx + (list stxes) + syntax-track-origin + (lambda (stxes) + (define-values (target tail) (proc in-space stxes)) + (unless (or (identifier? target) + (and (syntax? target) + (pair? (syntax-e target)) + (eq? 'op (syntax-e (car (syntax-e target)))))) + (raise-result-error (proc-name proc) "identifier-or-operator?" target)) + (values target tail)))) + (check-transformer-result target tail proc)) (define (name-root-ref-root v ref) (ref v)) diff --git a/enforest/operator.rkt b/enforest/operator.rkt index 8452f954e..30fc172ab 100644 --- a/enforest/operator.rkt +++ b/enforest/operator.rkt @@ -136,8 +136,8 @@ [else dir])])) (define (lookup-prefix-implicit alone-name adj-context adj-form in-space operator-ref operator-kind form-kind) - (define op-stx (datum->syntax adj-context alone-name)) - (define op (syntax-local-value* (in-space op-stx) operator-ref)) + (define op-stx (in-space (datum->syntax adj-context alone-name))) + (define op (syntax-local-value* op-stx operator-ref)) (unless op (raise-syntax-error #f (format (string-append @@ -155,8 +155,8 @@ (define (lookup-infix-implicit adjacent-name prev-form adj-context adj-form in-space operator-ref operator-kind form-kind stop-on-unbound? lookup-space-description) - (define op-stx (datum->syntax adj-context adjacent-name)) - (define op (syntax-local-value* (in-space op-stx) operator-ref)) + (define op-stx (in-space (datum->syntax adj-context adjacent-name))) + (define op (syntax-local-value* op-stx operator-ref)) (unless op (cond [(identifier? prev-form) @@ -215,39 +215,47 @@ #f) (define (apply-prefix-direct-operator op form stx track-origin checker) - (call-as-transformer - stx - track-origin - (lambda (in out) - (define proc (operator-proc op)) - (out (checker (proc (in form) stx) proc))))) + (define proc (operator-proc op)) + (checker (call-as-transformer + stx + (list form) + track-origin + (lambda (form) + (proc form stx))) + proc)) (define (apply-infix-direct-operator op form1 form2 stx track-origin checker) - (call-as-transformer - stx - track-origin - (lambda (in out) - (define proc (operator-proc op)) - (checker (out (proc (in form1) (in form2) stx)) proc)))) + (define proc (operator-proc op)) + (checker (call-as-transformer + stx + (list form1 form2) + track-origin + (lambda (form1 form2) + (proc form1 form2 stx))) + proc)) (define (apply-prefix-transformer-operator op op-stx tail track-origin checker) (define proc (operator-proc op)) - (call-as-transformer - op-stx - track-origin - (lambda (in out) - (define-values (form new-tail) (proc (in tail))) - (check-transformer-result (out (checker form proc)) - (out new-tail) - proc)))) + (define-values (form new-tail) + (call-as-transformer + op-stx + (list tail) + track-origin + (lambda (tail) + (define-values (form new-tail) (proc tail)) + (values (checker form proc) + new-tail)))) + (check-transformer-result form new-tail proc)) (define (apply-infix-transformer-operator op op-stx form1 tail track-origin checker) (define proc (operator-proc op)) - (call-as-transformer - op-stx - track-origin - (lambda (in out) - (define-values (form new-tail) (proc (in form1) (in tail))) - (check-transformer-result (out (checker form proc)) - (out new-tail) - proc)))) + (define-values (form new-tail) + (call-as-transformer + op-stx + (list form1 tail) + track-origin + (lambda (form1 tail) + (define-values (form new-tail) (proc form1 tail)) + (values (checker form proc) + new-tail)))) + (check-transformer-result form new-tail proc)) diff --git a/enforest/private/transform.rkt b/enforest/private/transform.rkt index 81a54c66c..f05bfb6de 100644 --- a/enforest/private/transform.rkt +++ b/enforest/private/transform.rkt @@ -10,29 +10,33 @@ (define no-props (datum->syntax #f #f)) -(define current-transformer-introduce (make-parameter (lambda (stx) stx))) (define (transform-in stx) - ((current-transformer-introduce) stx)) + (syntax-local-introduce stx)) (define (transform-out stx) - ((current-transformer-introduce) stx)) + (syntax-local-introduce stx)) -(define (call-as-transformer id track-origin thunk) - (define intro (make-syntax-introducer)) - (parameterize ([current-transformer-introduce intro]) - (thunk intro - (lambda (stx) - (let loop ([stx stx]) - (cond - [(syntax? stx) - (track-origin (intro stx) - (let ([du (syntax-property id 'disappeared-use)]) - (if du - (syntax-property no-props 'disappeared-use du) - no-props)) - id)] - [(pair? stx) (cons (loop (car stx)) - (loop (cdr stx)))] - [else stx])))))) +(define (call-as-transformer id args track-origin proc) + (call-with-values + (lambda () + (apply syntax-local-apply-transformer + proc + id + ;; for now, use contexts that imply no use-site scopes: + (if (eq? 'top-level (syntax-local-context)) + 'top-level + 'expression) + #f + (map syntax-local-introduce args))) + (lambda stxes + (apply values (map syntax-local-introduce (map (track track-origin id) stxes)))))) + +(define ((track track-origin id) stx) + (track-origin stx + (let ([du (syntax-property id 'disappeared-use)]) + (if du + (syntax-property no-props 'disappeared-use du) + no-props)) + id)) (define (check-transformer-result form tail proc) (unless (syntax? form) (raise-result-error (proc-name proc) "syntax?" form)) @@ -51,4 +55,3 @@ (syntax-track-origin e from-stx id)) stx stx)) - diff --git a/enforest/sequence.rkt b/enforest/sequence.rkt index b59f74372..94682af3d 100644 --- a/enforest/sequence.rkt +++ b/enforest/sequence.rkt @@ -78,11 +78,13 @@ (define (apply-sequence-transformer t id stx tail track-origin checker) (define proc (sequence-transformer-proc t)) - (call-as-transformer - id - track-origin - (lambda (in out) - (define-values (forms new-tail) (proc (in stx) (in tail))) - (check-transformer-result (out (datum->syntax #f (checker forms proc))) - (out new-tail) - proc)))) + (define-values (forms new-tail) + (call-as-transformer + id + (list stx tail) + track-origin + (lambda (stx tail) + (define-values (forms new-tail) (proc stx tail)) + (values (datum->syntax #f (checker forms proc)) + (datum->syntax #f new-tail))))) + (check-transformer-result forms new-tail proc)) diff --git a/enforest/transformer.rkt b/enforest/transformer.rkt index 8f8120182..24d88c6f5 100644 --- a/enforest/transformer.rkt +++ b/enforest/transformer.rkt @@ -18,8 +18,6 @@ transformer transformer-ref - transform-in - transform-out call-as-transformer track-sequence-origin @@ -116,7 +114,8 @@ (define proc (transformer-proc t)) (call-as-transformer id + (list stx) track-origin - (lambda (in out) - (define forms (checker (proc (in stx)) proc)) - (datum->syntax #f (out forms))))) + (lambda (stx) + (define forms (checker (proc stx) proc)) + (datum->syntax #f forms)))) diff --git a/rhombus/private/binding.rkt b/rhombus/private/binding.rkt index 8dd4542d3..4d1f60aee 100644 --- a/rhombus/private/binding.rkt +++ b/rhombus/private/binding.rkt @@ -57,13 +57,12 @@ "cannot find a transformer for an infoer" #'infoer-id))] #:with info (check-binding-info-result - (transform-out - (let ([form (transform-in #'form)]) - (call-as-transformer - #'infoer-id - syntax-track-origin - (lambda (in out) - (out (proc (in form))))))) + (let ([form #'form]) + (call-as-transformer + #'infoer-id + (list form) + syntax-track-origin + proc)) proc))) ;; To unpack a binding infoer result: diff --git a/rhombus/private/export.rkt b/rhombus/private/export.rkt index 3a0416c27..8a2854b6b 100644 --- a/rhombus/private/export.rkt +++ b/rhombus/private/export.rkt @@ -92,26 +92,26 @@ #:make-identifier-form make-identifier-export #:make-operator-form make-identifier-export) - (define (make-export-modifier-ref transform-in ex) + (define (make-export-modifier-ref ex) ;; "accessor" closes over `ex`: (lambda (v) (define mod (export-modifier-ref v)) (and mod (transformer (lambda (stx) - ((transformer-proc mod) (transform-in ex) stx)))))) + ((transformer-proc mod) (syntax-local-introduce ex) stx)))))) (define-rhombus-transform #:syntax-class (:export-modifier parsed-ex) #:desc "export modifier" #:parsed-tag #:rhombus/expo #:in-space in-export-space - #:transformer-ref (make-export-modifier-ref transform-in (syntax-parse parsed-ex - #:datum-literals (parsed) - [(parsed #:rhombus/expo req) #'req] - [_ (raise-arguments-error - 'export_meta.ParsedModifier - "given export to modify is not parsed" - "base export" parsed-ex)]))) + #:transformer-ref (make-export-modifier-ref (syntax-parse parsed-ex + #:datum-literals (parsed) + [(parsed #:rhombus/expo req) #'req] + [_ (raise-arguments-error + 'export_meta.ParsedModifier + "given export to modify is not parsed" + "base export" parsed-ex)]))) (define-syntax-class :modified-export #:attributes (parsed) diff --git a/rhombus/private/expr-macro.rkt b/rhombus/private/expr-macro.rkt index 086282b33..c6769d4f3 100644 --- a/rhombus/private/expr-macro.rkt +++ b/rhombus/private/expr-macro.rkt @@ -158,10 +158,9 @@ (syntax-parse (unpack-group s who #f) [e::expression (define-values (expr opaque) - (syntax-local-expand-expression - (syntax-local-introduce (transform-out #'e.parsed)))) + (syntax-local-expand-expression #'e.parsed)) (values (relocate+reraw expr #`(parsed #:rhombus/expr - #,(transform-in (syntax-local-introduce expr)))) + #,expr)) (relocate+reraw expr #`(parsed #:rhombus/expr - #,(transform-in (syntax-local-introduce opaque)))))])) + #,opaque)))])) ) diff --git a/rhombus/private/import.rkt b/rhombus/private/import.rkt index 0408cbf88..b03a62085 100644 --- a/rhombus/private/import.rkt +++ b/rhombus/private/import.rkt @@ -122,9 +122,9 @@ (define mod (or (import-modifier-ref v) (import-modifier-block-ref v))) (and mod - (transformer (let ([req (transform-in req)]) ; import transformer scope + (transformer (let ([req (syntax-local-introduce req)]) ; import transformer scope (lambda (stx) - ((transformer-proc mod) (transform-in req) ; import-modifier transformer scope + ((transformer-proc mod) (syntax-local-introduce req) ; import-modifier transformer scope stx))))))) (define-rhombus-transform @@ -506,7 +506,7 @@ (syntax-parse i #:datum-literals (parsed nspace) [(parsed mod-path parsed-r) - (define-values (mp r) (import-invert (syntax-local-introduce (transform-in #'parsed-r)) #f #f)) + (define-values (mp r) (import-invert (syntax-local-introduce #'parsed-r) #f #f)) #`(reimport #,id #,mp #,r)] [(nspace . _) #`(import-root #,id #,i #,space-id)]))]))) (cond diff --git a/rhombus/private/name-root-ref.rkt b/rhombus/private/name-root-ref.rkt index 1bd0e0aac..bf6516fdf 100644 --- a/rhombus/private/name-root-ref.rkt +++ b/rhombus/private/name-root-ref.rkt @@ -50,7 +50,7 @@ field-id field-id) 'disappeared-use - (transform-out (in-name-root-space prefix)))) + (syntax-local-introduce (in-name-root-space prefix)))) (define (next form-id field-id what tail) (define binding-end? (and binding-ref (syntax-parse tail @@ -228,8 +228,8 @@ (syntax-e root-id)) (syntax-e field-id)))) 'disappeared-use - (let ([root (transform-out (in-name-root-space root-id))]) - (if (syntax-original? (transform-out field-id)) + (let ([root (syntax-local-introduce (in-name-root-space root-id))]) + (if (syntax-original? (syntax-local-introduce field-id)) ;; enable arrows, etc., from `new-field-id` based on its binding (cons (syntax-property (datum->syntax new-field-id (syntax-e new-field-id) diff --git a/rhombus/private/namespace.rkt b/rhombus/private/namespace.rkt index ef383c218..fee3fb301 100644 --- a/rhombus/private/namespace.rkt +++ b/rhombus/private/namespace.rkt @@ -41,7 +41,7 @@ #:with name::dotted-identifier #'name-seq (define intro syntax-local-introduce) #`((rhombus-nested-forwarding-sequence - (define-name-root-for-exports [name.name name.extends plain #,(intro #'scoped)]) + (define-name-root-for-exports [name.name name.extends #,(intro #'plain) scoped]) #,(intro #`(rhombus-nested form ...))))])))) diff --git a/rhombus/private/parse.rkt b/rhombus/private/parse.rkt index 9403dfa24..2770f4440 100644 --- a/rhombus/private/parse.rkt +++ b/rhombus/private/parse.rkt @@ -147,47 +147,43 @@ ;; Trampoline variant where `top` for return is provided first (define-syntax (rhombus-top-step stx) (with-syntax-error-respan - (transform-out ; see `enforest-rhombus-expression` - (syntax-local-introduce - (syntax-parse (syntax-local-introduce (transform-in stx)) - #:datum-literals (group parsed) - [(_ top decl-ok? data) #`(begin)] - [(_ top decl-ok? (data ...) (group (parsed #:rhombus/decl decl)) . forms) - #`(begin decl (top data ... . forms))] - ;; note that we may perform hierarchical name resolution - ;; up to four times, since resolution in `:declaration`, - ;; `:definition`, etc., doesn't carry over - [(_ top decl-ok? (data ...) e::definition-sequence . tail) - (define-values (parsed new-tail) - (apply-definition-sequence-transformer #'e.id #'e.tail #'tail)) - #`(begin (begin . #,parsed) (top data ... . #,new-tail))] - [(_ top decl-ok? (data ...) form . forms) - (define (nestable-parsed) - (syntax-parse #'form - [e::nestable-declaration #'(begin . e.parsed)] - [e::definition #'(begin . e.parsed)] - [_ #`(#%expression (rhombus-expression form))])) - (define parsed - (if (syntax-e #'decl-ok?) - (syntax-parse #'form - [e::declaration #'(begin . e.parsed)] - [_ (nestable-parsed)]) - (nestable-parsed))) - (syntax-parse #'forms - [() parsed] - [_ #`(begin #,parsed (top data ... . forms))])]))))) + (syntax-parse stx + #:datum-literals (group parsed) + [(_ top decl-ok? data) #`(begin)] + [(_ top decl-ok? (data ...) (group (parsed #:rhombus/decl decl)) . forms) + #`(begin decl (top data ... . forms))] + ;; note that we may perform hierarchical name resolution + ;; up to four times, since resolution in `:declaration`, + ;; `:definition`, etc., doesn't carry over + [(_ top decl-ok? (data ...) e::definition-sequence . tail) + (define-values (parsed new-tail) + (apply-definition-sequence-transformer #'e.id #'e.tail #'tail)) + #`(begin (begin . #,parsed) (top data ... . #,new-tail))] + [(_ top decl-ok? (data ...) form . forms) + (define (nestable-parsed) + (syntax-parse #'form + [e::nestable-declaration #'(begin . e.parsed)] + [e::definition #'(begin . e.parsed)] + [_ #`(#%expression (rhombus-expression form))])) + (define parsed + (if (syntax-e #'decl-ok?) + (syntax-parse #'form + [e::declaration #'(begin . e.parsed)] + [_ (nestable-parsed)]) + (nestable-parsed))) + (syntax-parse #'forms + [() parsed] + [_ #`(begin #,parsed (top data ... . forms))])]))) ;; For a definition context: (define-syntax (rhombus-definition stx) (with-syntax-error-respan - (transform-out ; see `enforest-rhombus-expression` - (syntax-local-introduce - (syntax-parse (syntax-local-introduce (transform-in stx)) - #:datum-literals (group parsed) - [(_) #'(begin)] - [(_ (group (parsed #:rhombus/defn defn))) #'defn] - [(_ e::definition) #'(begin . e.parsed)] - [(_ form) #'(#%expression (rhombus-expression form))]))))) + (syntax-parse stx + #:datum-literals (group parsed) + [(_) #'(begin)] + [(_ (group (parsed #:rhombus/defn defn))) #'defn] + [(_ e::definition) #'(begin . e.parsed)] + [(_ form) #'(#%expression (rhombus-expression form))]))) ;; For an expression context, interleaves expansion and enforestation: (define-syntax (rhombus-body stx) @@ -230,30 +226,26 @@ ;; For a definition context, interleaves expansion and enforestation: (define-syntax (rhombus-body-sequence stx) (with-syntax-error-respan - (transform-out ; see `enforest-rhombus-expression` - (syntax-parse (syntax-local-introduce (transform-in stx)) - #:datum-literals (group parsed) - #:literals (maybe-definition) - [(_) #'(begin)] - [(_ (group (parsed #:rhombus/expr (maybe-definition e))) . tail) - #`(begin e . tail)] - [(_ e::definition-sequence . tail) - (define-values (parsed new-tail) - (apply-definition-sequence-transformer #'e.id #'e.tail #'tail)) - (syntax-local-introduce - #`(begin - (begin . #,parsed) - (rhombus-body-sequence . #,new-tail)))] - [(_ e::definition . tail) - (syntax-local-introduce - #`(begin - (begin . e.parsed) - (rhombus-body-sequence . tail)))] - [(_ g . tail) - (syntax-local-introduce - #`(begin - (#%expression (rhombus-expression g)) - (rhombus-body-sequence . tail)))])))) + (syntax-parse stx + #:datum-literals (group parsed) + #:literals (maybe-definition) + [(_) #'(begin)] + [(_ (group (parsed #:rhombus/expr (maybe-definition e))) . tail) + #`(begin e . tail)] + [(_ e::definition-sequence . tail) + (define-values (parsed new-tail) + (apply-definition-sequence-transformer #'e.id #'e.tail #'tail)) + #`(begin + (begin . #,parsed) + (rhombus-body-sequence . #,new-tail))] + [(_ e::definition . tail) + #`(begin + (begin . e.parsed) + (rhombus-body-sequence . tail))] + [(_ g . tail) + #`(begin + (#%expression (rhombus-expression g)) + (rhombus-body-sequence . tail))]))) ;; Wraps a `parsed` term that can be treated as a definition: (define-syntax (maybe-definition stx) @@ -263,10 +255,11 @@ ;; For an expression context: (define-syntax (rhombus-expression stx) ;; The `enforest-rhombus-expression` function expects to be called - ;; during the dynamic extent of a Rhombus transformer; since we're - ;; at the Racket expansion level, instead, transform in and out to - ;; cancel the corresponding calls in `:expression`. - (define new-stx (transform-out (enforest-rhombus-expression (transform-in stx)))) + ;; during the dynamic extent of a Rhombus transformer, so we + ;; add calls to `syntax-local-introduce` to cancel the ones in + ;; `enforest-rhombus-expression` + (define new-stx (syntax-local-introduce + (enforest-rhombus-expression (syntax-local-introduce stx)))) ;; We don't want an 'opaque-raw property to be duplicated. So, ;; if it exists on the input, discard any such property on the ;; output. diff --git a/rhombus/private/space-macro.rkt b/rhombus/private/space-macro.rkt index b76de1ff9..44bb01285 100644 --- a/rhombus/private/space-macro.rkt +++ b/rhombus/private/space-macro.rkt @@ -40,7 +40,7 @@ (syntax-parse stx #:datum-literals (group) [(_ name:identifier (_::block . clauses)) - (define data #`[#,stx base-stx #,(syntax-local-introduce #'scope-stx) + (define data #`[#,stx #,(syntax-local-introduce #'base-stx) scope-stx name enforest-meta define-operator-definition-transformer]) #`((rhombus-mixed-nested-forwarding-sequence (enforest-finish #,data) rhombus-space-clause @@ -52,7 +52,7 @@ (syntax-parse stx #:datum-literals (group) [(_ name:identifier (_::block . clauses)) - (define data #`[#,stx base-stx #,(syntax-local-introduce #'scope-stx) + (define data #`[#,stx #,(syntax-local-introduce #'base-stx) scope-stx name transform-meta define-identifier-syntax-definition-transformer*]) #`((rhombus-mixed-nested-forwarding-sequence (enforest-finish #,data) rhombus-space-clause diff --git a/rhombus/private/syntax-meta.rkt b/rhombus/private/syntax-meta.rkt index 4941c883e..795c97298 100644 --- a/rhombus/private/syntax-meta.rkt +++ b/rhombus/private/syntax-meta.rkt @@ -173,7 +173,7 @@ (define/arity (syntax_meta.flip_introduce stx) #:static-infos ((#%call-result #,syntax-static-infos)) - (transform-in stx)) + (syntax-local-introduce stx)) (define (unpack-identifier-or-operator who id/op-in) (define id/op (unpack-term/maybe id/op-in))