0002-auto-syntax-e-and-template-metafunction-stuff.patch (15211B)
1 From 46475182cde225c1c222420bf72de9000ca79a07 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 .../parse/experimental/private/substitute.rkt | 19 ++++++++-- 10 .../syntax/parse/experimental/template.rkt | 38 +++++++++++++++---- 11 .../collects/syntax/parse/private/parse.rkt | 8 +++- 12 .../syntax/parse/private/residual.rkt | 4 +- 13 .../collects/syntax/parse/private/runtime.rkt | 12 ++++-- 14 7 files changed, 80 insertions(+), 24 deletions(-) 15 16 diff --git a/racket/collects/racket/private/stxcase.rkt b/racket/collects/racket/private/stxcase.rkt 17 index ccc501593e..6ac4211fa2 100644 18 --- a/racket/collects/racket/private/stxcase.rkt 19 +++ b/racket/collects/racket/private/stxcase.rkt 20 @@ -4,8 +4,10 @@ 21 (module stxcase '#%kernel 22 (#%require racket/private/stx racket/private/small-scheme '#%paramz '#%unsafe 23 racket/private/ellipses 24 + stxparse-info/current-pvars 25 (for-syntax racket/private/stx racket/private/small-scheme 26 - racket/private/member racket/private/sc '#%kernel)) 27 + racket/private/member racket/private/sc '#%kernel 28 + auto-syntax-e/utils)) 29 30 (-define (datum->syntax/shape orig datum) 31 (if (syntax? datum) 32 @@ -469,7 +471,7 @@ 33 (list 34 (if s-exp? 35 (quote-syntax make-s-exp-mapping) 36 - (quote-syntax make-syntax-mapping)) 37 + (quote-syntax make-auto-pvar)) 38 ;; Tell it the shape of the variable: 39 (let loop ([var unflat-pattern-var][d 0]) 40 (if (syntax? var) 41 @@ -484,9 +486,13 @@ 42 null 43 (if fender 44 (list (quote-syntax if) fender 45 - answer 46 + (list (quote-syntax with-pvars) 47 + pattern-vars 48 + answer) 49 do-try-next) 50 - answer))) 51 + (list (quote-syntax with-pvars) 52 + pattern-vars 53 + answer)))) 54 do-try-next))]) 55 (if fender 56 (list 57 diff --git a/racket/collects/racket/syntax.rkt b/racket/collects/racket/syntax.rkt 58 index 99782d0216..b9ebea0bf3 100644 59 --- a/racket/collects/racket/syntax.rkt 60 +++ b/racket/collects/racket/syntax.rkt 61 @@ -1,7 +1,9 @@ 62 #lang racket/base 63 (require (only-in "stxloc.rkt" syntax-case) 64 + stxparse-info/current-pvars 65 (for-syntax racket/base 66 - racket/private/sc)) 67 + racket/private/sc 68 + auto-syntax-e/utils)) 69 (provide define/with-syntax 70 71 current-recorded-disappeared-uses 72 @@ -44,8 +46,9 @@ 73 (with-syntax ([pattern rhs]) 74 (values (pvar-value pvar) ...))) 75 (define-syntax pvar 76 - (make-syntax-mapping 'depth (quote-syntax valvar))) 77 - ...)))])) 78 + (make-auto-pvar 'depth (quote-syntax valvar))) 79 + ... 80 + (define-pvars pvar ...))))])) 81 ;; Ryan: alternative name: define/syntax-pattern ?? 82 83 ;; auxiliary macro 84 diff --git a/racket/collects/syntax/parse/experimental/private/substitute.rkt b/racket/collects/syntax/parse/experimental/private/substitute.rkt 85 index 2e11d58694..e92024c1f5 100644 86 --- a/racket/collects/syntax/parse/experimental/private/substitute.rkt 87 +++ b/racket/collects/syntax/parse/experimental/private/substitute.rkt 88 @@ -2,7 +2,8 @@ 89 (require syntax/parse/private/minimatch 90 racket/private/promise 91 racket/private/stx) ;; syntax/stx 92 -(provide translate) 93 +(provide translate 94 + syntax-local-template-metafunction-introduce) 95 96 #| 97 ;; Doesn't seem to make much difference. 98 @@ -58,7 +59,7 @@ An VarRef is one of 99 100 ;; Used to indicate absent pvar in template; ?? catches 101 ;; Note: not an exn, don't need continuation marks 102 -#;(require (only-in rackunit require/expose)) 103 +(require (only-in rackunit require/expose)) 104 #;(require/expose syntax/parse/experimental/private/substitute 105 (absent-pvar 106 absent-pvar? 107 @@ -257,7 +258,8 @@ An VarRef is one of 108 [mark (make-syntax-introducer)] 109 [old-mark (current-template-metafunction-introducer)] 110 [mf (get index env lenv)]) 111 - (parameterize ((current-template-metafunction-introducer mark)) 112 + (parameterize ((current-template-metafunction-introducer mark) 113 + (old-template-metafunction-introducer old-mark)) 114 (let ([r (call-with-continuation-barrier (lambda () (mf (mark (old-mark v)))))]) 115 (unless (syntax? r) 116 (raise-syntax-error #f "result of template metafunction was not syntax" stx)) 117 @@ -399,6 +401,17 @@ An VarRef is one of 118 (syntax-local-introduce stx) 119 stx)))) 120 121 +(define old-template-metafunction-introducer 122 + (make-parameter #f)) 123 + 124 +(define (syntax-local-template-metafunction-introduce stx) 125 + (let ([mark (current-template-metafunction-introducer)] 126 + [old-mark (old-template-metafunction-introducer)]) 127 + (unless old-mark 128 + (error 'syntax-local-template-metafunction-introduce 129 + "must be called within the dynamic extent of a template metafunction")) 130 + (mark (old-mark stx)))) 131 + 132 ;; ---- 133 134 (define (stx-cadr x) (stx-car (stx-cdr x))) 135 diff --git a/racket/collects/syntax/parse/experimental/template.rkt b/racket/collects/syntax/parse/experimental/template.rkt 136 index aaaa599602..0cad7a1532 100644 137 --- a/racket/collects/syntax/parse/experimental/template.rkt 138 +++ b/racket/collects/syntax/parse/experimental/template.rkt 139 @@ -5,7 +5,8 @@ 140 syntax/parse/private/minimatch 141 racket/private/stx ;; syntax/stx 142 racket/private/sc 143 - racket/struct) 144 + racket/struct 145 + auto-syntax-e/utils) 146 stxparse-info/parse/private/residual 147 "private/substitute.rkt") 148 (provide template 149 @@ -13,8 +14,10 @@ 150 quasitemplate 151 quasitemplate/loc 152 define-template-metafunction 153 + syntax-local-template-metafunction-introduce 154 ?? 155 - ?@) 156 + ?@ 157 + (for-syntax template-metafunction?)) 158 159 #| 160 To do: 161 @@ -91,7 +94,13 @@ A HeadTemplate (H) is one of: 162 (define-syntax (quasitemplate stx) 163 (syntax-case stx () 164 [(quasitemplate t) 165 - (do-template stx #'t #t #f)])) 166 + (do-template stx #'t #t #f)] 167 + [(quasitemplate t #:properties (prop ...)) 168 + (andmap identifier? (syntax->list #'(prop ...))) 169 + (parameterize ((props-to-serialize (syntax->datum #'(prop ...))) 170 + (props-to-transfer (syntax->datum #'(prop ...)))) 171 + ;; Same as above 172 + (do-template stx #'t #t #f))])) 173 174 (define-syntaxes (template/loc quasitemplate/loc) 175 ;; FIXME: better to replace unsyntax form, shrink template syntax constant 176 @@ -103,7 +112,16 @@ A HeadTemplate (H) is one of: 177 (syntax-arm 178 (with-syntax ([main-expr (do-template stx #'t quasi? #'loc-stx)]) 179 #'(let ([loc-stx (handle-loc '?/loc loc-expr)]) 180 - main-expr)))])))]) 181 + main-expr)))] 182 + [(?/loc loc-expr t #:properties (prop ...)) 183 + (andmap identifier? (syntax->list #'(prop ...))) 184 + (parameterize ((props-to-serialize (syntax->datum #'(prop ...))) 185 + (props-to-transfer (syntax->datum #'(prop ...)))) 186 + ;; Same as above 187 + (syntax-arm 188 + (with-syntax ([main-expr (do-template stx #'t quasi? #'loc-stx)]) 189 + #'(let ([loc-stx (handle-loc '?/loc loc-expr)]) 190 + main-expr))))])))]) 191 (values (make-tx #f) (make-tx #t)))) 192 193 (define (handle-loc who x) 194 @@ -185,6 +203,10 @@ instead of integers and integer vectors. 195 196 ;; ============================================================ 197 198 + 199 +;; TODO: once PR https://github.com/racket/racket/pull/1591 is merged, use 200 +;; the exported prop:template-metafunction, template-metafunction? and 201 +;; template-metafunction-accessor. 202 (define-syntax (define-template-metafunction stx) 203 (syntax-case stx () 204 [(dsm (id arg ...) . body) 205 @@ -229,7 +251,7 @@ instead of integers and integer vectors. 206 (let*-values ([(drivers pre-guide props-guide) (parse-t t 0 #f)] 207 [(drivers pre-guide) 208 (if loc-id 209 - (let* ([loc-sm (make-syntax-mapping 0 loc-id)] 210 + (let* ([loc-sm (make-auto-pvar 0 loc-id)] 211 [loc-pvar (pvar loc-sm #f #f)]) 212 (values (dset-add drivers loc-pvar) 213 (relocate-guide pre-guide loc-pvar))) 214 @@ -410,7 +432,7 @@ instead of integers and integer vectors. 215 (and (pair? v) (quotable? (car v)) (quotable? (cdr v))) 216 (and (vector? v) (andmap quotable? (vector->list v))) 217 (and (hash? v) (andmap quotable? (hash->list v))) 218 - (and (prefab-struct-key v) (andmap quotable? (cdr (vector->list (struct->vector v))))))) 219 + (and (prefab-struct-key v) (andmap quotable? (struct->list v))))) 220 221 (define (cons-guide g1 g2) 222 (if (and (eq? g1 '_) (eq? g2 '_)) '_ (cons g1 g2))) 223 @@ -454,7 +476,7 @@ instead of integers and integer vectors. 224 (cond [(box? qval) 225 (with-syntax ([(tmp) (generate-temporaries #'(unsyntax-expr))]) 226 (set-box! qval (cons (cons #'tmp t) (unbox qval))) 227 - (let* ([fake-sm (make-syntax-mapping 0 #'tmp)] 228 + (let* ([fake-sm (make-auto-pvar 0 #'tmp)] 229 [fake-pvar (pvar fake-sm #f #f)]) 230 (values (dset fake-pvar) (vector 'unsyntax fake-pvar) '_)))] 231 [else 232 @@ -586,7 +608,7 @@ instead of integers and integer vectors. 233 (cond [(box? qval) 234 (with-syntax ([(tmp) (generate-temporaries #'(unsyntax-splicing-expr))]) 235 (set-box! qval (cons (cons #'tmp h) (unbox qval))) 236 - (let* ([fake-sm (make-syntax-mapping 0 #'tmp)] 237 + (let* ([fake-sm (make-auto-pvar 0 #'tmp)] 238 [fake-pvar (pvar fake-sm #f #f)]) 239 (values (dset fake-pvar) #t (vector 'unsyntax-splicing fake-pvar) '_)))] 240 [else 241 diff --git a/racket/collects/syntax/parse/private/parse.rkt b/racket/collects/syntax/parse/private/parse.rkt 242 index 9e1652c87f..266d2bba44 100644 243 --- a/racket/collects/syntax/parse/private/parse.rkt 244 +++ b/racket/collects/syntax/parse/private/parse.rkt 245 @@ -414,7 +414,13 @@ Conventions: 246 [_ (raise-syntax-error #f "expected exactly one template" #'ctx)])) 247 ((body-sequence) 248 (syntax-case rest () 249 - [(e0 e ...) #'(let () e0 e ...)] 250 + [(e0 e ...) 251 + ;; Should we use a shadower (works on the whole file, unhygienically), 252 + ;; or use the context of the syntax-parse identifier? 253 + (let ([the-#%intdef-begin (datum->syntax #'ctx '#%intdef-begin)]) 254 + (if (syntax-local-value the-#%intdef-begin (λ () #f)) ;; Defined as a macro 255 + #`(let () (#,the-#%intdef-begin e0 e ...)) 256 + #'(let () e0 e ...)))] 257 [_ (raise-syntax-error #f "expected non-empty clause body" 258 #'ctx clause)])) 259 (else 260 diff --git a/racket/collects/syntax/parse/private/residual.rkt b/racket/collects/syntax/parse/private/residual.rkt 261 index d53cfb4661..beafc6709d 100644 262 --- a/racket/collects/syntax/parse/private/residual.rkt 263 +++ b/racket/collects/syntax/parse/private/residual.rkt 264 @@ -53,7 +53,9 @@ 265 266 (require "runtime-progress.rkt" 267 "3d-stx.rkt" 268 - syntax/stx) 269 + auto-syntax-e 270 + syntax/stx 271 + stxparse-info/current-pvars) 272 273 (provide (all-from-out "runtime-progress.rkt") 274 275 diff --git a/racket/collects/syntax/parse/private/runtime.rkt b/racket/collects/syntax/parse/private/runtime.rkt 276 index 98764b189c..7b6cb1989b 100644 277 --- a/racket/collects/syntax/parse/private/runtime.rkt 278 +++ b/racket/collects/syntax/parse/private/runtime.rkt 279 @@ -1,11 +1,13 @@ 280 #lang racket/base 281 (require racket/stxparam 282 stxparse-info/parse/private/residual ;; keep abs. path 283 + stxparse-info/current-pvars 284 (for-syntax racket/base 285 racket/list 286 syntax/kerncase 287 syntax/strip-context 288 racket/private/sc 289 + auto-syntax-e/utils 290 racket/syntax 291 syntax/parse/private/rep-data)) 292 293 @@ -100,9 +102,10 @@ residual.rkt. 294 'name 'depth 'syntax?)] ...) 295 ([(vtmp) value] ...) 296 (letrec-syntaxes+values 297 - ([(name) (make-syntax-mapping 'depth (quote-syntax stmp))] ...) 298 + ([(name) (make-auto-pvar 'depth (quote-syntax stmp))] ...) 299 () 300 - . body))))])) 301 + (with-pvars (name ...) 302 + . body)))))])) 303 304 ;; (let-attributes* (([id num] ...) (expr ...)) expr) : expr 305 ;; Special case: empty attrs need not match number of value exprs. 306 @@ -136,8 +139,9 @@ residual.rkt. 307 (make-attribute-mapping (quote-syntax vtmp) 308 'name 'depth 'syntax?)) 309 ... 310 - (define-syntax name (make-syntax-mapping 'depth (quote-syntax stmp))) 311 - ...)))])) 312 + (define-syntax name (make-auto-pvar 'depth (quote-syntax stmp))) 313 + ... 314 + (define-pvars name ...))))])) 315 316 (define-syntax-rule (phase-of-enclosing-module) 317 (variable-reference->module-base-phase 318 -- 319 2.30.0 320