From f42adad3f8f19ccda8dd9ae5adad31d4dab19b79 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Thu, 29 Apr 2010 10:58:04 -0600 Subject: [PATCH] syntax/parse: allow phase spec for literals --- collects/syntax/private/stxparse/parse.rkt | 26 ++--- collects/syntax/private/stxparse/rep-data.rkt | 18 ++-- .../syntax/private/stxparse/rep-patterns.rkt | 8 +- collects/syntax/private/stxparse/rep.rkt | 99 ++++++++++++------- collects/syntax/private/stxparse/runtime.rkt | 9 ++ collects/syntax/private/stxparse/sc.rkt | 18 +++- collects/syntax/private/util/txlift.ss | 53 ++++++++++ 7 files changed, 171 insertions(+), 60 deletions(-) create mode 100644 collects/syntax/private/util/txlift.ss diff --git a/collects/syntax/private/stxparse/parse.rkt b/collects/syntax/private/stxparse/parse.rkt index 3bb3e9e959..5fe7b1fdb9 100644 --- a/collects/syntax/private/stxparse/parse.rkt +++ b/collects/syntax/private/stxparse/parse.rkt @@ -8,6 +8,7 @@ "rep-data.ss" "rep.ss" "codegen-data.ss" + "../util/txlift.ss" "../util.ss") scheme/stxparam scheme/list @@ -158,7 +159,8 @@ (syntax-case stx () [(parse:clauses x clauses ctx) (with-disappeared-uses - (let () + (with-txlifts + (lambda () (define-values (chunks clauses-stx) (parse-keyword-options #'clauses parse-directive-table #:context #'ctx @@ -191,19 +193,13 @@ (clause-success () (let () . rest)))))))])) (unless (and (stx-list? clauses-stx) (stx-pair? clauses-stx)) (raise-syntax-error #f "expected non-empty sequence of clauses" #'ctx)) - (with-syntax ([(def ...) defs] + (with-syntax ([(def ...) (append (get-txlifts-as-definitions) defs)] [(alternative ...) (map for-clause (stx->list clauses-stx))]) #`(let ([fail (syntax-patterns-fail #,context)]) def ... (with-enclosing-fail* fail - (try alternative ...))))))])) - -(define-for-syntax (wash-literal stx) - (syntax-case stx () - [(a b) (list #'a #'b)])) -(define-for-syntax (wash-literals stx) - (wash-list wash-literal stx)) + (try alternative ...)))))))])) ;; (clause-success (IAttr ...) expr) : expr (define-syntax (clause-success stx) @@ -262,12 +258,20 @@ (fail x #:expect (expectation pattern0) #:fce fc)))] - [#s(pat:literal attrs literal) + [#s(pat:literal attrs literal #f) #`(if (and (identifier? x) (free-identifier=? x (quote-syntax literal))) k (fail x #:expect (expectation pattern0) #:fce fc))] + [#s(pat:literal attrs literal phase) + #`(if (and (identifier? x) + (free-identifier=? x (quote-syntax literal) + (phase+ (syntax-local-phase-level) phase))) + k + (fail x + #:expect (expectation pattern0) + #:fce fc))] [#s(pat:ghost attrs ghost subpattern) #'(parse:G x fc ghost (parse:S x fc subpattern k))] [#s(pat:head attrs head tail) @@ -625,7 +629,7 @@ [(_ #s(pat:datum attrs d)) #'(begin (collect-error '(datum d)) (make-expect:atom 'd))] - [(_ #s(pat:literal attrs lit)) + [(_ #s(pat:literal attrs lit phase)) #'(begin (collect-error '(literal lit)) (make-expect:literal (quote-syntax lit)))] ;; 2 pat:compound patterns diff --git a/collects/syntax/private/stxparse/rep-data.rkt b/collects/syntax/private/stxparse/rep-data.rkt index 1f99826c31..607f35588c 100644 --- a/collects/syntax/private/stxparse/rep-data.rkt +++ b/collects/syntax/private/stxparse/rep-data.rkt @@ -92,7 +92,7 @@ A ConventionRule is (list regexp DeclEntry) #| A LiteralSet is - (make-literalset (listof (list symbol id))) + (make-literalset (listof (list symbol id ct-phase))) |# (define-struct literalset (literals) #:transparent) @@ -110,14 +110,14 @@ DeclEnv = (listof ConventionRule)) DeclEntry = - (make-den:lit id id) + (make-den:lit id id ct-phase) (make-den:class id id (listof syntax) bool) (make-den:parser id id (listof SAttr) bool bool) (make-den:delayed id id id) |# (define-struct declenv (table conventions)) -(define-struct den:lit (internal external)) +(define-struct den:lit (internal external phase)) (define-struct den:class (name class args)) (define-struct den:parser (parser description attrs splicing? commit?)) (define-struct den:delayed (parser description class)) @@ -127,7 +127,7 @@ DeclEntry = (for/fold ([table (make-immutable-bound-id-table)]) ([literal literals]) (bound-id-table-set table (car literal) - (make den:lit (car literal) (cadr literal)))) + (make den:lit (car literal) (cadr literal) (caddr literal)))) conventions)) (define (declenv-lookup env id #:use-conventions? [use-conventions? #t]) @@ -141,7 +141,7 @@ DeclEntry = ;; So blame-declare? only applies to stxclass declares (let ([val (declenv-lookup env id #:use-conventions? #f)]) (match val - [(struct den:lit (_i _e)) + [(struct den:lit (_i _e _p)) (wrong-syntax id "identifier previously declared as literal")] [(struct den:class (name _c _a)) (if (and blame-declare? stxclass-name) @@ -205,6 +205,11 @@ DeclEntry = (define SideClause/c (or/c clause:fail? clause:with? clause:attr?)) +;; ct-phase +;; #f means not specified, ie default, ie 0 +;; syntax means computed by given expr +(define ct-phase/c (or/c syntax? #f)) + (provide (struct-out den:lit) (struct-out den:class) (struct-out den:parser) @@ -214,12 +219,13 @@ DeclEntry = [DeclEnv/c contract?] [DeclEntry/c contract?] [SideClause/c contract?] + [ct-phase/c contract?] [make-dummy-stxclass (-> identifier? stxclass?)] [stxclass-lookup-config (parameter/c (symbols 'no 'try 'yes))] [new-declenv - (->* [(listof (list/c identifier? identifier?))] + (->* [(listof (list/c identifier? identifier? ct-phase/c))] [#:conventions list?] DeclEnv/c)] [declenv-lookup diff --git a/collects/syntax/private/stxparse/rep-patterns.rkt b/collects/syntax/private/stxparse/rep-patterns.rkt index ac2d34839f..06cb3b44f8 100644 --- a/collects/syntax/private/stxparse/rep-patterns.rkt +++ b/collects/syntax/private/stxparse/rep-patterns.rkt @@ -17,7 +17,7 @@ A Base is (listof IAttr) A SinglePattern is one of (make-pat:any Base) (make-pat:var Base id id (listof stx) (listof IAttr) bool) - (make-pat:literal Base identifier) + (make-pat:literal Base identifier ct-phase) (make-pat:datum Base datum) (make-pat:ghost Base GhostPattern SinglePattern) (make-pat:head Base HeadPattern SinglePattern) @@ -38,7 +38,7 @@ A ListPattern is a subtype of SinglePattern; one of (define-struct pat:any (attrs) #:prefab) (define-struct pat:var (attrs name parser args nested-attrs commit?) #:prefab) -(define-struct pat:literal (attrs id) #:prefab) +(define-struct pat:literal (attrs id phase) #:prefab) (define-struct pat:datum (attrs datum) #:prefab) (define-struct pat:ghost (attrs ghost inner) #:prefab) (define-struct pat:head (attrs head tail) #:prefab) @@ -186,8 +186,8 @@ A Kind is one of (define (create-pat:datum datum) (make pat:datum null datum)) -(define (create-pat:literal literal) - (make pat:literal null literal)) +(define (create-pat:literal literal phase) + (make pat:literal null literal phase)) (define (create-pat:ghost g sp) (cond [(ghost:and? g) diff --git a/collects/syntax/private/stxparse/rep.rkt b/collects/syntax/private/stxparse/rep.rkt index cc1f1b96f1..d57ad02219 100644 --- a/collects/syntax/private/stxparse/rep.rkt +++ b/collects/syntax/private/stxparse/rep.rkt @@ -9,6 +9,7 @@ syntax/keyword unstable/syntax unstable/struct + "../util/txlift.ss" "rep-data.ss" "codegen-data.ss") @@ -42,12 +43,14 @@ (-> DeclEntry/c (values DeclEntry/c (listof syntax?)))] [check-literals-list + ;; NEEDS txlift context (-> syntax? syntax? - (listof (list/c identifier? identifier?)))] + (listof (list/c identifier? identifier? ct-phase/c)))] #| [check-literal-sets-list + ;; NEEDS txlift context (-> syntax? syntax? - (listof (listof (list/c identifier? identifier?))))] + (listof (listof (list/c identifier? identifier? ct-phase/c))))] |# [check-conventions-rules (-> syntax? syntax? @@ -124,22 +127,26 @@ ;; literals must be bound. Set to #f for pass1 (attr collection); ;; parser requires stxclasses to be bound. (define (parse-rhs stx expected-attrs splicing? #:context ctx) - (parameterize ((current-syntax-context ctx)) - (define-values (rest description transp? attributes auto-nested? - decls defs commit?) - (parse-rhs/part1 stx splicing? (and expected-attrs #t))) - (define patterns - (parameterize ((stxclass-lookup-config - (cond [expected-attrs 'yes] - [auto-nested? 'try] - [else 'no]))) - (parse-variants rest decls splicing? expected-attrs))) - (when (null? patterns) - (wrong-syntax #f "expected at least one variant")) - (let ([sattrs - (or attributes - (intersect-sattrss (map variant-attrs patterns)))]) - (make rhs stx sattrs transp? description patterns defs commit?)))) + (call/txlifts + (lambda () + (parameterize ((current-syntax-context ctx)) + (define-values (rest description transp? attributes auto-nested? + decls defs commit?) + (parse-rhs/part1 stx splicing? (and expected-attrs #t))) + (define patterns + (parameterize ((stxclass-lookup-config + (cond [expected-attrs 'yes] + [auto-nested? 'try] + [else 'no]))) + (parse-variants rest decls splicing? expected-attrs))) + (when (null? patterns) + (wrong-syntax #f "expected at least one variant")) + (let ([sattrs + (or attributes + (intersect-sattrss (map variant-attrs patterns)))]) + (make rhs stx sattrs transp? description patterns + (append (get-txlifts-as-definitions) defs) + commit?)))))) (define (parse-rhs/part1 stx splicing? strict?) (define-values (chunks rest) @@ -232,7 +239,7 @@ ;; create-aux-def : DeclEntry -> (values DeclEntry (listof stx)) (define (create-aux-def entry) (match entry - [(struct den:lit (_i _e)) + [(struct den:lit (_i _e _p)) (values entry null)] [(struct den:class (name class args)) (cond [(identifier? name) @@ -476,8 +483,8 @@ (define (parse-pat:id id decls allow-head?) (define entry (declenv-lookup decls id)) (match entry - [(struct den:lit (internal literal)) - (create-pat:literal literal)] + [(struct den:lit (internal literal phase)) + (create-pat:literal literal phase)] [(struct den:class (_n _c _a)) (error 'parse-pat:id "(internal error) decls had leftover stxclass entry: ~s" @@ -604,9 +611,10 @@ (define (parse-pat:literal stx decls) (syntax-case stx (~literal) [(~literal lit) + ;; FIXME: support #:phase option here (unless (identifier? #'lit) (wrong-syntax #'lit "expected identifier")) - (create-pat:literal #'lit)] + (create-pat:literal #'lit #f)] [_ (wrong-syntax stx "bad ~~literal pattern")])) @@ -969,7 +977,7 @@ [_ (raise-syntax-error #f "expected attribute name with optional depth declaration" ctx stx)])) -;; check-literals-list : stx stx -> (listof (list id id)) +;; check-literals-list : stx stx -> (listof (list id id ct-phase)) (define (check-literals-list stx ctx) (unless (stx-list? stx) (raise-syntax-error #f "expected literals list" ctx stx)) @@ -978,15 +986,18 @@ (when dup (raise-syntax-error #f "duplicate literal identifier" ctx dup))) lits)) -;; check-literal-entry : stx stx -> (list id id) +;; check-literal-entry : stx stx -> (list id id ct-phase) (define (check-literal-entry stx ctx) (syntax-case stx () + [(internal external #:phase phase) + (and (identifier? #'internal) (identifier? #'external)) + (list #'internal #'external (txlift #'phase))] [(internal external) (and (identifier? #'internal) (identifier? #'external)) - (list #'internal #'external)] + (list #'internal #'external #f)] [id (identifier? #'id) - (list #'id #'id)] + (list #'id #'id #f)] [_ (raise-syntax-error #f "expected literal (identifier or pair of identifiers)" ctx stx)])) @@ -997,27 +1008,38 @@ (for/list ([x (stx->list stx)]) (check-literal-set-entry x ctx))) +;; check-literal-set-entry : stx stx -> (listof (list id id ct-phase)) (define (check-literal-set-entry stx ctx) - (define (elaborate litset-id lctx) + (define (elaborate litset-id lctx phase) + ;; phase is #f (not specified, means 0) or syntax (expr) (let ([litset (syntax-local-value/catch litset-id literalset?)]) (unless litset (raise-syntax-error #f "expected identifier defined as a literal-set" ctx litset-id)) - (elaborate-litset litset lctx stx))) + (elaborate-litset litset lctx phase stx))) (syntax-case stx () - [(litset #:at lctx) - (and (identifier? #'litset) (identifier? #'lctx)) - (elaborate #'litset #'lctx)] + [(litset . more) + (and (identifier? #'litset)) + (let* ([chunks (parse-keyword-options/eol #'more litset-directive-table + #:no-duplicates? #t + #:context ctx)] + [lctx (options-select-value chunks '#:at #:default #'litset)] + [phase (options-select-value chunks '#:phase #:default #f)]) + (elaborate #'litset lctx (and phase (txlift phase))))] [litset (identifier? #'litset) - (elaborate #'litset #'litset)] + (elaborate #'litset #'litset #f)] [_ (raise-syntax-error #f "expected literal-set entry" ctx stx)])) -(define (elaborate-litset litset lctx srcctx) +(define (elaborate-litset litset lctx phase srcctx) + ;; phase is #f (not specified, means 0) or syntax (expr) (for/list ([entry (literalset-literals litset)]) (list (datum->syntax lctx (car entry) srcctx) - (cadr entry)))) + (cadr entry) + (cond [(not (caddr entry)) phase] + [(not phase) (caddr entry)] + [else #`(phase+ #,(caddr entry) #,phase)])))) ;; returns (listof (cons Conventions (listof syntax))) (define (check-conventions-list stx ctx) @@ -1140,3 +1162,12 @@ ;; h-optional-directive-table (define h-optional-directive-table (list (list '#:defaults check-bind-clause-list))) + +;; phase-directive-table +(define phase-directive-table + (list (list '#:phase check-expression))) + +;; litset-directive-table +(define litset-directive-table + (cons (list '#:at check-identifier) + phase-directive-table)) diff --git a/collects/syntax/private/stxparse/runtime.rkt b/collects/syntax/private/stxparse/runtime.rkt index 38f2389794..41f33ece8c 100644 --- a/collects/syntax/private/stxparse/runtime.rkt +++ b/collects/syntax/private/stxparse/runtime.rkt @@ -356,6 +356,8 @@ A Dynamic Frontier Context (DFC) is one of ;; == Expectations +;; FIXME: add phase to expect:literal + #| An Expectation is one of 'ineffable @@ -599,3 +601,10 @@ An Expectation is one of #'(k))]) #'(values (lambda (x extra ...) (parser x extra ... arg ...)) (lambda () (get-description arg ...)))))])) + +;; + +(provide phase+) + +(define (phase+ a b) + (and (number? a) (number? b) (+ a b))) diff --git a/collects/syntax/private/stxparse/sc.rkt b/collects/syntax/private/stxparse/sc.rkt index d1e20e55d9..55a4852318 100644 --- a/collects/syntax/private/stxparse/sc.rkt +++ b/collects/syntax/private/stxparse/sc.rkt @@ -4,6 +4,7 @@ unstable/syntax unstable/struct "minimatch.ss" + "../util/txlift.ss" "rep-data.ss" "rep.ss") racket/list @@ -146,11 +147,18 @@ (begin (unless (identifier? #'name) (raise-syntax-error #f "expected identifier" stx #'name)) - (let ([lits (check-literals-list #'(lit ...) stx)]) - (with-syntax ([((internal external) ...) lits]) - #'(define-syntax name - (make-literalset - (list (list 'internal (quote-syntax external)) ...))))))])) + (with-txlifts/defs + (lambda () + (let ([lits (check-literals-list #'(lit ...) stx)]) + (with-syntax ([((internal external _) ...) lits] + [(phase ...) + (for/list ([lit lits]) + (if (caddr lit) + #`(quote-syntax #,(caddr lit)) + #'(quote #f)))]) + #'(define-syntax name + (make-literalset + (list (list 'internal (quote-syntax external) phase) ...))))))))])) ;; ---- diff --git a/collects/syntax/private/util/txlift.ss b/collects/syntax/private/util/txlift.ss new file mode 100644 index 0000000000..11f53a09ef --- /dev/null +++ b/collects/syntax/private/util/txlift.ss @@ -0,0 +1,53 @@ +#lang scheme/base +(require (for-template scheme/base)) +(provide txlift + get-txlifts + get-txlifts-as-definitions + call/txlifts + with-txlifts + with-txlifts/defs) + +;; Like lifting definitions, but within a single transformer. + +(define current-liftbox (make-parameter #f)) + +(define (call/txlifts proc) + (parameterize ((current-liftbox (box null))) + (proc))) + +(define (txlift expr) + (let ([liftbox (current-liftbox)]) + (check 'txlift liftbox) + (let ([var (car (generate-temporaries '(txlift)))]) + (set-box! liftbox (cons (list var expr) (unbox liftbox))) + var))) + +(define (get-txlifts) + (let ([liftbox (current-liftbox)]) + (check 'get-txlifts liftbox) + (reverse (unbox liftbox)))) + +(define (get-txlifts-as-definitions) + (let ([liftbox (current-liftbox)]) + (check 'get-txlifts-as-definitions liftbox) + (map (lambda (p) + #`(define #,@p)) + (reverse (unbox liftbox))))) + +(define (check who lb) + (unless (box? lb) + (error who "not in a txlift-catching context"))) + +(define (with-txlifts proc) + (call/txlifts + (lambda () + (let ([v (proc)]) + (with-syntax ([((var rhs) ...) (get-txlifts)]) + #`(let* ([var rhs] ...) #,v)))))) + +(define (with-txlifts/defs proc) + (call/txlifts + (lambda () + (let ([v (proc)]) + (with-syntax ([(def ...) (get-txlifts-as-definitions)]) + #`(begin def ... #,v))))))