diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/utils.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/utils.rkt index f7786949..280def07 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/utils.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/utils.rkt @@ -8,6 +8,8 @@ (for-syntax racket/base syntax/parse racket/syntax) "../utils/utils.rkt" (utils tc-utils) + (only-in (utils literal-syntax-class) + [define-literal-syntax-class define-literal-syntax-class*]) (for-template racket/base) (types type-table utils subtype) (rep type-rep)) @@ -100,20 +102,9 @@ (pattern :literal #:with unsafe #'unsafe-id)))])) (define-syntax (define-literal-syntax-class stx) - (define-splicing-syntax-class spec - #:attributes (name (literals 1)) - (pattern (~seq name:id (literals:id ...))) - (pattern literal:id - #:with (literals ...) #'(literal) - #:with name (format-id #'literal "~a^" #'literal))) (syntax-parse stx - ((_ :spec) - #'(begin - (define-syntax-class name - #:commit - #:literals (literals ...) - (pattern (~and op (~or literals ...)) - #:do [(add-disappeared-use (syntax-local-introduce #'op))])))))) + [(_ . args) + #'(define-literal-syntax-class* #:for-template . args)])) (define-syntax-rule (define-merged-syntax-class name (syntax-classes ...)) (define-syntax-class name diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/literal-syntax-class.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/literal-syntax-class.rkt new file mode 100644 index 00000000..f77337c1 --- /dev/null +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/literal-syntax-class.rkt @@ -0,0 +1,44 @@ +#lang racket/base + +(require + "../utils/utils.rkt" + syntax/parse + (utils tc-utils) + (for-syntax + racket/base + racket/syntax + syntax/parse + unstable/sequence)) + +(provide define-literal-syntax-class) + + + +(define-syntax (define-literal-syntax-class stx) + (define-splicing-syntax-class spec + #:attributes (name (literals 1)) + (pattern (~seq name:id (literals:id ...))) + (pattern literal:id + #:with (literals ...) #'(literal) + #:with name (format-id #'literal "~a^" #'literal))) + (syntax-parse stx + ((_ phase-spec :spec) + ;; We need pattern ids that have the all have the same lexical context as the literal-set binding + (define add-context + (let ((introducer (make-syntax-introducer))) + (λ (sym) (introducer (datum->syntax #f sym))))) + (define/with-syntax literal-set (add-context 'lit-set)) + (define/with-syntax (pattern-literals ...) + (for/list ([_ (in-syntax #'(literals ...))] + [n (in-naturals)]) + (add-context (string->symbol (format "pat~a" n))))) + #'(begin + (define-literal-set literal-set phase-spec + ([pattern-literals literals] ...)) + + (define-syntax-class name + #:attributes () + #:commit + #:literal-sets ([literal-set]) + (pattern (~and op (~or pattern-literals ...)) + #:do [(add-disappeared-use (syntax-local-introduce #'op))]))))))