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

syntax/parse: fix #:attr-name-separator, used by honu macros

Browse Source
This commit is contained in:
Ryan Culpepper 2019-02-15 12:13:23 +01:00
parent 30e260835f
commit edeae791ab
3 changed files with 22 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
pkgs/racket-test/tests/stxparse/test.rkt
View File

@ -986,3 +986,12 @@
#'(define (f.x) ths)]))
(object 1)
(void)))
;; from William Hatch (2/2019) re honu macros
(let ()
(define-syntax-class thing (pattern x #:with a #'okay))
(check-equal?
(syntax->datum
(syntax-parse #'bad
[(~var y thing #:attr-name-separator "_") #'y_a]))
'okay))

8
racket/collects/syntax/parse/private/rep-patterns.rkt
View File

@ -35,7 +35,7 @@ A SinglePattern is one of
(pat:ord SinglePattern UninternedSymbol Nat)
(pat:post SinglePattern)
(pat:integrated id/#f id string stx)
* (pat:fixup Syntax Identifier/#f Identifier Identifier Arguments Syntax/#f Id/#f)
* (pat:fixup Syntax Identifier/#f Identifier Identifier Arguments String Syntax/#f Id/#f)
* (pat:and/fixup Syntax (Listof *Pattern))
A ListPattern is a subtype of SinglePattern; one of
@ -68,7 +68,7 @@ A ListPattern is a subtype of SinglePattern; one of
(define-struct pat:ord (pattern group index) #:prefab)
(define-struct pat:post (pattern) #:prefab)
(define-struct pat:integrated (name predicate description role) #:prefab)
(define-struct pat:fixup (stx bind varname scname argu role parser*) #:prefab)
(define-struct pat:fixup (stx bind varname scname argu sep role parser*) #:prefab)
(define-struct pat:and/fixup (stx patterns) #:prefab)
#|
@ -265,7 +265,7 @@ A RepConstraint is one of
(pattern-attrs sp)]
[(pat:integrated name _ _ _)
(if name (list (attr name 0 #t)) null)]
[(pat:fixup _ bind _ _ _ _ _)
[(pat:fixup _ bind _ _ _ _ _ _)
(if bind (list (attr bind 0 #t)) null)]
[(pat:and/fixup _ ps)
(append-iattrs (map pattern-attrs ps))]
@ -352,7 +352,7 @@ A RepConstraint is one of
[(pat:ord sp _ _) (pattern-has-cut? sp)]
[(pat:post sp) (pattern-has-cut? sp)]
[(pat:integrated name _ _ _) #f]
[(pat:fixup _ _ _ _ _ _ _) #t]
[(pat:fixup _ _ _ _ _ _ _ _) #t]
[(pat:and/fixup _ ps) (ormap pattern-has-cut? ps)]
;; -- A patterns

18
racket/collects/syntax/parse/private/rep.rkt
View File

@ -696,7 +696,7 @@
(define entry (declenv-lookup decls suffix))
(cond [(or (den:lit? entry) (den:datum-lit? entry))
(pat:and (list (pat:svar name) (parse-pat:id/entry id allow-head? entry)))]
[else (parse-stxclass-use id allow-head? name suffix no-arguments #f)])])]
[else (parse-stxclass-use id allow-head? name suffix no-arguments "." #f)])])]
[(declenv-apply-conventions decls id)
=> (lambda (entry) (parse-pat:id/entry id allow-head? entry))]
[else (pat:svar id)]))
@ -733,13 +733,13 @@
[(den:datum-lit internal sym)
(pat:datum sym)]
[(den:magic-class name scname argu role)
(parse-stxclass-use scname allow-head? id scname argu role)]
(parse-stxclass-use scname allow-head? id scname argu "." role)]
[(den:class _n _c _a)
(error 'parse-pat:id
"(internal error) decls had leftover stxclass entry: ~s"
entry)]
[(den:delayed parser scname)
(parse-stxclass-use id allow-head? id scname no-arguments #f parser)]))
(parse-stxclass-use id allow-head? id scname no-arguments "." #f parser)]))
(define (parse-pat:var stx decls allow-head?)
(define name0
@ -773,21 +773,21 @@
[(and (wildcard? name0) (not scname))
(pat:any)]
[scname
(parse-stxclass-use stx allow-head? name0 scname argu role)]
(parse-stxclass-use stx allow-head? name0 scname argu pfx role)]
[else ;; Just proper name
(pat:svar name0)]))
;; ----
(define (parse-stxclass-use stx allow-head? varname scname argu role [parser* #f])
(define (parse-stxclass-use stx allow-head? varname scname argu pfx role [parser* #f])
(cond [(and (memq (stxclass-lookup-config) '(yes try)) (get-stxclass scname #t))
=> (lambda (sc)
(unless parser*
(check-stxclass-arity sc stx (length (arguments-pargs argu)) (arguments-kws argu)))
(parse-stxclass-use* stx allow-head? varname sc argu "." role parser*))]
(parse-stxclass-use* stx allow-head? varname sc argu pfx role parser*))]
[(memq (stxclass-lookup-config) '(try no))
(define bind (name->bind varname))
(pat:fixup stx bind varname scname argu role parser*)]
(pat:fixup stx bind varname scname argu pfx role parser*)]
[else (wrong-syntax scname "not defined as syntax class (config=~s)"
;; XXX FIXME
(stxclass-lookup-config))]))
@ -1255,8 +1255,8 @@
(define (fixup p allow-head?)
(define (I p) (fixup p allow-head?))
(match p
[(pat:fixup stx bind varname scname argu role parser*)
(parse-stxclass-use stx allow-head? varname scname argu role parser*)]
[(pat:fixup stx bind varname scname argu pfx role parser*)
(parse-stxclass-use stx allow-head? varname scname argu pfx role parser*)]
;; ----
;; [(pat:any)
;; (pat:any)]