From edeae791ab736be7bb23239188382c8e11379d85 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Fri, 15 Feb 2019 12:13:23 +0100 Subject: [PATCH] syntax/parse: fix #:attr-name-separator, used by honu macros --- pkgs/racket-test/tests/stxparse/test.rkt | 9 +++++++++ .../syntax/parse/private/rep-patterns.rkt | 8 ++++---- racket/collects/syntax/parse/private/rep.rkt | 18 +++++++++--------- 3 files changed, 22 insertions(+), 13 deletions(-) diff --git a/pkgs/racket-test/tests/stxparse/test.rkt b/pkgs/racket-test/tests/stxparse/test.rkt index 4794b27c99..387652bbac 100644 --- a/pkgs/racket-test/tests/stxparse/test.rkt +++ b/pkgs/racket-test/tests/stxparse/test.rkt @@ -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)) diff --git a/racket/collects/syntax/parse/private/rep-patterns.rkt b/racket/collects/syntax/parse/private/rep-patterns.rkt index 04915c3718..2f8891ada5 100644 --- a/racket/collects/syntax/parse/private/rep-patterns.rkt +++ b/racket/collects/syntax/parse/private/rep-patterns.rkt @@ -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 diff --git a/racket/collects/syntax/parse/private/rep.rkt b/racket/collects/syntax/parse/private/rep.rkt index e60debac37..8a6e305c21 100644 --- a/racket/collects/syntax/parse/private/rep.rkt +++ b/racket/collects/syntax/parse/private/rep.rkt @@ -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)]