syntax/parse: literals, literal-sets, and phases (todo: docs)
typed-scheme: added missing import for literal
This commit is contained in:
Ryan Culpepper
parent
f42adad3f8
commit
eff9147ddc
|
|
@ -258,16 +258,10 @@
|
|||
(fail x
|
||||
#:expect (expectation pattern0)
|
||||
#:fce fc)))]
|
||||
[#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)
|
||||
[#s(pat:literal attrs literal input-phase lit-phase)
|
||||
#`(if (and (identifier? x)
|
||||
(free-identifier=? x (quote-syntax literal)
|
||||
(phase+ (syntax-local-phase-level) phase)))
|
||||
(free-identifier=?/phases x input-phase
|
||||
(quote-syntax literal) lit-phase))
|
||||
k
|
||||
(fail x
|
||||
#:expect (expectation pattern0)
|
||||
|
|
@ -629,7 +623,7 @@
|
|||
[(_ #s(pat:datum attrs d))
|
||||
#'(begin (collect-error '(datum d))
|
||||
(make-expect:atom 'd))]
|
||||
[(_ #s(pat:literal attrs lit phase))
|
||||
[(_ #s(pat:literal attrs lit input-phase lit-phase))
|
||||
#'(begin (collect-error '(literal lit))
|
||||
(make-expect:literal (quote-syntax lit)))]
|
||||
;; 2 pat:compound patterns
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
#lang racket/base
|
||||
(require racket/contract/base
|
||||
racket/dict
|
||||
racket/list
|
||||
syntax/stx
|
||||
syntax/id-table
|
||||
"../util.ss"
|
||||
|
|
@ -92,9 +93,9 @@ A ConventionRule is (list regexp DeclEntry)
|
|||
|
||||
#|
|
||||
A LiteralSet is
|
||||
(make-literalset (listof (list symbol id ct-phase)))
|
||||
(make-literalset (listof (list symbol id)) stx)
|
||||
|#
|
||||
(define-struct literalset (literals) #:transparent)
|
||||
(define-struct literalset (literals phase) #:transparent)
|
||||
|
||||
;; make-dummy-stxclass : identifier -> SC
|
||||
;; Dummy stxclass for calculating attributes of recursive stxclasses.
|
||||
|
|
@ -110,14 +111,14 @@ DeclEnv =
|
|||
(listof ConventionRule))
|
||||
|
||||
DeclEntry =
|
||||
(make-den:lit id id ct-phase)
|
||||
(make-den:lit id id ct-phase 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 phase))
|
||||
(define-struct den:lit (internal external input-phase lit-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 +128,8 @@ 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) (caddr literal))))
|
||||
(make den:lit (first literal) (second literal)
|
||||
(third literal) (fourth literal))))
|
||||
conventions))
|
||||
|
||||
(define (declenv-lookup env id #:use-conventions? [use-conventions? #t])
|
||||
|
|
@ -141,7 +143,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 _p))
|
||||
[(struct den:lit (_i _e _ip _lp))
|
||||
(wrong-syntax id "identifier previously declared as literal")]
|
||||
[(struct den:class (name _c _a))
|
||||
(if (and blame-declare? stxclass-name)
|
||||
|
|
@ -205,10 +207,9 @@ 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))
|
||||
;; ct-phase = syntax, expr that computes absolute phase
|
||||
;; usually = #'(syntax-local-phase-level)
|
||||
(define ct-phase/c syntax?)
|
||||
|
||||
(provide (struct-out den:lit)
|
||||
(struct-out den:class)
|
||||
|
|
@ -225,7 +226,7 @@ DeclEntry =
|
|||
[stxclass-lookup-config (parameter/c (symbols 'no 'try 'yes))]
|
||||
|
||||
[new-declenv
|
||||
(->* [(listof (list/c identifier? identifier? ct-phase/c))]
|
||||
(->* [(listof (list/c identifier? identifier? ct-phase/c ct-phase/c))]
|
||||
[#:conventions list?]
|
||||
DeclEnv/c)]
|
||||
[declenv-lookup
|
||||
|
|
|
|||
|
|
@ -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 ct-phase)
|
||||
(make-pat:literal Base identifier ct-phase 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 phase) #:prefab)
|
||||
(define-struct pat:literal (attrs id input-phase lit-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 phase)
|
||||
(make pat:literal null literal phase))
|
||||
(define (create-pat:literal literal input-phase lit-phase)
|
||||
(make pat:literal null literal input-phase lit-phase))
|
||||
|
||||
(define (create-pat:ghost g sp)
|
||||
(cond [(ghost:and? g)
|
||||
|
|
|
|||
|
|
@ -42,10 +42,15 @@
|
|||
[create-aux-def
|
||||
(-> DeclEntry/c
|
||||
(values DeclEntry/c (listof syntax?)))]
|
||||
#|
|
||||
[check-literals-list
|
||||
;; NEEDS txlift context
|
||||
(-> syntax? syntax?
|
||||
(listof (list/c identifier? identifier? ct-phase/c)))]
|
||||
(listof (list/c identifier? identifier? ct-phase/c ct-phase/c)))]
|
||||
|#
|
||||
[check-literals-list/litset
|
||||
(-> syntax? syntax?
|
||||
(listof (list/c identifier? identifier?)))]
|
||||
#|
|
||||
[check-literal-sets-list
|
||||
;; NEEDS txlift context
|
||||
|
|
@ -192,8 +197,7 @@
|
|||
(define convs (options-select-value chunks '#:conventions #:default null))
|
||||
(define localconvs (options-select-value chunks '#:local-conventions #:default null))
|
||||
(define literals
|
||||
(append-lits+litsets (check-literals-bound lits strict?)
|
||||
litsets))
|
||||
(append-lits+litsets lits litsets))
|
||||
(define-values (convs-rules convs-defs)
|
||||
(for/fold ([convs-rules null] [convs-defs null])
|
||||
([conv-entry convs])
|
||||
|
|
@ -217,18 +221,6 @@
|
|||
(let-values ([(parsers descriptions) (get-procedures arg ...)])
|
||||
(apply values parsers)))))
|
||||
|
||||
(define (check-literals-bound lits strict?)
|
||||
(define phase (syntax-local-phase-level))
|
||||
(when strict?
|
||||
(for ([p lits])
|
||||
;; FIXME: hack...
|
||||
(unless (or (identifier-binding (cadr p) phase)
|
||||
(identifier-binding (cadr p) (add1 phase))
|
||||
(identifier-binding (cadr p) (sub1 phase))
|
||||
(identifier-binding (cadr p) #f))
|
||||
(wrong-syntax (cadr p) "unbound identifier not allowed as literal"))))
|
||||
lits)
|
||||
|
||||
;; decls-create-defs : DeclEnv -> (values DeclEnv (listof stx))
|
||||
(define (decls-create-defs decls0)
|
||||
(define (updater key value defs)
|
||||
|
|
@ -237,9 +229,10 @@
|
|||
(declenv-update/fold decls0 updater null))
|
||||
|
||||
;; create-aux-def : DeclEntry -> (values DeclEntry (listof stx))
|
||||
;; FIXME: replace with txlift mechanism
|
||||
(define (create-aux-def entry)
|
||||
(match entry
|
||||
[(struct den:lit (_i _e _p))
|
||||
[(struct den:lit (_i _e _ip _lp))
|
||||
(values entry null)]
|
||||
[(struct den:class (name class args))
|
||||
(cond [(identifier? name)
|
||||
|
|
@ -483,8 +476,8 @@
|
|||
(define (parse-pat:id id decls allow-head?)
|
||||
(define entry (declenv-lookup decls id))
|
||||
(match entry
|
||||
[(struct den:lit (internal literal phase))
|
||||
(create-pat:literal literal phase)]
|
||||
[(struct den:lit (internal literal input-phase lit-phase))
|
||||
(create-pat:literal literal input-phase lit-phase)]
|
||||
[(struct den:class (_n _c _a))
|
||||
(error 'parse-pat:id
|
||||
"(internal error) decls had leftover stxclass entry: ~s"
|
||||
|
|
@ -610,11 +603,15 @@
|
|||
|
||||
(define (parse-pat:literal stx decls)
|
||||
(syntax-case stx (~literal)
|
||||
[(~literal lit)
|
||||
;; FIXME: support #:phase option here
|
||||
[(~literal lit . more)
|
||||
(unless (identifier? #'lit)
|
||||
(wrong-syntax #'lit "expected identifier"))
|
||||
(create-pat:literal #'lit #f)]
|
||||
(let* ([chunks (parse-keyword-options/eol #'more phase-directive-table
|
||||
#:no-duplicates? #t
|
||||
#:context stx)]
|
||||
[phase (options-select-value chunks '#:phase #:default #f)])
|
||||
;; FIXME: Duplicates phase expr!
|
||||
(create-pat:literal #'lit phase phase))]
|
||||
[_
|
||||
(wrong-syntax stx "bad ~~literal pattern")]))
|
||||
|
||||
|
|
@ -977,7 +974,9 @@
|
|||
[_
|
||||
(raise-syntax-error #f "expected attribute name with optional depth declaration" ctx stx)]))
|
||||
|
||||
;; check-literals-list : stx stx -> (listof (list id id ct-phase))
|
||||
;; check-literals-list : stx stx -> (listof (list id id ct-phase ct-phase))
|
||||
;; - txlifts defs of phase expressions
|
||||
;; - txlifts checks that literals are bound
|
||||
(define (check-literals-list stx ctx)
|
||||
(unless (stx-list? stx)
|
||||
(raise-syntax-error #f "expected literals list" ctx stx))
|
||||
|
|
@ -986,37 +985,72 @@
|
|||
(when dup (raise-syntax-error #f "duplicate literal identifier" ctx dup)))
|
||||
lits))
|
||||
|
||||
;; check-literal-entry : stx stx -> (list id id ct-phase)
|
||||
;; check-literal-entry : stx stx -> (list id id ct-phase ct-phase)
|
||||
(define (check-literal-entry stx ctx)
|
||||
(define (go internal external phase)
|
||||
(txlift #`(check-literal (quote-syntax #,external)
|
||||
#,phase (quote-syntax #,ctx)))
|
||||
(list internal external phase phase))
|
||||
(syntax-case stx ()
|
||||
[(internal external #:phase phase)
|
||||
(and (identifier? #'internal) (identifier? #'external))
|
||||
(list #'internal #'external (txlift #'phase))]
|
||||
(go #'internal #'external (txlift #'phase))]
|
||||
[(internal external)
|
||||
(and (identifier? #'internal) (identifier? #'external))
|
||||
(list #'internal #'external #f)]
|
||||
(go #'internal #'external #'(syntax-local-phase-level))]
|
||||
[id
|
||||
(identifier? #'id)
|
||||
(list #'id #'id #f)]
|
||||
(go #'id #'id #'(syntax-local-phase-level))]
|
||||
[_
|
||||
(raise-syntax-error #f "expected literal (identifier or pair of identifiers)"
|
||||
(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 (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)))
|
||||
(define (check-literal-sets-list stx ctx)
|
||||
(unless (stx-list? stx)
|
||||
(raise-syntax-error #f "expected literal-set list" ctx stx))
|
||||
(for/list ([x (stx->list stx)])
|
||||
(check-literal-set-entry x ctx)))
|
||||
|
||||
;; check-literal-set-entry : stx stx -> (listof (list id id ct-phase))
|
||||
;; check-literal-set-entry : stx stx -> (listof (list id id ct-phase^2))
|
||||
(define (check-literal-set-entry stx ctx)
|
||||
(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 phase stx)))
|
||||
(elaborate2 litset lctx phase)))
|
||||
(define (elaborate2 litset lctx phase)
|
||||
(for/list ([entry (literalset-literals litset)])
|
||||
(list (datum->syntax lctx (car entry) stx)
|
||||
(cadr entry)
|
||||
phase
|
||||
(literalset-phase litset))))
|
||||
(syntax-case stx ()
|
||||
[(litset . more)
|
||||
(and (identifier? #'litset))
|
||||
|
|
@ -1024,22 +1058,16 @@
|
|||
#: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))))]
|
||||
[phase (options-select-value chunks '#:phase
|
||||
#:default #'(syntax-local-phase-level))])
|
||||
(elaborate #'litset lctx (txlift phase)))]
|
||||
[litset
|
||||
(identifier? #'litset)
|
||||
(elaborate #'litset #'litset #f)]
|
||||
(elaborate #'litset #'litset #'(syntax-local-phase-level))]
|
||||
[_
|
||||
(raise-syntax-error #f "expected literal-set entry" ctx stx)]))
|
||||
|
||||
(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)
|
||||
(cond [(not (caddr entry)) phase]
|
||||
[(not phase) (caddr entry)]
|
||||
[else #`(phase+ #,(caddr entry) #,phase)]))))
|
||||
;; Conventions
|
||||
|
||||
;; returns (listof (cons Conventions (listof syntax)))
|
||||
(define (check-conventions-list stx ctx)
|
||||
|
|
|
|||
|
|
@ -604,7 +604,55 @@ An Expectation is one of
|
|||
|
||||
;;
|
||||
|
||||
(provide phase+)
|
||||
(provide phase+
|
||||
check-literal
|
||||
free-identifier=?/phases)
|
||||
|
||||
(define (phase+ a b)
|
||||
(and (number? a) (number? b) (+ a b)))
|
||||
|
||||
;; check-literal : id phase-level stx -> void
|
||||
;; FIXME: change to normal 'error', if src gets stripped away
|
||||
(define (check-literal id phase ctx)
|
||||
(unless (identifier-binding id phase)
|
||||
(raise-syntax-error #f "literal identifier has no binding" ctx id)))
|
||||
|
||||
;; free-identifier=?/phases : id phase-level id phase-level -> boolean
|
||||
;; Determines whether x has the same binding at phase-level phase-x
|
||||
;; that y has at phase-level y.
|
||||
;; At least one of the identifiers MUST have a binding (module or lexical)
|
||||
(define (free-identifier=?/phases x phase-x y phase-y)
|
||||
(let ([base-phase (syntax-local-phase-level)])
|
||||
(let ([bx (identifier-binding x (phase+ base-phase phase-x))]
|
||||
[by (identifier-binding y (phase+ base-phase phase-y))])
|
||||
(cond [(and (list? bx) (list? by))
|
||||
(let ([modx (module-path-index-resolve (first bx))]
|
||||
[namex (second bx)]
|
||||
[phasex (fifth bx)]
|
||||
[mody (module-path-index-resolve (first by))]
|
||||
[namey (second by)]
|
||||
[phasey (fifth by)])
|
||||
(and (eq? modx mody) ;; resolved-module-paths are interned
|
||||
(eq? namex namey)
|
||||
(equal? phasex phasey)))]
|
||||
[else
|
||||
;; One must be lexical (can't be #f, since one must be bound)
|
||||
;; lexically-bound names bound in only one phase; just compare
|
||||
(free-identifier=? x y)]))))
|
||||
|
||||
;; ----
|
||||
|
||||
(provide begin-for-syntax/once)
|
||||
|
||||
;; (begin-for-syntax/once expr/phase1 ...)
|
||||
;; evaluates in pass 2 of module/intdefs expansion
|
||||
(define-syntax (begin-for-syntax/once stx)
|
||||
(syntax-case stx ()
|
||||
[(bfs/o e ...)
|
||||
(cond [(list? (syntax-local-context))
|
||||
#`(define-values ()
|
||||
(begin (begin-for-syntax/once e ...)
|
||||
(values)))]
|
||||
[else
|
||||
#'(let-syntax ([m (lambda _ (begin e ...) #'(void))])
|
||||
(m))])]))
|
||||
|
|
|
|||
|
|
@ -144,21 +144,50 @@
|
|||
(define-syntax (define-literal-set stx)
|
||||
(syntax-case stx ()
|
||||
[(define-literal-set name (lit ...))
|
||||
(begin
|
||||
(let ([phase-of-definition (syntax-local-phase-level)])
|
||||
(unless (identifier? #'name)
|
||||
(raise-syntax-error #f "expected identifier" stx #'name))
|
||||
(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
|
||||
(let ([lits (check-literals-list/litset #'(lit ...) stx)])
|
||||
(with-syntax ([((internal external) ...) lits])
|
||||
#`(begin
|
||||
(define phase-of-literals
|
||||
(let ([phase-of-module-instantiation
|
||||
;; Hack to get enclosing module's base phase
|
||||
(variable-reference->phase (#%variable-reference))])
|
||||
(- phase-of-module-instantiation
|
||||
'#,(if (zero? phase-of-definition) 0 1))))
|
||||
(define-syntax name
|
||||
(make-literalset
|
||||
(list (list 'internal (quote-syntax external) phase) ...))))))))]))
|
||||
(list (list 'internal (quote-syntax external)) ...)
|
||||
(quote-syntax phase-of-literals)))
|
||||
(begin-for-syntax/once
|
||||
(for ([x (syntax->list #'(external ...))])
|
||||
(unless (identifier-binding x 0)
|
||||
(raise-syntax-error #f "literal identifier has no binding"
|
||||
(quote-syntax #,stx) x))))))))]))
|
||||
|
||||
#|
|
||||
Literal sets: The goal is for literals to refer to their bindings at
|
||||
|
||||
phase 0 relative to the enclosing module
|
||||
|
||||
Use cases, explained:
|
||||
1) module X with def-lit-set is required-for-syntax
|
||||
phase-of-mod-inst = 1
|
||||
phase-of-def = 0
|
||||
literals looked up at abs phase 1
|
||||
which is phase 0 rel to module X
|
||||
2) module X with local def-lit-set within define-syntax
|
||||
phase-of-mod-inst = 1 (mod at 0, but +1 within define-syntax)
|
||||
phase-of-def = 1
|
||||
literals looked up at abs phase 0
|
||||
which is phase 0 rel to module X
|
||||
3) module X with def-lit-set in phase-2 position (really uncommon case!)
|
||||
phase-of-mod-inst = 1 (not 2, apparently)
|
||||
phase-of-def = 2
|
||||
literals looked up at abs phase 0
|
||||
(that's why the weird (if (z?) 0 1) term)
|
||||
|#
|
||||
|
||||
;; ----
|
||||
|
||||
|
|
|
|||
|
|
@ -10,7 +10,8 @@
|
|||
(prefix-in t: (combine-in "base-types-extra.ss" "base-types.ss")) (only-in "colon.ss" :)
|
||||
scheme/match
|
||||
(for-template scheme/base "base-types-extra.ss" "colon.ss")
|
||||
(for-template (prefix-in t: "base-types-extra.ss")))
|
||||
(for-template (prefix-in t: "base-types-extra.ss")
|
||||
(prefix-in t: (only-in "base-types.ss" Vectorof))))
|
||||
|
||||
(define-struct poly (name vars) #:prefab)
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user