From 46475182cde225c1c222420bf72de9000ca79a07 Mon Sep 17 00:00:00 2001 From: Suzanne Soy Date: Tue, 2 Mar 2021 21:20:46 +0000 Subject: [PATCH 2/2] auto-syntax-e and template-metafunction stuff --- racket/collects/racket/private/stxcase.rkt | 14 +++++-- racket/collects/racket/syntax.rkt | 9 +++-- .../parse/experimental/private/substitute.rkt | 19 ++++++++-- .../syntax/parse/experimental/template.rkt | 38 +++++++++++++++---- .../collects/syntax/parse/private/parse.rkt | 8 +++- .../syntax/parse/private/residual.rkt | 4 +- .../collects/syntax/parse/private/runtime.rkt | 12 ++++-- 7 files changed, 80 insertions(+), 24 deletions(-) diff --git a/racket/collects/racket/private/stxcase.rkt b/racket/collects/racket/private/stxcase.rkt index ccc501593e..6ac4211fa2 100644 --- a/racket/collects/racket/private/stxcase.rkt +++ b/racket/collects/racket/private/stxcase.rkt @@ -4,8 +4,10 @@ (module stxcase '#%kernel (#%require racket/private/stx racket/private/small-scheme '#%paramz '#%unsafe racket/private/ellipses + stxparse-info/current-pvars (for-syntax racket/private/stx racket/private/small-scheme - racket/private/member racket/private/sc '#%kernel)) + racket/private/member racket/private/sc '#%kernel + auto-syntax-e/utils)) (-define (datum->syntax/shape orig datum) (if (syntax? datum) @@ -469,7 +471,7 @@ (list (if s-exp? (quote-syntax make-s-exp-mapping) - (quote-syntax make-syntax-mapping)) + (quote-syntax make-auto-pvar)) ;; Tell it the shape of the variable: (let loop ([var unflat-pattern-var][d 0]) (if (syntax? var) @@ -484,9 +486,13 @@ null (if fender (list (quote-syntax if) fender - answer + (list (quote-syntax with-pvars) + pattern-vars + answer) do-try-next) - answer))) + (list (quote-syntax with-pvars) + pattern-vars + answer)))) do-try-next))]) (if fender (list diff --git a/racket/collects/racket/syntax.rkt b/racket/collects/racket/syntax.rkt index 99782d0216..b9ebea0bf3 100644 --- a/racket/collects/racket/syntax.rkt +++ b/racket/collects/racket/syntax.rkt @@ -1,7 +1,9 @@ #lang racket/base (require (only-in "stxloc.rkt" syntax-case) + stxparse-info/current-pvars (for-syntax racket/base - racket/private/sc)) + racket/private/sc + auto-syntax-e/utils)) (provide define/with-syntax current-recorded-disappeared-uses @@ -44,8 +46,9 @@ (with-syntax ([pattern rhs]) (values (pvar-value pvar) ...))) (define-syntax pvar - (make-syntax-mapping 'depth (quote-syntax valvar))) - ...)))])) + (make-auto-pvar 'depth (quote-syntax valvar))) + ... + (define-pvars pvar ...))))])) ;; Ryan: alternative name: define/syntax-pattern ?? ;; auxiliary macro diff --git a/racket/collects/syntax/parse/experimental/private/substitute.rkt b/racket/collects/syntax/parse/experimental/private/substitute.rkt index 2e11d58694..e92024c1f5 100644 --- a/racket/collects/syntax/parse/experimental/private/substitute.rkt +++ b/racket/collects/syntax/parse/experimental/private/substitute.rkt @@ -2,7 +2,8 @@ (require syntax/parse/private/minimatch racket/private/promise racket/private/stx) ;; syntax/stx -(provide translate) +(provide translate + syntax-local-template-metafunction-introduce) #| ;; Doesn't seem to make much difference. @@ -58,7 +59,7 @@ An VarRef is one of ;; Used to indicate absent pvar in template; ?? catches ;; Note: not an exn, don't need continuation marks -#;(require (only-in rackunit require/expose)) +(require (only-in rackunit require/expose)) #;(require/expose syntax/parse/experimental/private/substitute (absent-pvar absent-pvar? @@ -257,7 +258,8 @@ An VarRef is one of [mark (make-syntax-introducer)] [old-mark (current-template-metafunction-introducer)] [mf (get index env lenv)]) - (parameterize ((current-template-metafunction-introducer mark)) + (parameterize ((current-template-metafunction-introducer mark) + (old-template-metafunction-introducer old-mark)) (let ([r (call-with-continuation-barrier (lambda () (mf (mark (old-mark v)))))]) (unless (syntax? r) (raise-syntax-error #f "result of template metafunction was not syntax" stx)) @@ -399,6 +401,17 @@ An VarRef is one of (syntax-local-introduce stx) stx)))) +(define old-template-metafunction-introducer + (make-parameter #f)) + +(define (syntax-local-template-metafunction-introduce stx) + (let ([mark (current-template-metafunction-introducer)] + [old-mark (old-template-metafunction-introducer)]) + (unless old-mark + (error 'syntax-local-template-metafunction-introduce + "must be called within the dynamic extent of a template metafunction")) + (mark (old-mark stx)))) + ;; ---- (define (stx-cadr x) (stx-car (stx-cdr x))) diff --git a/racket/collects/syntax/parse/experimental/template.rkt b/racket/collects/syntax/parse/experimental/template.rkt index aaaa599602..0cad7a1532 100644 --- a/racket/collects/syntax/parse/experimental/template.rkt +++ b/racket/collects/syntax/parse/experimental/template.rkt @@ -5,7 +5,8 @@ syntax/parse/private/minimatch racket/private/stx ;; syntax/stx racket/private/sc - racket/struct) + racket/struct + auto-syntax-e/utils) stxparse-info/parse/private/residual "private/substitute.rkt") (provide template @@ -13,8 +14,10 @@ quasitemplate quasitemplate/loc define-template-metafunction + syntax-local-template-metafunction-introduce ?? - ?@) + ?@ + (for-syntax template-metafunction?)) #| To do: @@ -91,7 +94,13 @@ A HeadTemplate (H) is one of: (define-syntax (quasitemplate stx) (syntax-case stx () [(quasitemplate t) - (do-template stx #'t #t #f)])) + (do-template stx #'t #t #f)] + [(quasitemplate t #:properties (prop ...)) + (andmap identifier? (syntax->list #'(prop ...))) + (parameterize ((props-to-serialize (syntax->datum #'(prop ...))) + (props-to-transfer (syntax->datum #'(prop ...)))) + ;; Same as above + (do-template stx #'t #t #f))])) (define-syntaxes (template/loc quasitemplate/loc) ;; FIXME: better to replace unsyntax form, shrink template syntax constant @@ -103,7 +112,16 @@ A HeadTemplate (H) is one of: (syntax-arm (with-syntax ([main-expr (do-template stx #'t quasi? #'loc-stx)]) #'(let ([loc-stx (handle-loc '?/loc loc-expr)]) - main-expr)))])))]) + main-expr)))] + [(?/loc loc-expr t #:properties (prop ...)) + (andmap identifier? (syntax->list #'(prop ...))) + (parameterize ((props-to-serialize (syntax->datum #'(prop ...))) + (props-to-transfer (syntax->datum #'(prop ...)))) + ;; Same as above + (syntax-arm + (with-syntax ([main-expr (do-template stx #'t quasi? #'loc-stx)]) + #'(let ([loc-stx (handle-loc '?/loc loc-expr)]) + main-expr))))])))]) (values (make-tx #f) (make-tx #t)))) (define (handle-loc who x) @@ -185,6 +203,10 @@ instead of integers and integer vectors. ;; ============================================================ + +;; TODO: once PR https://github.com/racket/racket/pull/1591 is merged, use +;; the exported prop:template-metafunction, template-metafunction? and +;; template-metafunction-accessor. (define-syntax (define-template-metafunction stx) (syntax-case stx () [(dsm (id arg ...) . body) @@ -229,7 +251,7 @@ instead of integers and integer vectors. (let*-values ([(drivers pre-guide props-guide) (parse-t t 0 #f)] [(drivers pre-guide) (if loc-id - (let* ([loc-sm (make-syntax-mapping 0 loc-id)] + (let* ([loc-sm (make-auto-pvar 0 loc-id)] [loc-pvar (pvar loc-sm #f #f)]) (values (dset-add drivers loc-pvar) (relocate-guide pre-guide loc-pvar))) @@ -410,7 +432,7 @@ instead of integers and integer vectors. (and (pair? v) (quotable? (car v)) (quotable? (cdr v))) (and (vector? v) (andmap quotable? (vector->list v))) (and (hash? v) (andmap quotable? (hash->list v))) - (and (prefab-struct-key v) (andmap quotable? (cdr (vector->list (struct->vector v))))))) + (and (prefab-struct-key v) (andmap quotable? (struct->list v))))) (define (cons-guide g1 g2) (if (and (eq? g1 '_) (eq? g2 '_)) '_ (cons g1 g2))) @@ -454,7 +476,7 @@ instead of integers and integer vectors. (cond [(box? qval) (with-syntax ([(tmp) (generate-temporaries #'(unsyntax-expr))]) (set-box! qval (cons (cons #'tmp t) (unbox qval))) - (let* ([fake-sm (make-syntax-mapping 0 #'tmp)] + (let* ([fake-sm (make-auto-pvar 0 #'tmp)] [fake-pvar (pvar fake-sm #f #f)]) (values (dset fake-pvar) (vector 'unsyntax fake-pvar) '_)))] [else @@ -586,7 +608,7 @@ instead of integers and integer vectors. (cond [(box? qval) (with-syntax ([(tmp) (generate-temporaries #'(unsyntax-splicing-expr))]) (set-box! qval (cons (cons #'tmp h) (unbox qval))) - (let* ([fake-sm (make-syntax-mapping 0 #'tmp)] + (let* ([fake-sm (make-auto-pvar 0 #'tmp)] [fake-pvar (pvar fake-sm #f #f)]) (values (dset fake-pvar) #t (vector 'unsyntax-splicing fake-pvar) '_)))] [else diff --git a/racket/collects/syntax/parse/private/parse.rkt b/racket/collects/syntax/parse/private/parse.rkt index 9e1652c87f..266d2bba44 100644 --- a/racket/collects/syntax/parse/private/parse.rkt +++ b/racket/collects/syntax/parse/private/parse.rkt @@ -414,7 +414,13 @@ Conventions: [_ (raise-syntax-error #f "expected exactly one template" #'ctx)])) ((body-sequence) (syntax-case rest () - [(e0 e ...) #'(let () e0 e ...)] + [(e0 e ...) + ;; Should we use a shadower (works on the whole file, unhygienically), + ;; or use the context of the syntax-parse identifier? + (let ([the-#%intdef-begin (datum->syntax #'ctx '#%intdef-begin)]) + (if (syntax-local-value the-#%intdef-begin (λ () #f)) ;; Defined as a macro + #`(let () (#,the-#%intdef-begin e0 e ...)) + #'(let () e0 e ...)))] [_ (raise-syntax-error #f "expected non-empty clause body" #'ctx clause)])) (else diff --git a/racket/collects/syntax/parse/private/residual.rkt b/racket/collects/syntax/parse/private/residual.rkt index d53cfb4661..beafc6709d 100644 --- a/racket/collects/syntax/parse/private/residual.rkt +++ b/racket/collects/syntax/parse/private/residual.rkt @@ -53,7 +53,9 @@ (require "runtime-progress.rkt" "3d-stx.rkt" - syntax/stx) + auto-syntax-e + syntax/stx + stxparse-info/current-pvars) (provide (all-from-out "runtime-progress.rkt") diff --git a/racket/collects/syntax/parse/private/runtime.rkt b/racket/collects/syntax/parse/private/runtime.rkt index 98764b189c..7b6cb1989b 100644 --- a/racket/collects/syntax/parse/private/runtime.rkt +++ b/racket/collects/syntax/parse/private/runtime.rkt @@ -1,11 +1,13 @@ #lang racket/base (require racket/stxparam stxparse-info/parse/private/residual ;; keep abs. path + stxparse-info/current-pvars (for-syntax racket/base racket/list syntax/kerncase syntax/strip-context racket/private/sc + auto-syntax-e/utils racket/syntax syntax/parse/private/rep-data)) @@ -100,9 +102,10 @@ residual.rkt. 'name 'depth 'syntax?)] ...) ([(vtmp) value] ...) (letrec-syntaxes+values - ([(name) (make-syntax-mapping 'depth (quote-syntax stmp))] ...) + ([(name) (make-auto-pvar 'depth (quote-syntax stmp))] ...) () - . body))))])) + (with-pvars (name ...) + . body)))))])) ;; (let-attributes* (([id num] ...) (expr ...)) expr) : expr ;; Special case: empty attrs need not match number of value exprs. @@ -136,8 +139,9 @@ residual.rkt. (make-attribute-mapping (quote-syntax vtmp) 'name 'depth 'syntax?)) ... - (define-syntax name (make-syntax-mapping 'depth (quote-syntax stmp))) - ...)))])) + (define-syntax name (make-auto-pvar 'depth (quote-syntax stmp))) + ... + (define-pvars name ...))))])) (define-syntax-rule (phase-of-enclosing-module) (variable-reference->module-base-phase -- 2.30.0