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

Fix issues with #:define-syntax-class and #:define-splicing-syntax-class

Browse Source
This commit is contained in:
Georges Dupéron 2016-09-26 01:22:55 +02:00
parent a8001c282b
commit 028e3fc1b7
1 changed files with 18 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -16,6 +16,7 @@
(for-meta 2 racket/list) (for-meta 2 racket/list)
(for-meta 2 racket/syntax) (for-meta 2 racket/syntax)
(for-meta 2 syntax/parse) (for-meta 2 syntax/parse)
(for-meta 2 syntax/parse/experimental/template)
(for-meta 2 phc-toolkit/untyped)) (for-meta 2 phc-toolkit/untyped))
(define-syntax/parse (define-syntax/parse+simple (define-syntax/parse (define-syntax/parse+simple
@ -34,21 +35,26 @@
(define-syntax (define/syntax-parse+simple stx) (define-syntax (define/syntax-parse+simple stx)
(syntax-parse stx (syntax-parse stx
[(_ (name:name-or-curry . args) [(_ (name:name-or-curry . args)
(~optional (~seq #:define-splicing-syntax-class define-class-name:id)) (~optional (~seq #:define-splicing-syntax-class define-splicing:id))
(~optional (~seq #:define-syntax-class define-class:id))
. body) . body)
(let () (let ()
(define introducer (make-syntax-introducer)) (define introducer (make-syntax-introducer))
(define/with-syntax args-stxclass (define/with-syntax args-stxclass
(or (attribute define-class-name) (or (attribute define-class)
(introducer (datum->syntax #'args 'args-stxclass) 'add))) (introducer (datum->syntax #'args 'args-stxclass) 'add)))
(define/with-syntax body-introduced (define/with-syntax body-introduced
(introducer #'body 'add)) (introducer #'body 'add))
#'(begin (template
(define-splicing-syntax-class args-stxclass (begin
(?? (define-splicing-syntax-class define-splicing
#:auto-nested-attributes #:auto-nested-attributes
(pattern (~seq . args))) (pattern {~seq . args})))
(define/syntax-parse+simple/stxclass [name args-stxclass] (define-syntax-class args-stxclass
. body-introduced)))])) #:auto-nested-attributes
(pattern args))
(define/syntax-parse+simple/stxclass [name . args-stxclass]
. body-introduced))))]))
(define-for-syntax (change-name-or-curry stx new-name) (define-for-syntax (change-name-or-curry stx new-name)
(if (identifier? stx) (if (identifier? stx)
@ -63,7 +69,7 @@
(define-syntax define/syntax-parse+simple/stxclass (define-syntax define/syntax-parse+simple/stxclass
(syntax-parser-with-arrows (syntax-parser-with-arrows
[(_ [name:name-or-curry [(_ [name:name-or-curry
(~var cls (static syntax/parse:stxclass? "a syntax class"))] . (~var cls (static syntax/parse:stxclass? "a syntax class"))]
. body) . body)
#:with colon-stxclass (format-id #'cls ":~a" #'cls) #:with colon-stxclass (format-id #'cls ":~a" #'cls)
#:with name-forward (format-id/record #'name.id #:with name-forward (format-id/record #'name.id
@ -88,7 +94,7 @@
(with-arrows (with-arrows
(syntax-parameterize ([stx (make-rename-transformer #'stx2)]) (syntax-parameterize ([stx (make-rename-transformer #'stx2)])
(syntax-parse stx2 (syntax-parse stx2
[(_ colon-stxclass) . body])))) [(_ . colon-stxclass) . body]))))
(define def-private-simple-api (define def-private-simple-api
(syntax-parameterize ([stx (make-rename-transformer #'stx/arg)]) (syntax-parameterize ([stx (make-rename-transformer #'stx/arg)])
(syntax-parse #'nothing (syntax-parse #'nothing