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

15
current-pvars.rkt
View File

@ -136,7 +136,7 @@
(void)) (void))
(let* ([pvars (reverse (syntax*->list (stx-car (stx-cdr stx))))] (let* ([pvars (reverse (syntax*->list (stx-car (stx-cdr stx))))]
[unique-at-runtime (map gensym (map syntax-e pvars))] [unique-at-runtime (map gensym (map syntax-e pvars))]
[stxquoted-pvars (map (λ (v unique) [stxquoted-pvars+unique (map (λ (v unique)
`(cons (quote-syntax ,v) `(cons (quote-syntax ,v)
(quote-syntax ,unique))) (quote-syntax ,unique)))
pvars pvars
@ -158,7 +158,7 @@
(quote-syntax here) (quote-syntax here)
`(let-values (,@do-unique-at-runtime) `(let-values (,@do-unique-at-runtime)
(letrec-syntaxes+values (letrec-syntaxes+values
([(,binding) (list* ,@stxquoted-pvars ([(,binding) (list* ,@stxquoted-pvars+unique
(try-nth-current-pvars ,old-pvars-index))] (try-nth-current-pvars ,old-pvars-index))]
[(,lower-bound-binding) ,(+ old-pvars-index 1)]) [(,lower-bound-binding) ,(+ old-pvars-index 1)])
() ()
@ -173,8 +173,13 @@
(syntax*->list (stx-cdr stx))))) (syntax*->list (stx-cdr stx)))))
(raise-syntax-error 'with-pvars "bad syntax" stx) (raise-syntax-error 'with-pvars "bad syntax" stx)
(void)) (void))
(let* ([pvars (syntax*->list (stx-cdr stx))] (let* ([pvars (reverse (syntax*->list (stx-cdr stx)))]
[quoted-pvars (reverse (map (λ (v) `(quote-syntax ,v)) pvars))] [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-index (find-last-current-pvars)]
[old-pvars (try-nth-current-pvars old-pvars-index)] [old-pvars (try-nth-current-pvars old-pvars-index)]
[binding (syntax-local-identifier-as-binding [binding (syntax-local-identifier-as-binding
@ -182,5 +187,5 @@
(datum->syntax (datum->syntax
(quote-syntax here) (quote-syntax here)
`(define-syntaxes (,binding) `(define-syntaxes (,binding)
(list* ,@quoted-pvars (list* ,@stxquoted-pvars+unique
(try-nth-current-pvars ,old-pvars-index)))))))) (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) (define-syntax (quasitemplate stx)
(syntax-case stx () (syntax-case stx ()
[(quasitemplate t) [(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) (define-syntaxes (template/loc quasitemplate/loc)
;; FIXME: better to replace unsyntax form, shrink template syntax constant ;; FIXME: better to replace unsyntax form, shrink template syntax constant
@ -104,7 +110,16 @@ A HeadTemplate (H) is one of:
(syntax-arm (syntax-arm
(with-syntax ([main-expr (do-template stx #'t quasi? #'loc-stx)]) (with-syntax ([main-expr (do-template stx #'t quasi? #'loc-stx)])
#'(let ([loc-stx (handle-loc '?/loc loc-expr)]) #'(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)))) (values (make-tx #f) (make-tx #t))))
(define (handle-loc who x) (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 ([my-valvar (quote-syntax x)])
(let-syntax ([my-pvar (make-syntax-mapping 0 (quote-syntax my-valvar))]) (let-syntax ([my-pvar (make-syntax-mapping 0 (quote-syntax my-valvar))])
(with-pvars (x) (with-pvars (x)
(get-current-pvars+unique)) (code:comment '([x . g123])) (get-current-pvars+unique)) (code:comment "'([x . g123])")
(with-pvars (x) (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 Under normal circumstances, @racket[with-pvars] @racket[define-pvars] should
be called immediately after binding the syntax pattern variable, but the code be called immediately after binding the syntax pattern variable, but the code