0002-auto-syntax-e-and-template-metafunction-stuff.patch (9549B)
1 From 9e686f19b9139ffd106ce6937d80153ebcaf6f60 Mon Sep 17 00:00:00 2001 2 From: Suzanne Soy <ligo@suzanne.soy> 3 Date: Tue, 2 Mar 2021 21:20:46 +0000 4 Subject: [PATCH 2/2] auto-syntax-e and template-metafunction stuff 5 6 --- 7 racket/collects/racket/private/stxcase.rkt | 14 ++++++++++---- 8 racket/collects/racket/syntax.rkt | 9 ++++++--- 9 .../syntax/parse/experimental/template.rkt | 17 +++++++++++++++-- 10 racket/collects/syntax/parse/private/parse.rkt | 7 ++++++- 11 .../collects/syntax/parse/private/residual.rkt | 4 +++- 12 .../collects/syntax/parse/private/runtime.rkt | 12 ++++++++---- 13 6 files changed, 48 insertions(+), 15 deletions(-) 14 15 diff --git racket/collects/racket/private/stxcase.rkt racket/collects/racket/private/stxcase.rkt 16 index 2ac2ec85a6..8101d34c3d 100644 17 --- racket/collects/racket/private/stxcase.rkt 18 +++ racket/collects/racket/private/stxcase.rkt 19 @@ -4,8 +4,10 @@ 20 (module stxcase '#%kernel 21 (#%require racket/private/stx racket/private/define-et-al racket/private/qq-and-or racket/private/cond '#%paramz '#%unsafe 22 racket/private/ellipses 23 + stxparse-info/current-pvars 24 (for-syntax racket/private/stx racket/private/define-et-al racket/private/qq-and-or racket/private/cond 25 - racket/private/gen-temp racket/private/sc '#%kernel)) 26 + racket/private/gen-temp racket/private/sc '#%kernel 27 + auto-syntax-e/utils)) 28 29 (-define interp-match 30 (lambda (pat e literals immediate=?) 31 @@ -346,7 +348,7 @@ 32 (list 33 (if s-exp? 34 (quote-syntax make-s-exp-mapping) 35 - (quote-syntax make-syntax-mapping)) 36 + (quote-syntax make-auto-pvar)) 37 ;; Tell it the shape of the variable: 38 (let loop ([var unflat-pattern-var][d 0]) 39 (if (syntax? var) 40 @@ -361,9 +363,13 @@ 41 null 42 (if fender 43 (list (quote-syntax if) fender 44 - answer 45 + (list (quote-syntax with-pvars) 46 + pattern-vars 47 + answer) 48 do-try-next) 49 - answer))) 50 + (list (quote-syntax with-pvars) 51 + pattern-vars 52 + answer)))) 53 do-try-next))]) 54 (if fender 55 (list 56 diff --git racket/collects/racket/syntax.rkt racket/collects/racket/syntax.rkt 57 index 4aee14d23d..54329c54f7 100644 58 --- racket/collects/racket/syntax.rkt 59 +++ racket/collects/racket/syntax.rkt 60 @@ -1,7 +1,9 @@ 61 #lang racket/base 62 (require (only-in "stxloc.rkt" syntax-case) 63 + stxparse-info/current-pvars 64 (for-syntax racket/base 65 - racket/private/sc)) 66 + racket/private/sc 67 + auto-syntax-e/utils)) 68 (provide define/with-syntax 69 70 current-recorded-disappeared-uses 71 @@ -44,8 +46,9 @@ 72 (with-syntax ([pattern rhs]) 73 (values (pvar-value pvar) ...))) 74 (define-syntax pvar 75 - (make-syntax-mapping 'depth (quote-syntax valvar))) 76 - ...)))])) 77 + (make-auto-pvar 'depth (quote-syntax valvar))) 78 + ... 79 + (define-pvars pvar ...))))])) 80 ;; Ryan: alternative name: define/syntax-pattern ?? 81 82 ;; auxiliary macro 83 diff --git racket/collects/syntax/parse/experimental/template.rkt racket/collects/syntax/parse/experimental/template.rkt 84 index b52fd80e6e..160eccc84b 100644 85 --- racket/collects/syntax/parse/experimental/template.rkt 86 +++ racket/collects/syntax/parse/experimental/template.rkt 87 @@ -1,5 +1,6 @@ 88 #lang racket/base 89 -(require (for-syntax racket/base) 90 +(require (for-syntax racket/base 91 + auto-syntax-e/utils) 92 (only-in racket/private/template 93 metafunction)) 94 (provide (rename-out [syntax template] 95 @@ -26,10 +27,22 @@ 96 (define current-template-metafunction-introducer 97 (make-parameter (lambda (stx) (if (syntax-transforming?) (syntax-local-introduce stx) stx)))) 98 99 +(define old-template-metafunction-introducer 100 + (make-parameter #f)) 101 + 102 +(define (syntax-local-template-metafunction-introduce stx) 103 + (let ([mark (current-template-metafunction-introducer)] 104 + [old-mark (old-template-metafunction-introducer)]) 105 + (unless old-mark 106 + (error 'syntax-local-template-metafunction-introduce 107 + "must be called within the dynamic extent of a template metafunction")) 108 + (mark (old-mark stx)))) 109 + 110 (define ((make-hygienic-metafunction transformer) stx) 111 (define mark (make-syntax-introducer)) 112 (define old-mark (current-template-metafunction-introducer)) 113 - (parameterize ((current-template-metafunction-introducer mark)) 114 + (parameterize ((current-template-metafunction-introducer mark) 115 + (old-template-metafunction-introducer old-mark)) 116 (define r (call-with-continuation-barrier (lambda () (transformer (mark (old-mark stx)))))) 117 (unless (syntax? r) 118 (raise-syntax-error #f "result of template metafunction was not syntax" stx)) 119 diff --git racket/collects/syntax/parse/private/parse.rkt racket/collects/syntax/parse/private/parse.rkt 120 index e14cc3aea9..7e5c61dee1 100644 121 --- racket/collects/syntax/parse/private/parse.rkt 122 +++ racket/collects/syntax/parse/private/parse.rkt 123 @@ -435,7 +435,12 @@ Conventions: 124 ((body-sequence) 125 (syntax-case rest () 126 [(e0 e ...) 127 - #'(let () e0 e ...)] 128 + ;; Should we use a shadower (works on the whole file, unhygienically), 129 + ;; or use the context of the syntax-parse identifier? 130 + (let ([the-#%intdef-begin (datum->syntax #'ctx '#%intdef-begin)]) 131 + (if (syntax-local-value the-#%intdef-begin (λ () #f)) ;; Defined as a macro 132 + #`(let () (#,the-#%intdef-begin e0 e ...)) 133 + #'(let () e0 e ...)))] 134 [_ (raise-syntax-error #f "expected non-empty clause body" 135 #'ctx clause)])) 136 (else 137 diff --git racket/collects/syntax/parse/private/residual.rkt racket/collects/syntax/parse/private/residual.rkt 138 index 88a5911810..1c78afe79f 100644 139 --- racket/collects/syntax/parse/private/residual.rkt 140 +++ racket/collects/syntax/parse/private/residual.rkt 141 @@ -18,7 +18,9 @@ 142 143 (require "runtime-progress.rkt" 144 "3d-stx.rkt" 145 - syntax/stx) 146 + auto-syntax-e 147 + syntax/stx 148 + stxparse-info/current-pvars) 149 150 (provide (all-from-out "runtime-progress.rkt") 151 152 diff --git racket/collects/syntax/parse/private/runtime.rkt racket/collects/syntax/parse/private/runtime.rkt 153 index 41b321499e..90d7ea88f4 100644 154 --- racket/collects/syntax/parse/private/runtime.rkt 155 +++ racket/collects/syntax/parse/private/runtime.rkt 156 @@ -1,11 +1,13 @@ 157 #lang racket/base 158 (require racket/stxparam 159 stxparse-info/parse/private/residual ;; keep abs. path 160 + stxparse-info/current-pvars 161 (for-syntax racket/base 162 racket/list 163 syntax/kerncase 164 syntax/strip-context 165 racket/private/sc 166 + auto-syntax-e/utils 167 racket/syntax 168 syntax/parse/private/rep-data)) 169 170 @@ -111,9 +113,10 @@ residual.rkt. 171 ...) 172 ([(vtmp) value] ...) 173 (letrec-syntaxes+values 174 - ([(name) (make-syntax-mapping 'depth (quote-syntax stmp))] ...) 175 + ([(name) (make-auto-pvar 'depth (quote-syntax stmp))] ...) 176 () 177 - . body))))])) 178 + (with-pvars (name ...) 179 + . body)))))])) 180 181 ;; (let-attributes* (([id num] ...) (expr ...)) expr) : expr 182 ;; Special case: empty attrs need not match number of value exprs. 183 @@ -147,8 +150,9 @@ residual.rkt. 184 (attribute-mapping (quote-syntax vtmp) 'name 'depth 185 (if 'syntax? #f (quote-syntax check-attr-value)))) 186 ... 187 - (define-syntax name (make-syntax-mapping 'depth (quote-syntax stmp))) 188 - ...)))])) 189 + (define-syntax name (make-auto-pvar 'depth (quote-syntax stmp))) 190 + ... 191 + (define-pvars name ...))))])) 192 193 (define-syntax-rule (phase-of-enclosing-module) 194 (variable-reference->module-base-phase 195 -- 196 2.30.0 197