diff --git a/collects/syntax/parse/private/litconv.rkt b/collects/syntax/parse/private/litconv.rkt index 5d1e8e3acb..4a29f83613 100644 --- a/collects/syntax/parse/private/litconv.rkt +++ b/collects/syntax/parse/private/litconv.rkt @@ -10,6 +10,7 @@ "runtime.rkt") (provide define-conventions define-literal-set + literal-set->predicate kernel-literals) (define-syntax (define-conventions stx) @@ -181,6 +182,24 @@ Use cases, explained: (that's why the weird (if (z?) 0 1) term) |# +;; FIXME: keep one copy of each identifier (?) + +(define-syntax (literal-set->predicate stx) + (syntax-case stx () + [(literal-set->predicate litset-id) + (let ([val (and (identifier? #'litset-id) + (syntax-local-value/record #'litset-id literalset?))]) + (unless val (raise-syntax-error #f "expected literal set name" stx #'litset-id)) + (let ([lits (literalset-literals val)]) + (with-syntax ([((_sym lit phase-var) ...) lits]) + #'(make-literal-set-predicate (list (list (quote-syntax lit) phase-var) ...)))))])) + +(define (make-literal-set-predicate 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=?/phases x phase lit-id lit-phase))))) ;; Literal sets diff --git a/collects/syntax/scribblings/parse/litconv.scrbl b/collects/syntax/scribblings/parse/litconv.scrbl index 0b38ffa916..27ca3db59c 100644 --- a/collects/syntax/scribblings/parse/litconv.scrbl +++ b/collects/syntax/scribblings/parse/litconv.scrbl @@ -93,6 +93,24 @@ whose binding at phase 1 is the @scheme[x] from module @schememodname['common]. } +@defform[(literal-set->predicate litset-id)]{ + +Given the name of a literal set, produces a predicate that recognizes +identifiers in the literal set. The predicate takes one required +argument, an identifier @racket[_id], and one optional argument, the +phase @racket[_phase] at which to examine the binding of @racket[_id]; +the @racket[_phase] argument defaults to +@racket[(syntax-local-phase-level)]. + +@myexamples[ +(define kernel? (literal-set->predicate kernel-literals)) +(kernel? #'lambda) +(kernel? #'#%plain-lambda) +(kernel? #'define-values) +(kernel? #'define-values 4) +] +} + @defform/subs[(define-conventions name-id convention-rule ...) ([convention-rule (name-pattern syntax-class)] [name-pattern exact-id diff --git a/collects/tests/stxparse/test-litset.rkt b/collects/tests/stxparse/test-litset.rkt index 8f05235165..40bf0b5af3 100644 --- a/collects/tests/stxparse/test-litset.rkt +++ b/collects/tests/stxparse/test-litset.rkt @@ -3,7 +3,6 @@ syntax/parse/debug rackunit "setup.rkt") -(require (for-syntax syntax/parse)) (define-literal-set lits0 #:phase 0 (define lambda)) @@ -97,3 +96,14 @@ (go #'define 'define) (go #'begin #f) (void))) + +(require (for-label '#%kernel)) + +(test-case "litset->pred" + (let ([kernel? (literal-set->predicate kernel-literals)]) + (check-equal? (kernel? #'#%plain-lambda) #t) + (check-equal? (kernel? #'define-values) #t) + (check-equal? (kernel? #'define-values #f) #t) + (check-equal? (kernel? #'define-values 4) #f) + (check-equal? (kernel? #'foo) #f) + (void)))