321 lines
15 KiB
Diff
321 lines
15 KiB
Diff
From 46475182cde225c1c222420bf72de9000ca79a07 Mon Sep 17 00:00:00 2001
|
|
From: Suzanne Soy <ligo@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
|
|
|