diff --git a/collects/syntax/parse/private/litconv.rkt b/collects/syntax/parse/private/litconv.rkt index 067b12195c..a0fa2fc554 100644 --- a/collects/syntax/parse/private/litconv.rkt +++ b/collects/syntax/parse/private/litconv.rkt @@ -64,13 +64,50 @@ (raise-syntax-error #f "expected phase-level (exact integer or #f)" ctx stx)) stx) +(define-for-syntax (check-litset-list stx ctx) + (syntax-case stx () + [(litset-id ...) + (for/list ([litset-id (syntax->list #'(litset-id ...))]) + (let* ([val (and (identifier? litset-id) + (syntax-local-value/record litset-id literalset?))]) + (if val + (cons litset-id val) + (raise-syntax-error #f "expected literal set name" ctx litset-id))))] + [_ (raise-syntax-error #f "expected list of literal set names" ctx stx)])) + +;; check-literal-entry/litset : stx stx -> (list id id) +(define-for-syntax (check-literal-entry/litset stx ctx) + (syntax-case stx () + [(internal external) + (and (identifier? #'internal) (identifier? #'external)) + (list #'internal #'external)] + [id + (identifier? #'id) + (list #'id #'id)] + [_ (raise-syntax-error #f "expected literal entry" ctx stx)])) + +(define-for-syntax (check-duplicate-literals stx imports lits) + (let ([lit-t (make-hasheq)]) ;; sym => #t + (define (check+enter! key blame-stx) + (when (hash-ref lit-t key #f) + (raise-syntax-error #f (format "duplicate literal: ~a" key) stx blame-stx)) + (hash-set! lit-t key #t)) + (for ([id+litset (in-list imports)]) + (let ([litset-id (car id+litset)] + [litset (cdr id+litset)]) + (for ([entry (in-list (literalset-literals litset))]) + (check+enter! (car entry) litset-id)))) + (for ([lit (in-list lits)]) + (check+enter! (syntax-e (car lit)) (car lit))))) + (define-syntax (define-literal-set stx) (syntax-case stx () [(define-literal-set name . rest) (let-values ([(chunks rest) (parse-keyword-options #'rest - `((#:phase ,check-phase-level) + `((#:literal-sets ,check-litset-list) + (#:phase ,check-phase-level) (#:for-template) (#:for-syntax) (#:for-label)) @@ -86,9 +123,13 @@ [else (options-select-value chunks '#:phase #:default 0)])] [lits (syntax-case rest () [( (lit ...) ) - (check-literals-list/litset #'(lit ...) stx)] - [_ (raise-syntax-error #f "bad syntax" stx)])]) + (for/list ([lit (in-list (syntax->list #'(lit ...)))]) + (check-literal-entry/litset lit stx))] + [_ (raise-syntax-error #f "bad syntax" stx)])] + [imports (options-select-value chunks '#:literal-sets #:default null)]) + (check-duplicate-literals stx imports lits) (with-syntax ([((internal external) ...) lits] + [(litset-id ...) (map car imports)] [relphase relphase]) #`(begin (define phase-of-literals @@ -97,13 +138,23 @@ 'relphase)) (define-syntax name (make-literalset - (list (list 'internal (quote-syntax external)) ...) - (quote-syntax phase-of-literals))) + (append (literalset-literals (syntax-local-value (quote-syntax litset-id))) + ... + (list (list 'internal + (quote-syntax external) + (quote-syntax phase-of-literals)) + ...)))) (begin-for-syntax/once (for ([x (in-list (syntax->list #'(external ...)))]) (unless (identifier-binding x 'relphase) (raise-syntax-error #f - (format "literal is unbound in phase ~a" 'relphase) + (format "literal is unbound in phase ~a~a" + 'relphase + (case 'relphase + ((1) " (for-syntax)") + ((-1) " (for-template)") + ((#f) " (for-label)") + (else ""))) (quote-syntax #,stx) x))))))))])) (define-syntax (phase-of-enclosing-module stx) diff --git a/collects/syntax/parse/private/rep-data.rkt b/collects/syntax/parse/private/rep-data.rkt index 9771cce103..50cf81f022 100644 --- a/collects/syntax/parse/private/rep-data.rkt +++ b/collects/syntax/parse/private/rep-data.rkt @@ -81,9 +81,9 @@ A ConventionRule is (list regexp DeclEntry) #| A LiteralSet is - (make-literalset (listof (list symbol id)) stx) + (make-literalset (listof (list symbol id phase-var-id))) |# -(define-struct literalset (literals phase) #:transparent) +(define-struct literalset (literals) #:transparent) ;; make-dummy-stxclass : identifier -> SC ;; Dummy stxclass for calculating attributes of recursive stxclasses. diff --git a/collects/syntax/parse/private/rep.rkt b/collects/syntax/parse/private/rep.rkt index 0d17af8303..47b73b8e42 100644 --- a/collects/syntax/parse/private/rep.rkt +++ b/collects/syntax/parse/private/rep.rkt @@ -57,9 +57,6 @@ [check-stxclass-application (-> syntax? syntax? (cons/c identifier? arguments?))] - [check-literals-list/litset - (-> syntax? syntax? - (listof (list/c identifier? identifier?)))] [check-conventions-rules (-> syntax? syntax? (listof (list/c regexp? any/c)))] @@ -1320,29 +1317,6 @@ A syntax class is integrable if (raise-syntax-error #f "expected literal entry" ctx stx)])) -;; Literal sets - Definition - -;; check-literals-list/litset : stx stx -> (listof (list id id)) -(define (check-literals-list/litset stx ctx) - (let ([lits (for/list ([x (in-list (stx->list stx))]) - (check-literal-entry/litset x ctx))]) - (let ([dup (check-duplicate-identifier (map car lits))]) - (when dup (raise-syntax-error #f "duplicate literal identifier" ctx dup))) - lits)) - -;; check-literal-entry/litset : stx stx -> (list id id) -(define (check-literal-entry/litset stx ctx) - (syntax-case stx () - [(internal external) - (and (identifier? #'internal) (identifier? #'external)) - (list #'internal #'external)] - [id - (identifier? #'id) - (list #'id #'id)] - [_ - (raise-syntax-error #f "expected literal entry" - ctx stx)])) - ;; Literal sets - Import ;; check-literal-sets-list : stx stx -> (listof (listof (list id id ct-phase^2))) @@ -1365,7 +1339,7 @@ A syntax class is integrable if (list (datum->syntax lctx (car entry) stx) (cadr entry) phase - (literalset-phase litset)))) + (caddr entry)))) (syntax-case stx () [(litset . more) (and (identifier? #'litset)) diff --git a/collects/syntax/scribblings/parse/litconv.scrbl b/collects/syntax/scribblings/parse/litconv.scrbl index 610c804bd9..0b38ffa916 100644 --- a/collects/syntax/scribblings/parse/litconv.scrbl +++ b/collects/syntax/scribblings/parse/litconv.scrbl @@ -15,20 +15,24 @@ As a remedy, @schememodname[syntax/parse] offers @deftech{literal sets}. A literal set is defined via @scheme[define-literal-set] and used via the @scheme[#:literal-set] option of @scheme[syntax-parse]. -@defform/subs[(define-literal-set name-id maybe-phase (literal ...)) +@defform/subs[(define-literal-set id maybe-phase maybe-imports (literal ...)) ([literal literal-id (pattern-id literal-id)] [maybe-phase (code:line) (code:line #:for-template) (code:line #:for-syntax) (code:line #:for-label) - (code:line #:phase phase-level)])]{ + (code:line #:phase phase-level)] + [maybe-imports (code:line) + (code:line #:literal-sets (imported-litset-id ...))])]{ -Defines @scheme[name] as a @tech{literal set}. Each @scheme[literal] -can have a separate @scheme[pattern-id] and @scheme[literal-id]. The +Defines @scheme[id] as a @tech{literal set}. Each @scheme[literal] can +have a separate @scheme[pattern-id] and @scheme[literal-id]. The @scheme[pattern-id] determines what identifiers in the pattern are treated as literals. The @scheme[literal-id] determines what -identifiers the literal matches. +identifiers the literal matches. If the @racket[#:literal-sets] option +is present, the contents of the given @racket[imported-litset-id]s are +included. @myexamples[ (define-literal-set def-litset diff --git a/collects/tests/stxparse/litset-phases.rkt b/collects/tests/stxparse/test-litset.rkt similarity index 68% rename from collects/tests/stxparse/litset-phases.rkt rename to collects/tests/stxparse/test-litset.rkt index 988dd56987..8f05235165 100644 --- a/collects/tests/stxparse/litset-phases.rkt +++ b/collects/tests/stxparse/test-litset.rkt @@ -1,30 +1,10 @@ -#lang scheme +#lang racket/base (require syntax/parse syntax/parse/debug rackunit "setup.rkt") (require (for-syntax syntax/parse)) -#| -(module a racket - (require syntax/parse) - (define-literal-set lits (begin)) - (provide lits)) -(module b racket - (require (for-syntax 'a syntax/parse)) - (require (for-syntax syntax/parse/private/runtime)) - (define-syntax (snarf stx) - ;;(printf "slpl of snarf: ~s\n" (syntax-local-phase-level)) - (syntax-parse stx - #:literal-sets (lits) - [(snarf (begin e)) #'e])) - (provide snarf)) -(module c racket - (require (for-syntax 'b racket/base)) - (begin-for-syntax - (displayln (snarf (begin 5))))) -|# - (define-literal-set lits0 #:phase 0 (define lambda)) @@ -87,3 +67,33 @@ '(b)) ;; check that passed lambda is not a literal, but a pattern variable: (check-equal? (syntax->datum (getvar lambda #'(lambda b c)))))) + +;; Litset extension + +(tcerr "litset ext, dup 1" + (let () + (define-literal-set lits1 (define)) + (define-literal-set lits2 #:literal-sets (lits1) (define)) + (void))) + +(tcerr "litset ext, dup 2" + (let () + (define-literal-set lits1 (define)) + (define-literal-set lits2 (define)) + (define-literal-set lits3 #:literal-sets (lits1 lits2) ()) + (void))) + +(test-case "litset ext, works" + (let () + (define-literal-set lits1 (define)) + (define-literal-set lits2 #:literal-sets (lits1) (lambda)) + (define (go x exp) + (check-equal? (syntax-parse x #:literal-sets (lits2) + [lambda 'lambda] + [define 'define] + [_ #f]) + exp)) + (go #'lambda 'lambda) + (go #'define 'define) + (go #'begin #f) + (void)))