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

syntax/parse: fix literal-set->predicate and datum-literals

Browse Source
This commit is contained in:
Ryan Culpepper 2016-11-16 18:58:13 -05:00
parent 85eee2bbbc
commit f1128cca97
2 changed files with 23 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
pkgs/racket-test/tests/stxparse/test-litset.rkt
View File

@ -99,13 +99,19 @@
;; Litsets with datum-lits
(test-case "litset, datum-lits"
(let ([one 1])
(define-literal-set lits-d #:datum-literals (one two) ())
(let ([one 1])
(define-literal-set lits-d #:datum-literals (one two) ())
(test-case "litset, datum-lits"
(syntax-parse #'one #:literal-sets (lits-d)
[one (void)])
(let ([one 2])
(syntax-parse #'one #:literal-sets (lits-d) [one (void)]))))
(syntax-parse #'one #:literal-sets (lits-d) [one (void)])))
(test-case "litset->predicate, datum-lits"
(define lit? (literal-set->predicate lits-d))
(check-equal? (lit? #'one) #t)
(check-equal? (lit? #'one 1) #t)
(check-equal? (lit? #'apple) #f)))
;; literal-set->predicate

20
racket/collects/syntax/parse/private/litconv.rkt
View File

@ -240,15 +240,21 @@ cause an error, so don't worry about that case.)
(with-syntax ([((lit phase-var) ...)
(for/list ([lit (in-list lits)]
#:when (lse:lit? lit))
(list (lse:lit-external lit) (lse:lit-phase lit)))])
#'(make-literal-set-predicate (list (list (quote-syntax lit) phase-var) ...)))))]))
(list (lse:lit-external lit) (lse:lit-phase lit)))]
[(datum-lit ...)
(for/list ([lit (in-list lits)]
#:when (lse:datum-lit? lit))
(lse:datum-lit-external lit))])
#'(make-literal-set-predicate (list (list (quote-syntax lit) phase-var) ...)
'(datum-lit ...)))))]))
(define (make-literal-set-predicate lits)
(define (make-literal-set-predicate lits datum-lits)
(lambda (x [phase (syntax-local-phase-level)])
(for/or ([lit (in-list lits)])
(let ([lit-id (car lit)]
[lit-phase (cadr lit)])
(free-identifier=? x lit-id phase lit-phase)))))
(or (for/or ([lit (in-list lits)])
(let ([lit-id (car lit)]
[lit-phase (cadr lit)])
(free-identifier=? x lit-id phase lit-phase)))
(and (memq (syntax-e x) datum-lits) #t))))
;; Literal sets