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

Preserve syntax-original?-ness and syntax properties from splicing forms (#1413)

Browse Source 
This makes two changes to the forms in racket/splicing to adjust how
syntax properties are propagated through expansion:

  1. Uses of make-syntax-introducer are passed #t as the first argument,
     which causes the introduced scope to be consider a use-site rather
     than macro-introduction scope. This prevents syntax objects from
     being unnecessarily marked as unoriginal, in the syntax-original?
     sense.

  2. Uses of syntax/loc have been adjusted to copy syntax properties
     from original syntax objects, which were previously discared. Forms
     that were spliced into the surrounding context, such as begin,
     define-values, and define-syntaxes, recreated the top-level syntax
     objects, which did not preserve syntax properties from the
     originals.

This is not a perfect solution, mostly because it potentially elides
properties that may be associated with captured literals (that is,
properties attached directly to begin, define-values, or define-syntaxes
identifiers themselves). However, it seems to accommodate most of the
common use-cases: propagation of syntax-original?-ness and forms like
`struct`, which attach properties like 'sub-range-binders.

fixes #1410
This commit is contained in:
Alexis King 2016-08-19 05:33:20 -07:00 committed by Matthew Flatt
parent 8df0d6bba3
commit 0b21818100
2 changed files with 51 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
pkgs/racket-test-core/tests/racket/syntax.rktl
View File

@ -1643,6 +1643,23 @@
(define-syntax (m stx) id)
(m))))
(test 'prop-value 'splicing+syntax-property
(eval
'(begin
(define-syntax (define-syntaxes/prop stx)
(syntax-case stx ()
[(_ . body)
(syntax-property #'(define-syntaxes . body) 'some-prop 'prop-value)]))
(define-syntax (inspect-prop stx)
(syntax-case stx ()
[(_ form)
(syntax-case (local-expand #'form (syntax-local-context) '()) ()
[(_ definition)
(with-syntax ([prop-value (syntax-property #'definition 'some-prop)])
#''prop-value)])]))
(inspect-prop (splicing-let ()
(define-syntaxes/prop [] (values)))))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Check keyword & optionals for define-syntax
;; and define-syntax-for-values:

50
racket/collects/racket/splicing.rkt
View File

@ -21,6 +21,24 @@
splicing-local
splicing-syntax-parameterize)
(module syntax/loc/props racket/base
(require (for-syntax racket/base))
(provide syntax/loc/props quasisyntax/loc/props)
(define-syntaxes [syntax/loc/props quasisyntax/loc/props]
(let ()
(define (mk-syntax/loc/props syntax-id)
(λ (stx)
(syntax-case stx ()
[(_ src-expr template)
#`(let ([src src-expr])
(datum->syntax (quote-syntax #,stx) (syntax-e (#,syntax-id template)) src src))])))
(values (mk-syntax/loc/props #'syntax)
(mk-syntax/loc/props #'quasisyntax)))))
(require (for-syntax 'syntax/loc/props)
(for-meta 2 'syntax/loc/props))
(define-syntax (splicing-local stx)
(do-local stx (lambda (def-ctx expand-context sbindings vbindings bodys)
(if (eq? 'expression (syntax-local-context))
@ -31,7 +49,7 @@
#,@bodys))
;; Since we alerady have bindings for the current scopes,
;; add an extra scope for re-binding:
(let ([i (make-syntax-introducer)])
(let ([i (make-syntax-introducer #t)])
(with-syntax ([([s-ids s-rhs] ...) (i sbindings)]
[([(v-id ...) v-rhs] ...) (i vbindings)]
[(body ...) (i bodys)]
@ -98,7 +116,7 @@
[rec? rec?]
[(marked-id markless-id)
(let ([id #'id])
(list ((make-syntax-introducer) id)
(list ((make-syntax-introducer #t) id)
id))])
(with-syntax ([(top-decl ...)
(if (and need-top-decl? (equal? 'top-level (syntax-local-context)))
@ -152,16 +170,16 @@
#%provide
#%declare)
[(begin form ...)
(syntax/loc body
(syntax/loc/props body
(begin (splicing-let-body marked-id markless-id form) ...))]
[(define-values ids rhs)
(quasisyntax/loc body
(quasisyntax/loc/props body
(define-values #,(map (maybe unintro) (syntax->list #'ids)) rhs))]
[(define-syntaxes ids rhs)
(quasisyntax/loc body
(quasisyntax/loc/props body
(define-syntaxes #,(map (maybe unintro) (syntax->list #'ids)) rhs))]
[(begin-for-syntax e ...)
(syntax/loc body
(syntax/loc/props body
(begin-for-syntax (splicing-let-body/et marked-id markless-id e) ...))]
[(module . _) (unintro body)]
[(module* . _) body]
@ -192,13 +210,13 @@
#%provide
#%declare)
[(begin form ...)
(syntax/loc body
(syntax/loc/props body
(begin (splicing-let-body/et marked-id markless-id form) ...))]
[(define-values ids rhs)
(quasisyntax/loc body
(quasisyntax/loc/props body
(define-values #,(map (maybe unintro) (syntax->list #'ids)) rhs))]
[(define-syntaxes ids rhs)
(quasisyntax/loc body
(quasisyntax/loc/props body
(define-syntaxes #,(map (maybe unintro) (syntax->list #'ids)) rhs))]
[(begin-for-syntax . es)
;; Give up on splicing definitions at phase level 2 and deeper:
@ -249,7 +267,7 @@
(with-syntax ([((vid ...) ...) all-vids]
[(marked-id markless-id)
(let ([id #'id])
(list ((make-syntax-introducer) id)
(list ((make-syntax-introducer #t) id)
id))])
(with-syntax ([(top-decl ...)
(if (equal? 'top-level (syntax-local-context))
@ -311,18 +329,18 @@
#%provide
#%declare )
[(begin expr ...)
(syntax/loc body
(syntax/loc/props body
(begin (expand-ssp-body (sp-id ...) (temp-id ...) (orig-id ...) expr) ...))]
[(define-values (id ...) rhs)
(syntax/loc body
(syntax/loc/props body
(define-values (id ...)
(letrec-syntaxes ([(sp-id) (syntax-local-value (quote-syntax temp-id))] ...)
rhs)))]
[(define-syntaxes ids rhs)
(syntax/loc body
(syntax/loc/props body
(define-syntaxes ids (wrap-param-et rhs (orig-id ...) (temp-id ...))))]
[(begin-for-syntax e ...)
(syntax/loc body
(syntax/loc/props body
(begin-for-syntax (wrap-param-et e (orig-id ...) (temp-id ...)) ...))]
[(module . _) body]
[(module* . _) body]
@ -382,12 +400,12 @@
#%require #%provide #%declare
quote-syntax)
[(begin form ...)
(syntax/loc e
(syntax/loc/props e
(begin (wrap-param-et form (orig-id ...) (temp-id ...)) ...))]
[(define-syntaxes . _) e]
[(begin-for-syntax . _) e]
[(define-values ids rhs)
(syntax/loc e
(syntax/loc/props e
(define-values ids (wrap-param-et rhs (orig-id ...) (temp-id ...))))]
[(module . _) e]
[(module* . _) e]