|
|
@ -7,6 +7,7 @@
|
|
|
|
(provide
|
|
|
|
(provide
|
|
|
|
(struct-out terminal-derivation)
|
|
|
|
(struct-out terminal-derivation)
|
|
|
|
(struct-out nonterminal-derivation)
|
|
|
|
(struct-out nonterminal-derivation)
|
|
|
|
|
|
|
|
(struct-out datum-label)
|
|
|
|
(contract-out
|
|
|
|
(contract-out
|
|
|
|
[parser-derivation? predicate/c]
|
|
|
|
[parser-derivation? predicate/c]
|
|
|
|
[parser-derivation-first-terminal (-> parser-derivation? any/c)]
|
|
|
|
[parser-derivation-first-terminal (-> parser-derivation? any/c)]
|
|
|
@ -14,8 +15,14 @@
|
|
|
|
[parser-derivation
|
|
|
|
[parser-derivation
|
|
|
|
(case->
|
|
|
|
(case->
|
|
|
|
(-> any/c terminal-derivation?)
|
|
|
|
(-> any/c terminal-derivation?)
|
|
|
|
(-> any/c parser-derivation? #:rest (listof parser-derivation?) nonterminal-derivation?))]
|
|
|
|
(-> derivation-label? parser-derivation? #:rest (listof parser-derivation?)
|
|
|
|
|
|
|
|
nonterminal-derivation?))]
|
|
|
|
[parser-derivation->syntax (-> parser-derivation? syntax?)]
|
|
|
|
[parser-derivation->syntax (-> parser-derivation? syntax?)]
|
|
|
|
|
|
|
|
[derivation-label? predicate/c]
|
|
|
|
|
|
|
|
[cut-label cut-label?]
|
|
|
|
|
|
|
|
[cut-label? predicate/c]
|
|
|
|
|
|
|
|
[splice-label splice-label?]
|
|
|
|
|
|
|
|
[splice-label? predicate/c]
|
|
|
|
[syntax-label? predicate/c]
|
|
|
|
[syntax-label? predicate/c]
|
|
|
|
[syntax-label (->* (any/c) (#:properties hash? #:expression-properties hash?) syntax-label?)]
|
|
|
|
[syntax-label (->* (any/c) (#:properties hash? #:expression-properties hash?) syntax-label?)]
|
|
|
|
[syntax-label-value (-> syntax-label? any/c)]
|
|
|
|
[syntax-label-value (-> syntax-label? any/c)]
|
|
|
@ -33,6 +40,7 @@
|
|
|
|
|
|
|
|
|
|
|
|
(module+ test
|
|
|
|
(module+ test
|
|
|
|
(require (submod "..")
|
|
|
|
(require (submod "..")
|
|
|
|
|
|
|
|
racket/syntax-srcloc
|
|
|
|
rackunit))
|
|
|
|
rackunit))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
@ -99,7 +107,7 @@
|
|
|
|
(test-case "nonterminal of terminals"
|
|
|
|
(test-case "nonterminal of terminals"
|
|
|
|
(define derivation
|
|
|
|
(define derivation
|
|
|
|
(parser-derivation
|
|
|
|
(parser-derivation
|
|
|
|
'a
|
|
|
|
(datum-label 'a)
|
|
|
|
(parser-derivation 1)
|
|
|
|
(parser-derivation 1)
|
|
|
|
(parser-derivation 2)
|
|
|
|
(parser-derivation 2)
|
|
|
|
(parser-derivation 3)))
|
|
|
|
(parser-derivation 3)))
|
|
|
@ -108,8 +116,8 @@
|
|
|
|
(test-case "nonterminal of nonterminals and terminals"
|
|
|
|
(test-case "nonterminal of nonterminals and terminals"
|
|
|
|
(define derivation
|
|
|
|
(define derivation
|
|
|
|
(parser-derivation
|
|
|
|
(parser-derivation
|
|
|
|
'a
|
|
|
|
(datum-label 'a)
|
|
|
|
(parser-derivation 'b (parser-derivation 1))
|
|
|
|
(parser-derivation (datum-label 'b) (parser-derivation 1))
|
|
|
|
(parser-derivation 2)
|
|
|
|
(parser-derivation 2)
|
|
|
|
(parser-derivation 3)))
|
|
|
|
(parser-derivation 3)))
|
|
|
|
(check-equal? (parser-derivation-first-terminal derivation) 1)))
|
|
|
|
(check-equal? (parser-derivation-first-terminal derivation) 1)))
|
|
|
@ -122,7 +130,7 @@
|
|
|
|
(test-case "nonterminal of terminals"
|
|
|
|
(test-case "nonterminal of terminals"
|
|
|
|
(define derivation
|
|
|
|
(define derivation
|
|
|
|
(parser-derivation
|
|
|
|
(parser-derivation
|
|
|
|
'a
|
|
|
|
(datum-label 'a)
|
|
|
|
(parser-derivation 1)
|
|
|
|
(parser-derivation 1)
|
|
|
|
(parser-derivation 2)
|
|
|
|
(parser-derivation 2)
|
|
|
|
(parser-derivation 3)))
|
|
|
|
(parser-derivation 3)))
|
|
|
@ -131,13 +139,28 @@
|
|
|
|
(test-case "nonterminal of nonterminals and terminals"
|
|
|
|
(test-case "nonterminal of nonterminals and terminals"
|
|
|
|
(define derivation
|
|
|
|
(define derivation
|
|
|
|
(parser-derivation
|
|
|
|
(parser-derivation
|
|
|
|
'a
|
|
|
|
(datum-label 'a)
|
|
|
|
(parser-derivation 1)
|
|
|
|
(parser-derivation 1)
|
|
|
|
(parser-derivation 2)
|
|
|
|
(parser-derivation 2)
|
|
|
|
(parser-derivation 'b (parser-derivation 3))))
|
|
|
|
(parser-derivation (datum-label 'b) (parser-derivation 3))))
|
|
|
|
(check-equal? (parser-derivation-last-terminal derivation) 3))))
|
|
|
|
(check-equal? (parser-derivation-last-terminal derivation) 3))))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(define (derivation-label? v)
|
|
|
|
|
|
|
|
(or (cut-label? v) (splice-label? v) (datum-label? v) (syntax-label? v)))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(struct cut-label () #:transparent #:constructor-name constructor:cut-label #:omit-define-syntaxes)
|
|
|
|
|
|
|
|
(define cut-label (constructor:cut-label))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(struct splice-label ()
|
|
|
|
|
|
|
|
#:transparent #:constructor-name constructor:splice-label #:omit-define-syntaxes)
|
|
|
|
|
|
|
|
(define splice-label (constructor:splice-label))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(struct datum-label (value) #:transparent)
|
|
|
|
|
|
|
|
|
|
|
|
(struct syntax-label (value expression-properties properties)
|
|
|
|
(struct syntax-label (value expression-properties properties)
|
|
|
|
#:transparent
|
|
|
|
#:transparent
|
|
|
|
#:constructor-name constructor:syntax-label
|
|
|
|
#:constructor-name constructor:syntax-label
|
|
|
@ -155,9 +178,15 @@
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(define (parser-derivation->syntax derivation)
|
|
|
|
(define (parser-derivation->syntax derivation)
|
|
|
|
|
|
|
|
(define (->splice derivation)
|
|
|
|
(match derivation
|
|
|
|
(match derivation
|
|
|
|
[(terminal-derivation t) (syntax-token->syntax t)]
|
|
|
|
[(terminal-derivation t) (list (syntax-token->syntax t))]
|
|
|
|
[(nonterminal-derivation label children)
|
|
|
|
[(nonterminal-derivation (? cut-label?) _) '()]
|
|
|
|
|
|
|
|
[(nonterminal-derivation (? splice-label?) children)
|
|
|
|
|
|
|
|
(for*/list ([child (in-vector children)]
|
|
|
|
|
|
|
|
[stx (in-list (->splice child))])
|
|
|
|
|
|
|
|
stx)]
|
|
|
|
|
|
|
|
[(nonterminal-derivation (? syntax-label? label) children)
|
|
|
|
(define first-token (parser-derivation-first-terminal derivation))
|
|
|
|
(define first-token (parser-derivation-first-terminal derivation))
|
|
|
|
(define label-location
|
|
|
|
(define label-location
|
|
|
|
(srcloc (syntax-token-source first-token)
|
|
|
|
(srcloc (syntax-token-source first-token)
|
|
|
@ -170,8 +199,9 @@
|
|
|
|
([(key value) (in-hash (syntax-label-properties label))])
|
|
|
|
([(key value) (in-hash (syntax-label-properties label))])
|
|
|
|
(syntax-property stx key value)))
|
|
|
|
(syntax-property stx key value)))
|
|
|
|
(define children-syntaxes
|
|
|
|
(define children-syntaxes
|
|
|
|
(for/list ([child (in-vector children)])
|
|
|
|
(for*/list ([child (in-vector children)]
|
|
|
|
(parser-derivation->syntax child)))
|
|
|
|
[spliced-child (in-list (->splice child))])
|
|
|
|
|
|
|
|
spliced-child))
|
|
|
|
(define last-token (parser-derivation-last-terminal derivation))
|
|
|
|
(define last-token (parser-derivation-last-terminal derivation))
|
|
|
|
(define expression-location
|
|
|
|
(define expression-location
|
|
|
|
(srcloc (syntax-token-source first-token)
|
|
|
|
(srcloc (syntax-token-source first-token)
|
|
|
@ -181,6 +211,116 @@
|
|
|
|
(- (syntax-token-end-position last-token) (syntax-token-position first-token))))
|
|
|
|
(- (syntax-token-end-position last-token) (syntax-token-position first-token))))
|
|
|
|
(define expression-stx
|
|
|
|
(define expression-stx
|
|
|
|
(datum->syntax #false (cons label-stx children-syntaxes) expression-location #false))
|
|
|
|
(datum->syntax #false (cons label-stx children-syntaxes) expression-location #false))
|
|
|
|
(for/fold ([expression-stx expression-stx])
|
|
|
|
(list (for/fold ([expression-stx expression-stx])
|
|
|
|
([(key value) (in-hash (syntax-label-expression-properties label))])
|
|
|
|
([(key value) (in-hash (syntax-label-expression-properties label))])
|
|
|
|
(syntax-property expression-stx key value))]))
|
|
|
|
(syntax-property expression-stx key value)))]))
|
|
|
|
|
|
|
|
(define first-token (parser-derivation-first-terminal derivation))
|
|
|
|
|
|
|
|
(define last-token (parser-derivation-last-terminal derivation))
|
|
|
|
|
|
|
|
(define top-level-location
|
|
|
|
|
|
|
|
(srcloc (syntax-token-source first-token)
|
|
|
|
|
|
|
|
(syntax-token-line first-token)
|
|
|
|
|
|
|
|
(syntax-token-column first-token)
|
|
|
|
|
|
|
|
(syntax-token-position first-token)
|
|
|
|
|
|
|
|
(- (syntax-token-end-position last-token) (syntax-token-position first-token))))
|
|
|
|
|
|
|
|
(define top-level-stxs (->splice derivation))
|
|
|
|
|
|
|
|
(match top-level-stxs
|
|
|
|
|
|
|
|
[(list stx) stx]))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(define (parser-derivation->datum derivation)
|
|
|
|
|
|
|
|
(define (->splice derivation)
|
|
|
|
|
|
|
|
(match derivation
|
|
|
|
|
|
|
|
[(terminal-derivation t) (list t)]
|
|
|
|
|
|
|
|
[(nonterminal-derivation (? cut-label?) _) '()]
|
|
|
|
|
|
|
|
[(nonterminal-derivation (? splice-label?) children)
|
|
|
|
|
|
|
|
(for*/list ([child (in-vector children)]
|
|
|
|
|
|
|
|
[datum (in-list (->splice child))])
|
|
|
|
|
|
|
|
datum)]
|
|
|
|
|
|
|
|
[(nonterminal-derivation (datum-label value) children)
|
|
|
|
|
|
|
|
(define child-data
|
|
|
|
|
|
|
|
(for*/list ([child (in-vector children)]
|
|
|
|
|
|
|
|
[spliced-child (in-list (->splice child))])
|
|
|
|
|
|
|
|
spliced-child))
|
|
|
|
|
|
|
|
(list (cons value child-data))]))
|
|
|
|
|
|
|
|
(define top-level-data (->splice derivation))
|
|
|
|
|
|
|
|
(match top-level-data
|
|
|
|
|
|
|
|
[(list datum) datum]))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(module+ test
|
|
|
|
|
|
|
|
(test-case (name-string parser-derivation->datum)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(test-case "datum terminals"
|
|
|
|
|
|
|
|
(define derivation (parser-derivation 'a))
|
|
|
|
|
|
|
|
(check-equal? (parser-derivation->datum derivation) 'a))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(test-case "datum nonterminals"
|
|
|
|
|
|
|
|
(define derivation
|
|
|
|
|
|
|
|
(parser-derivation (datum-label 'a)
|
|
|
|
|
|
|
|
(parser-derivation 'b)
|
|
|
|
|
|
|
|
(parser-derivation 'c)
|
|
|
|
|
|
|
|
(parser-derivation 'd)))
|
|
|
|
|
|
|
|
(check-equal? (parser-derivation->datum derivation) '(a b c d)))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(test-case "datum cuts"
|
|
|
|
|
|
|
|
(define derivation
|
|
|
|
|
|
|
|
(parser-derivation (datum-label 'a)
|
|
|
|
|
|
|
|
(parser-derivation cut-label (parser-derivation 'b))
|
|
|
|
|
|
|
|
(parser-derivation 'c)
|
|
|
|
|
|
|
|
(parser-derivation cut-label (parser-derivation 'd))))
|
|
|
|
|
|
|
|
(check-equal? (parser-derivation->datum derivation) '(a c)))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(test-case "datum splices"
|
|
|
|
|
|
|
|
(define derivation
|
|
|
|
|
|
|
|
(parser-derivation (datum-label 'a)
|
|
|
|
|
|
|
|
(parser-derivation 'b)
|
|
|
|
|
|
|
|
(parser-derivation splice-label
|
|
|
|
|
|
|
|
(parser-derivation 'c1)
|
|
|
|
|
|
|
|
(parser-derivation 'c2)
|
|
|
|
|
|
|
|
(parser-derivation 'c3))
|
|
|
|
|
|
|
|
(parser-derivation 'd)))
|
|
|
|
|
|
|
|
(check-equal? (parser-derivation->datum derivation) '(a b c1 c2 c3 d))))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(test-case (name-string parser-derivation->syntax)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(test-case "syntax terminals"
|
|
|
|
|
|
|
|
(define derivation (parser-derivation (syntax-token 'a #:position 1 #:span 1)))
|
|
|
|
|
|
|
|
(define actual (parser-derivation->syntax derivation))
|
|
|
|
|
|
|
|
(check-equal? (syntax->datum actual) 'a)
|
|
|
|
|
|
|
|
(check-equal? (syntax-srcloc actual) (srcloc #false #false #false 1 1)))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(test-case "syntax nonterminals"
|
|
|
|
|
|
|
|
(define derivation
|
|
|
|
|
|
|
|
(parser-derivation
|
|
|
|
|
|
|
|
(syntax-label 'a)
|
|
|
|
|
|
|
|
(parser-derivation (syntax-token 'b #:position 1 #:span 1))
|
|
|
|
|
|
|
|
(parser-derivation (syntax-token 'c #:position 2 #:span 1))
|
|
|
|
|
|
|
|
(parser-derivation (syntax-token 'd #:position 3 #:span 1))))
|
|
|
|
|
|
|
|
(define actual (parser-derivation->syntax derivation))
|
|
|
|
|
|
|
|
(check-equal? (syntax->datum actual) '(a b c d))
|
|
|
|
|
|
|
|
(check-equal? (syntax-srcloc actual) (srcloc #false #false #false 1 3)))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(test-case "syntax cuts"
|
|
|
|
|
|
|
|
(define derivation
|
|
|
|
|
|
|
|
(parser-derivation
|
|
|
|
|
|
|
|
(syntax-label 'a)
|
|
|
|
|
|
|
|
(parser-derivation cut-label (parser-derivation (syntax-token 'b #:position 1 #:span 1)))
|
|
|
|
|
|
|
|
(parser-derivation (syntax-token 'c #:position 2 #:span 1))
|
|
|
|
|
|
|
|
(parser-derivation cut-label (parser-derivation (syntax-token 'd #:position 3 #:span 1)))))
|
|
|
|
|
|
|
|
(define actual (parser-derivation->syntax derivation))
|
|
|
|
|
|
|
|
(check-equal? (syntax->datum actual) '(a c))
|
|
|
|
|
|
|
|
(check-equal? (syntax-srcloc actual) (srcloc #false #false #false 1 3)))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(test-case "syntax splices"
|
|
|
|
|
|
|
|
(define derivation
|
|
|
|
|
|
|
|
(parser-derivation
|
|
|
|
|
|
|
|
(syntax-label 'a)
|
|
|
|
|
|
|
|
(parser-derivation (syntax-token 'b #:position 1 #:span 1))
|
|
|
|
|
|
|
|
(parser-derivation splice-label
|
|
|
|
|
|
|
|
(parser-derivation (syntax-token 'c1 #:position 2 #:span 1))
|
|
|
|
|
|
|
|
(parser-derivation (syntax-token 'c2 #:position 3 #:span 1))
|
|
|
|
|
|
|
|
(parser-derivation (syntax-token 'c3 #:position 4 #:span 1)))
|
|
|
|
|
|
|
|
(parser-derivation (syntax-token 'd #:position 5 #:span 1))))
|
|
|
|
|
|
|
|
(define actual (parser-derivation->syntax derivation))
|
|
|
|
|
|
|
|
(check-equal? (syntax->datum actual) '(a b c1 c2 c3 d))
|
|
|
|
|
|
|
|
(check-equal? (syntax-srcloc actual) (srcloc #false #false #false 1 5)))))
|
|
|
|