suzanne.soy/extensible-parser-specifications
1
0
Fork 0
Code Issues 2 Pull Requests Actions Packages Projects Releases Wiki Activity

Fix for 6.4 and 6.5 where with-disappeared-uses does not allow multiple body statements.

Browse Source
This commit is contained in:
Georges Dupéron 2016-08-29 23:16:57 +02:00
parent 6475b89bc8
commit 468495937c
1 changed files with 34 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

66
private/define-syntax+simple-api.rkt
View File

@ -33,35 +33,37 @@
#:with colon-stxclass (format-id #'cls ":~a" #'cls) #:with colon-stxclass (format-id #'cls ":~a" #'cls)
#:with name-forward (format-id #'name "~a-forward-attributes" #'name) #:with name-forward (format-id #'name "~a-forward-attributes" #'name)
(with-disappeared-uses (with-disappeared-uses
(define c (syntax-local-value/record #'cls syntax/parse:stxclass?)) (let ()
(define attrs (syntax/parse:stxclass-attrs c)) (define c (syntax-local-value/record #'cls syntax/parse:stxclass?))
(define/with-syntax (attr-name …) (map syntax/parse:attr-name attrs)) (define attrs (syntax/parse:stxclass-attrs c))
(define/with-syntax (attr-name/ctx …) (define/with-syntax (attr-name …) (map syntax/parse:attr-name attrs))
(stx-map (λ (a) (datum->syntax #'body (syntax-e a))) (define/with-syntax (attr-name/ctx …)
#'(attr-name …))) (stx-map (λ (a) (datum->syntax #'body (syntax-e a)))
(define-temp-ids "~a/arg" (attr-name …)) #'(attr-name …)))
(define/with-syntax (attr-depth …) (map syntax/parse:attr-depth attrs)) (define-temp-ids "~a/arg" (attr-name …))
#'(begin (define/with-syntax (attr-depth …)
(define (name stx2) (map syntax/parse:attr-depth attrs))
(syntax-parameterize ([stx (make-rename-transformer #'stx2)]) #'(begin
(syntax-parse stx2 (define (name stx2)
[(name colon-stxclass) . body]))) (syntax-parameterize ([stx (make-rename-transformer #'stx2)])
(define (private-simple-api stx/arg attr-name/arg …) (syntax-parse stx2
(syntax-parameterize ([stx (make-rename-transformer #'stx/arg)]) [(name colon-stxclass) . body])))
(syntax-parse #'nothing (define (private-simple-api stx/arg attr-name/arg …)
[(~bind [(attr-name/ctx attr-depth) attr-name/arg] …) (syntax-parameterize ([stx (make-rename-transformer #'stx/arg)])
. body]))) (syntax-parse #'nothing
(define-syntax (name-forward stx3) [(~bind [(attr-name/ctx attr-depth) attr-name/arg] …)
(syntax-case stx3 () . body])))
[(_) (define-syntax (name-forward stx3)
#`(private-simple-api (syntax-case stx3 ()
stx [(_)
(attribute #,(datum->syntax stx3 'attr-name)) #`(private-simple-api
…)] stx
[(_ forward-args-prefix) (attribute #,(datum->syntax stx3 'attr-name))
#`(private-simple-api …)]
stx [(_ forward-args-prefix)
(attribute #,(format-id stx3 "~a.~a" #`(private-simple-api
#'forward-args-prefix stx
'attr-name)) (attribute #,(format-id stx3 "~a.~a"
…)]))))]))) #'forward-args-prefix
'attr-name))
…)])))))])))