suzanne.soy/stxparse-info
1
0
Fork 0
Code Issues 1 Pull Requests Actions Packages Projects Releases Wiki Activity

Support #:properties on all four of (quasi)template(/loc), instead of just template.

Browse Source
This commit is contained in:
Georges Dupéron 2017-01-26 05:27:34 +01:00
parent de60a419e2
commit ad27231d00
3 changed files with 34 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
current-pvars.rkt
View File

@ -136,11 +136,11 @@
(void))
(let* ([pvars (reverse (syntax*->list (stx-car (stx-cdr stx))))]
[unique-at-runtime (map gensym (map syntax-e pvars))]
[stxquoted-pvars (map (λ (v unique)
`(cons (quote-syntax ,v)
(quote-syntax ,unique)))
pvars
unique-at-runtime)]
[stxquoted-pvars+unique (map (λ (v unique)
`(cons (quote-syntax ,v)
(quote-syntax ,unique)))
pvars
unique-at-runtime)]
[body (stx-cdr (stx-cdr stx))]
[old-pvars-index (find-last-current-pvars)]
[old-pvars (try-nth-current-pvars old-pvars-index)]
@ -158,10 +158,10 @@
(quote-syntax here)
`(let-values (,@do-unique-at-runtime)
(letrec-syntaxes+values
([(,binding) (list* ,@stxquoted-pvars
([(,binding) (list* ,@stxquoted-pvars+unique
(try-nth-current-pvars ,old-pvars-index))]
[(,lower-bound-binding) ,(+ old-pvars-index 1)])
()
()
. ,body))))))
(define-syntaxes (define-pvars)
@ -173,8 +173,13 @@
(syntax*->list (stx-cdr stx)))))
(raise-syntax-error 'with-pvars "bad syntax" stx)
(void))
(let* ([pvars (syntax*->list (stx-cdr stx))]
[quoted-pvars (reverse (map (λ (v) `(quote-syntax ,v)) pvars))]
(let* ([pvars (reverse (syntax*->list (stx-cdr stx)))]
[unique-at-runtime (map gensym (map syntax-e pvars))]
[stxquoted-pvars+unique (map (λ (v unique)
`(cons (quote-syntax ,v)
(quote-syntax ,unique)))
pvars
unique-at-runtime)]
[old-pvars-index (find-last-current-pvars)]
[old-pvars (try-nth-current-pvars old-pvars-index)]
[binding (syntax-local-identifier-as-binding
@ -182,5 +187,5 @@
(datum->syntax
(quote-syntax here)
`(define-syntaxes (,binding)
(list* ,@quoted-pvars
(list* ,@stxquoted-pvars+unique
(try-nth-current-pvars ,old-pvars-index))))))))

19
parse/experimental/template.rkt
View File

@ -92,7 +92,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
@ -104,7 +110,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)

4
scribblings/stxparse-info.scrbl
View File

@ -115,9 +115,9 @@ track which syntax or datum pattern variables are bound.
(let ([my-valvar (quote-syntax x)])
(let-syntax ([my-pvar (make-syntax-mapping 0 (quote-syntax my-valvar))])
(with-pvars (x)
(get-current-pvars+unique)) (code:comment '([x . g123]))
(get-current-pvars+unique)) (code:comment "'([x . g123])")
(with-pvars (x)
(get-current-pvars+unique)))) (code:comment '([x . g124]))]
(get-current-pvars+unique)))) (code:comment "'([x . g124])")]
Under normal circumstances, @racket[with-pvars] @racket[define-pvars] should
be called immediately after binding the syntax pattern variable, but the code