angle brackets behave ; tests pass
This commit is contained in:
parent
831d5cca35
commit
e4a3255f6c
|
@ -44,7 +44,7 @@
|
||||||
|
|
||||||
;; The first rule, by default, is the start rule.
|
;; The first rule, by default, is the start rule.
|
||||||
(define rule-ids (for/list ([a-rule (in-list rules)])
|
(define rule-ids (for/list ([a-rule (in-list rules)])
|
||||||
(rule-id a-rule)))
|
(rule-id a-rule)))
|
||||||
(define start-id (first rule-ids))
|
(define start-id (first rule-ids))
|
||||||
|
|
||||||
|
|
||||||
|
@ -112,9 +112,9 @@
|
||||||
;; For internal use by the permissive tokenizer only:
|
;; For internal use by the permissive tokenizer only:
|
||||||
(define all-tokens-hash/mutable
|
(define all-tokens-hash/mutable
|
||||||
(make-hash (list ;; Note: we also allow the eof object here, to make
|
(make-hash (list ;; Note: we also allow the eof object here, to make
|
||||||
;; the permissive tokenizer even nicer to work with.
|
;; the permissive tokenizer even nicer to work with.
|
||||||
(cons eof token-EOF)
|
(cons eof token-EOF)
|
||||||
(cons 'token-type token-type-constructor) ...)))
|
(cons 'token-type token-type-constructor) ...)))
|
||||||
|
|
||||||
|
|
||||||
#;(define default-lex/1
|
#;(define default-lex/1
|
||||||
|
@ -181,44 +181,44 @@
|
||||||
(define translated-patterns
|
(define translated-patterns
|
||||||
(let loop ([primitive-patterns (syntax->list a-clause)])
|
(let loop ([primitive-patterns (syntax->list a-clause)])
|
||||||
(cond
|
(cond
|
||||||
[(empty? primitive-patterns)
|
[(empty? primitive-patterns)
|
||||||
'()]
|
'()]
|
||||||
[else
|
[else
|
||||||
(cons (syntax-case (first primitive-patterns) (id lit token inferred-id)
|
(cons (syntax-case (first primitive-patterns) (id lit token inferred-id)
|
||||||
[(id val)
|
[(id val)
|
||||||
#'val]
|
#'val]
|
||||||
[(lit val)
|
[(lit val)
|
||||||
(datum->syntax #f (string->symbol (syntax-e #'val)) #'val)]
|
(datum->syntax #f (string->symbol (syntax-e #'val)) #'val)]
|
||||||
[(token val)
|
[(token val)
|
||||||
#'val]
|
#'val]
|
||||||
[(inferred-id val reason)
|
[(inferred-id val reason)
|
||||||
#'val])
|
#'val])
|
||||||
(loop (rest primitive-patterns)))])))
|
(loop (rest primitive-patterns)))])))
|
||||||
|
|
||||||
(define translated-actions
|
(define translated-actions
|
||||||
(for/list ([translated-pattern (in-list translated-patterns)]
|
(for/list ([translated-pattern (in-list translated-patterns)]
|
||||||
[primitive-pattern (syntax->list a-clause)]
|
[primitive-pattern (syntax->list a-clause)]
|
||||||
[pos (in-naturals 1)])
|
[pos (in-naturals 1)])
|
||||||
(with-syntax ([$X
|
(with-syntax ([$X
|
||||||
(format-id translated-pattern "$~a" pos)]
|
(format-id translated-pattern "$~a" pos)]
|
||||||
[$X-start-pos
|
[$X-start-pos
|
||||||
(format-id translated-pattern "$~a-start-pos" pos)]
|
(format-id translated-pattern "$~a-start-pos" pos)]
|
||||||
[$X-end-pos
|
[$X-end-pos
|
||||||
(format-id translated-pattern "$~a-end-pos" pos)])
|
(format-id translated-pattern "$~a-end-pos" pos)])
|
||||||
(syntax-case primitive-pattern (id lit token inferred-id)
|
(syntax-case primitive-pattern (id lit token inferred-id)
|
||||||
;; When a rule usage is inferred, the value of $X is a syntax object
|
;; When a rule usage is inferred, the value of $X is a syntax object
|
||||||
;; whose head is the name of the inferred rule . We strip that out,
|
;; whose head is the name of the inferred rule . We strip that out,
|
||||||
;; leaving the residue to be absorbed.
|
;; leaving the residue to be absorbed.
|
||||||
[(inferred-id val reason)
|
[(inferred-id val reason)
|
||||||
#'(syntax-case $X ()
|
#'(syntax-case $X ()
|
||||||
[(inferred-rule-name . rest)
|
[(inferred-rule-name . rest)
|
||||||
(syntax->list #'rest)])]
|
(syntax->list #'rest)])]
|
||||||
[(id val)
|
[(id val)
|
||||||
#`(list $X)]
|
#`(list $X)]
|
||||||
[(lit val)
|
[(lit val)
|
||||||
#`(list (atomic-datum->syntax $X $X-start-pos $X-end-pos))]
|
#`(list (atomic-datum->syntax $X $X-start-pos $X-end-pos))]
|
||||||
[(token val)
|
[(token val)
|
||||||
#`(list (atomic-datum->syntax $X $X-start-pos $X-end-pos))]))))
|
#`(list (atomic-datum->syntax $X $X-start-pos $X-end-pos))]))))
|
||||||
|
|
||||||
(define whole-rule-loc
|
(define whole-rule-loc
|
||||||
(if (empty? translated-patterns)
|
(if (empty? translated-patterns)
|
||||||
|
@ -247,7 +247,7 @@
|
||||||
(define-values (implicit explicit)
|
(define-values (implicit explicit)
|
||||||
(for/fold ([implicit '()]
|
(for/fold ([implicit '()]
|
||||||
[explicit (list (datum->syntax (first rules) 'EOF))])
|
[explicit (list (datum->syntax (first rules) 'EOF))])
|
||||||
([r (in-list rules)])
|
([r (in-list rules)])
|
||||||
(rule-collect-token-types r implicit explicit)))
|
(rule-collect-token-types r implicit explicit)))
|
||||||
(values (reverse implicit) (reverse explicit)))
|
(values (reverse implicit) (reverse explicit)))
|
||||||
|
|
||||||
|
@ -260,7 +260,7 @@
|
||||||
(let loop ([a-pattern a-pattern]
|
(let loop ([a-pattern a-pattern]
|
||||||
[implicit implicit]
|
[implicit implicit]
|
||||||
[explicit explicit])
|
[explicit explicit])
|
||||||
(syntax-case a-pattern (id lit token choice repeat maybe elide seq)
|
(syntax-case a-pattern (id lit token choice elide repeat maybe seq)
|
||||||
[(id val)
|
[(id val)
|
||||||
(values implicit explicit)]
|
(values implicit explicit)]
|
||||||
[(lit val)
|
[(lit val)
|
||||||
|
@ -275,12 +275,15 @@
|
||||||
[explicit explicit])
|
[explicit explicit])
|
||||||
([v (in-list (syntax->list #'(vals ...)))])
|
([v (in-list (syntax->list #'(vals ...)))])
|
||||||
(loop v implicit explicit))]
|
(loop v implicit explicit))]
|
||||||
|
[(elide vals ...)
|
||||||
|
(for/fold ([implicit implicit]
|
||||||
|
[explicit explicit])
|
||||||
|
([v (in-list (syntax->list #'(vals ...)))])
|
||||||
|
(loop v implicit explicit))]
|
||||||
[(repeat min val)
|
[(repeat min val)
|
||||||
(loop #'val implicit explicit)]
|
(loop #'val implicit explicit)]
|
||||||
[(maybe val)
|
[(maybe val)
|
||||||
(loop #'val implicit explicit)]
|
(loop #'val implicit explicit)]
|
||||||
[(elide val)
|
|
||||||
(loop #'val implicit explicit)]
|
|
||||||
[(seq vals ...)
|
[(seq vals ...)
|
||||||
(for/fold ([implicit implicit]
|
(for/fold ([implicit implicit]
|
||||||
[explicit explicit])
|
[explicit explicit])
|
||||||
|
@ -292,12 +295,12 @@
|
||||||
;; rule-id: rule -> identifier-stx
|
;; rule-id: rule -> identifier-stx
|
||||||
;; Get the binding id of a rule.
|
;; Get the binding id of a rule.
|
||||||
(define (rule-id a-rule)
|
(define (rule-id a-rule)
|
||||||
(syntax-case a-rule (rule)
|
(syntax-case a-rule (rule)
|
||||||
[(rule id a-pattern)
|
[(rule id a-pattern)
|
||||||
#'id]))
|
#'id]))
|
||||||
|
|
||||||
(define (rule-pattern a-rule)
|
(define (rule-pattern a-rule)
|
||||||
(syntax-case a-rule (rule)
|
(syntax-case a-rule (rule)
|
||||||
[(rule id a-pattern)
|
[(rule id a-pattern)
|
||||||
#'a-pattern]))
|
#'a-pattern]))
|
||||||
|
|
||||||
|
@ -309,26 +312,26 @@
|
||||||
(define table (make-free-id-table))
|
(define table (make-free-id-table))
|
||||||
;; Pass one: collect all the defined rule names.
|
;; Pass one: collect all the defined rule names.
|
||||||
(for ([a-rule (in-list rules)])
|
(for ([a-rule (in-list rules)])
|
||||||
(free-id-table-set! table (rule-id a-rule) #t))
|
(free-id-table-set! table (rule-id a-rule) #t))
|
||||||
;; Pass two: check each referenced id, and make sure it's been defined.
|
;; Pass two: check each referenced id, and make sure it's been defined.
|
||||||
(for ([a-rule (in-list rules)])
|
(for ([a-rule (in-list rules)])
|
||||||
(for ([referenced-id (in-list (rule-collect-used-ids a-rule))])
|
(for ([referenced-id (in-list (rule-collect-used-ids a-rule))])
|
||||||
(unless (free-id-table-ref table referenced-id (lambda () #f))
|
(unless (free-id-table-ref table referenced-id (lambda () #f))
|
||||||
(raise-syntax-error #f (format "Rule ~a has no definition" (syntax-e referenced-id))
|
(raise-syntax-error #f (format "Rule ~a has no definition" (syntax-e referenced-id))
|
||||||
referenced-id)))))
|
referenced-id)))))
|
||||||
|
|
||||||
;; check-all-rules-no-duplicates!: (listof rule-stx) -> void
|
;; check-all-rules-no-duplicates!: (listof rule-stx) -> void
|
||||||
(define (check-all-rules-no-duplicates! rules)
|
(define (check-all-rules-no-duplicates! rules)
|
||||||
(define table (make-free-id-table))
|
(define table (make-free-id-table))
|
||||||
;; Pass one: collect all the defined rule names.
|
;; Pass one: collect all the defined rule names.
|
||||||
(for ([a-rule (in-list rules)])
|
(for ([a-rule (in-list rules)])
|
||||||
(define maybe-other-rule-id (free-id-table-ref table (rule-id a-rule) (lambda () #f)))
|
(define maybe-other-rule-id (free-id-table-ref table (rule-id a-rule) (lambda () #f)))
|
||||||
(when maybe-other-rule-id
|
(when maybe-other-rule-id
|
||||||
(raise-syntax-error #f (format "Rule ~a has a duplicate definition" (syntax-e (rule-id a-rule)))
|
(raise-syntax-error #f (format "Rule ~a has a duplicate definition" (syntax-e (rule-id a-rule)))
|
||||||
(rule-id a-rule)
|
(rule-id a-rule)
|
||||||
#f
|
#f
|
||||||
(list (rule-id a-rule) maybe-other-rule-id)))
|
(list (rule-id a-rule) maybe-other-rule-id)))
|
||||||
(free-id-table-set! table (rule-id a-rule) (rule-id a-rule))))
|
(free-id-table-set! table (rule-id a-rule) (rule-id a-rule))))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
@ -344,7 +347,7 @@
|
||||||
(define (pattern-collect-used-ids a-pattern acc)
|
(define (pattern-collect-used-ids a-pattern acc)
|
||||||
(let loop ([a-pattern a-pattern]
|
(let loop ([a-pattern a-pattern]
|
||||||
[acc acc])
|
[acc acc])
|
||||||
(syntax-case a-pattern (id lit token choice repeat maybe elide seq)
|
(syntax-case a-pattern (id lit token choice elide repeat maybe seq)
|
||||||
[(id val)
|
[(id val)
|
||||||
(cons #'val acc)]
|
(cons #'val acc)]
|
||||||
[(lit val)
|
[(lit val)
|
||||||
|
@ -355,12 +358,14 @@
|
||||||
(for/fold ([acc acc])
|
(for/fold ([acc acc])
|
||||||
([v (in-list (syntax->list #'(vals ...)))])
|
([v (in-list (syntax->list #'(vals ...)))])
|
||||||
(loop v acc))]
|
(loop v acc))]
|
||||||
|
[(elide vals ...)
|
||||||
|
(for/fold ([acc acc])
|
||||||
|
([v (in-list (syntax->list #'(vals ...)))])
|
||||||
|
(loop v acc))]
|
||||||
[(repeat min val)
|
[(repeat min val)
|
||||||
(loop #'val acc)]
|
(loop #'val acc)]
|
||||||
[(maybe val)
|
[(maybe val)
|
||||||
(loop #'val acc)]
|
(loop #'val acc)]
|
||||||
[(elide val)
|
|
||||||
(loop #'val acc)]
|
|
||||||
[(seq vals ...)
|
[(seq vals ...)
|
||||||
(for/fold ([acc acc])
|
(for/fold ([acc acc])
|
||||||
([v (in-list (syntax->list #'(vals ...)))])
|
([v (in-list (syntax->list #'(vals ...)))])
|
||||||
|
@ -378,9 +383,9 @@
|
||||||
(define (check-all-rules-satisfiable! rules)
|
(define (check-all-rules-satisfiable! rules)
|
||||||
(define toplevel-rule-table (make-free-id-table))
|
(define toplevel-rule-table (make-free-id-table))
|
||||||
(for ([a-rule (in-list rules)])
|
(for ([a-rule (in-list rules)])
|
||||||
(free-id-table-set! toplevel-rule-table
|
(free-id-table-set! toplevel-rule-table
|
||||||
(rule-id a-rule)
|
(rule-id a-rule)
|
||||||
(sat:make-and)))
|
(sat:make-and)))
|
||||||
(define leaves '())
|
(define leaves '())
|
||||||
|
|
||||||
(define (make-leaf)
|
(define (make-leaf)
|
||||||
|
@ -389,7 +394,7 @@
|
||||||
a-leaf)
|
a-leaf)
|
||||||
|
|
||||||
(define (process-pattern a-pattern)
|
(define (process-pattern a-pattern)
|
||||||
(syntax-case a-pattern (id lit token choice repeat maybe elide seq)
|
(syntax-case a-pattern (id lit token choice elide repeat maybe seq)
|
||||||
[(id val)
|
[(id val)
|
||||||
(free-id-table-ref toplevel-rule-table #'val)]
|
(free-id-table-ref toplevel-rule-table #'val)]
|
||||||
[(lit val)
|
[(lit val)
|
||||||
|
@ -400,8 +405,15 @@
|
||||||
(begin
|
(begin
|
||||||
(define an-or-node (sat:make-or))
|
(define an-or-node (sat:make-or))
|
||||||
(for ([v (in-list (syntax->list #'(vals ...)))])
|
(for ([v (in-list (syntax->list #'(vals ...)))])
|
||||||
(define a-child (process-pattern v))
|
(define a-child (process-pattern v))
|
||||||
(sat:add-child! an-or-node a-child))
|
(sat:add-child! an-or-node a-child))
|
||||||
|
an-or-node)]
|
||||||
|
[(elide vals ...)
|
||||||
|
(begin
|
||||||
|
(define an-or-node (sat:make-or))
|
||||||
|
(for ([v (in-list (syntax->list #'(vals ...)))])
|
||||||
|
(define a-child (process-pattern v))
|
||||||
|
(sat:add-child! an-or-node a-child))
|
||||||
an-or-node)]
|
an-or-node)]
|
||||||
[(repeat min val)
|
[(repeat min val)
|
||||||
(syntax-case #'min ()
|
(syntax-case #'min ()
|
||||||
|
@ -411,25 +423,23 @@
|
||||||
(process-pattern #'val)])]
|
(process-pattern #'val)])]
|
||||||
[(maybe val)
|
[(maybe val)
|
||||||
(make-leaf)]
|
(make-leaf)]
|
||||||
[(elide val)
|
|
||||||
(make-leaf)]
|
|
||||||
[(seq vals ...)
|
[(seq vals ...)
|
||||||
(begin
|
(begin
|
||||||
(define an-and-node (sat:make-and))
|
(define an-and-node (sat:make-and))
|
||||||
(for ([v (in-list (syntax->list #'(vals ...)))])
|
(for ([v (in-list (syntax->list #'(vals ...)))])
|
||||||
(define a-child (process-pattern v))
|
(define a-child (process-pattern v))
|
||||||
(sat:add-child! an-and-node a-child))
|
(sat:add-child! an-and-node a-child))
|
||||||
an-and-node)]))
|
an-and-node)]))
|
||||||
|
|
||||||
(for ([a-rule (in-list rules)])
|
(for ([a-rule (in-list rules)])
|
||||||
(define rule-node (free-id-table-ref toplevel-rule-table (rule-id a-rule)))
|
(define rule-node (free-id-table-ref toplevel-rule-table (rule-id a-rule)))
|
||||||
(sat:add-child! rule-node (process-pattern (rule-pattern a-rule))))
|
(sat:add-child! rule-node (process-pattern (rule-pattern a-rule))))
|
||||||
|
|
||||||
(for ([a-leaf leaves])
|
(for ([a-leaf leaves])
|
||||||
(sat:visit! a-leaf))
|
(sat:visit! a-leaf))
|
||||||
|
|
||||||
(for ([a-rule (in-list rules)])
|
(for ([a-rule (in-list rules)])
|
||||||
(define rule-node (free-id-table-ref toplevel-rule-table (rule-id a-rule)))
|
(define rule-node (free-id-table-ref toplevel-rule-table (rule-id a-rule)))
|
||||||
(unless (sat:node-yes? rule-node)
|
(unless (sat:node-yes? rule-node)
|
||||||
(raise-syntax-error #f (format "Rule ~a has no finite derivation" (syntax-e (rule-id a-rule)))
|
(raise-syntax-error #f (format "Rule ~a has no finite derivation" (syntax-e (rule-id a-rule)))
|
||||||
(rule-id a-rule)))))
|
(rule-id a-rule)))))
|
||||||
|
|
|
@ -72,7 +72,7 @@
|
||||||
[origin (syntax-case a-rule (rule) [(rule name (pat-head rest ...)) #'pat-head])])
|
[origin (syntax-case a-rule (rule) [(rule name (pat-head rest ...)) #'pat-head])])
|
||||||
(syntax-case a-rule (rule)
|
(syntax-case a-rule (rule)
|
||||||
[(rule name pat)
|
[(rule name pat)
|
||||||
(syntax-case #'pat (id inferred-id lit token choice repeat maybe elide seq)
|
(syntax-case #'pat (id inferred-id lit token choice elide repeat maybe seq)
|
||||||
|
|
||||||
;; The primitive types stay as they are:
|
;; The primitive types stay as they are:
|
||||||
[(id val)
|
[(id val)
|
||||||
|
@ -98,6 +98,18 @@
|
||||||
(append (list #'(head origin name [sub-pat ...] ...))
|
(append (list #'(head origin name [sub-pat ...] ...))
|
||||||
(apply append (reverse inferred-ruless/rev)))))]
|
(apply append (reverse inferred-ruless/rev)))))]
|
||||||
|
|
||||||
|
[(elide sub-pat ...)
|
||||||
|
(begin
|
||||||
|
(define-values (inferred-ruless/rev new-sub-patss/rev)
|
||||||
|
(for/fold ([rs '()] [ps '()])
|
||||||
|
([p (syntax->list #'(sub-pat ...))])
|
||||||
|
(let-values ([(new-r new-p)
|
||||||
|
(lift-nonprimitive-pattern p)])
|
||||||
|
(values (cons new-r rs) (cons new-p ps)))))
|
||||||
|
(with-syntax ([((sub-pat ...) ...) (reverse new-sub-patss/rev)])
|
||||||
|
(append (list #'(head origin name [sub-pat ...] ...))
|
||||||
|
(apply append (reverse inferred-ruless/rev)))))]
|
||||||
|
|
||||||
[(repeat min sub-pat)
|
[(repeat min sub-pat)
|
||||||
(begin
|
(begin
|
||||||
(define-values (inferred-rules new-sub-pats)
|
(define-values (inferred-rules new-sub-pats)
|
||||||
|
@ -123,16 +135,6 @@
|
||||||
[])
|
[])
|
||||||
inferred-rules)))]
|
inferred-rules)))]
|
||||||
|
|
||||||
[(elide sub-pat)
|
|
||||||
(begin
|
|
||||||
(define-values (inferred-rules new-sub-pats)
|
|
||||||
(lift-nonprimitive-pattern #'sub-pat))
|
|
||||||
(with-syntax ([(sub-pat ...) new-sub-pats])
|
|
||||||
(cons #'(head origin name
|
|
||||||
[sub-pat ...]
|
|
||||||
[])
|
|
||||||
inferred-rules)))]
|
|
||||||
|
|
||||||
[(seq sub-pat ...)
|
[(seq sub-pat ...)
|
||||||
(begin
|
(begin
|
||||||
(define-values (inferred-rules new-sub-pats)
|
(define-values (inferred-rules new-sub-pats)
|
||||||
|
@ -149,7 +151,7 @@
|
||||||
|
|
||||||
;; Returns true if the pattern looks primitive
|
;; Returns true if the pattern looks primitive
|
||||||
(define (primitive-pattern? a-pat)
|
(define (primitive-pattern? a-pat)
|
||||||
(syntax-case a-pat (id lit token choice repeat maybe elide seq)
|
(syntax-case a-pat (id lit token choice elide repeat maybe seq)
|
||||||
[(id val)
|
[(id val)
|
||||||
#t]
|
#t]
|
||||||
[(lit val)
|
[(lit val)
|
||||||
|
@ -158,12 +160,12 @@
|
||||||
#t]
|
#t]
|
||||||
[(choice sub-pat ...)
|
[(choice sub-pat ...)
|
||||||
#f]
|
#f]
|
||||||
|
[(elide sub-pat)
|
||||||
|
#f]
|
||||||
[(repeat min val)
|
[(repeat min val)
|
||||||
#f]
|
#f]
|
||||||
[(maybe sub-pat)
|
[(maybe sub-pat)
|
||||||
#f]
|
#f]
|
||||||
[(elide sub-pat)
|
|
||||||
#f]
|
|
||||||
[(seq sub-pat ...)
|
[(seq sub-pat ...)
|
||||||
(andmap primitive-pattern? (syntax->list #'(sub-pat ...)))]))
|
(andmap primitive-pattern? (syntax->list #'(sub-pat ...)))]))
|
||||||
|
|
||||||
|
|
|
@ -1,10 +1,9 @@
|
||||||
#lang br/ragg
|
#lang br/ragg
|
||||||
|
|
||||||
;; Simple baby example of JSON structure
|
;; Simple baby example of JSON structure
|
||||||
json: number | string
|
json: <number | string
|
||||||
| array
|
| array
|
||||||
| object
|
| object>
|
||||||
|
|
||||||
number: NUMBER
|
number: NUMBER
|
||||||
|
|
||||||
string: STRING
|
string: STRING
|
||||||
|
@ -13,4 +12,4 @@ array: "[" [json ("," json)*] "]"
|
||||||
|
|
||||||
object: "{" [kvpair ("," kvpair)*] "}"
|
object: "{" [kvpair ("," kvpair)*] "}"
|
||||||
|
|
||||||
kvpair: ID <":"> json
|
kvpair: ID ":" json
|
||||||
|
|
|
@ -11,7 +11,7 @@
|
||||||
(token 'STRING "'hello world'")
|
(token 'STRING "'hello world'")
|
||||||
"}")))
|
"}")))
|
||||||
'(json (object "{"
|
'(json (object "{"
|
||||||
(kvpair "message" (json (string "'hello world'")))
|
(kvpair "message" ":" (json (string "'hello world'")))
|
||||||
"}")))
|
"}")))
|
||||||
|
|
||||||
|
|
||||||
|
|
|
@ -14,7 +14,7 @@
|
||||||
(define-lex-abbrevs
|
(define-lex-abbrevs
|
||||||
[letter (:or (:/ "a" "z") (:/ #\A #\Z))]
|
[letter (:or (:/ "a" "z") (:/ #\A #\Z))]
|
||||||
[digit (:/ #\0 #\9)]
|
[digit (:/ #\0 #\9)]
|
||||||
[id-char (:or letter digit (char-set "-.!$%&/<=>?^_~@"))]
|
[id-char (:or letter digit (char-set "-.!$%&/=?^_~@"))]
|
||||||
)
|
)
|
||||||
|
|
||||||
(define-lex-abbrev id
|
(define-lex-abbrev id
|
||||||
|
|
|
@ -10,10 +10,10 @@
|
||||||
(provide tokens
|
(provide tokens
|
||||||
token-LPAREN
|
token-LPAREN
|
||||||
token-RPAREN
|
token-RPAREN
|
||||||
token-LBRACKET
|
|
||||||
token-RBRACKET
|
|
||||||
token-LANGLE ; for elider
|
token-LANGLE ; for elider
|
||||||
token-RANGLE ; for elider
|
token-RANGLE ; for elider
|
||||||
|
token-LBRACKET
|
||||||
|
token-RBRACKET
|
||||||
token-PIPE
|
token-PIPE
|
||||||
token-REPEAT
|
token-REPEAT
|
||||||
token-RULE_HEAD
|
token-RULE_HEAD
|
||||||
|
@ -32,9 +32,9 @@
|
||||||
[struct-out pattern-lit]
|
[struct-out pattern-lit]
|
||||||
[struct-out pattern-token]
|
[struct-out pattern-token]
|
||||||
[struct-out pattern-choice]
|
[struct-out pattern-choice]
|
||||||
|
[struct-out pattern-elide]
|
||||||
[struct-out pattern-repeat]
|
[struct-out pattern-repeat]
|
||||||
[struct-out pattern-maybe]
|
[struct-out pattern-maybe]
|
||||||
[struct-out pattern-elide]
|
|
||||||
[struct-out pattern-seq])
|
[struct-out pattern-seq])
|
||||||
|
|
||||||
(define-tokens tokens (LPAREN
|
(define-tokens tokens (LPAREN
|
||||||
|
@ -49,7 +49,7 @@
|
||||||
ID
|
ID
|
||||||
LIT
|
LIT
|
||||||
EOF))
|
EOF))
|
||||||
|
(require sugar/debug)
|
||||||
;; grammar-parser: (-> token) -> (listof rule)
|
;; grammar-parser: (-> token) -> (listof rule)
|
||||||
(define grammar-parser
|
(define grammar-parser
|
||||||
(parser
|
(parser
|
||||||
|
@ -145,12 +145,10 @@
|
||||||
(position->pos $3-end-pos)
|
(position->pos $3-end-pos)
|
||||||
$2)]
|
$2)]
|
||||||
|
|
||||||
[(LANGLE pattern RANGLE)
|
|
||||||
(pattern-elide (position->pos $1-start-pos)
|
|
||||||
(position->pos $3-end-pos)
|
|
||||||
$2)]
|
|
||||||
|
|
||||||
[(LPAREN pattern RPAREN)
|
[(LPAREN pattern RPAREN)
|
||||||
|
(relocate-pattern $2 (position->pos $1-start-pos) (position->pos $3-end-pos))]
|
||||||
|
|
||||||
|
[(LANGLE pattern RANGLE)
|
||||||
(relocate-pattern $2 (position->pos $1-start-pos) (position->pos $3-end-pos))]])
|
(relocate-pattern $2 (position->pos $1-start-pos) (position->pos $3-end-pos))]])
|
||||||
|
|
||||||
|
|
||||||
|
@ -170,12 +168,12 @@
|
||||||
(pattern-lit start-pos end-pos v)]
|
(pattern-lit start-pos end-pos v)]
|
||||||
[(pattern-choice _ _ vs)
|
[(pattern-choice _ _ vs)
|
||||||
(pattern-choice start-pos end-pos vs)]
|
(pattern-choice start-pos end-pos vs)]
|
||||||
|
[(pattern-elide _ _ vs)
|
||||||
|
(pattern-elide start-pos end-pos vs)]
|
||||||
[(pattern-repeat _ _ m v)
|
[(pattern-repeat _ _ m v)
|
||||||
(pattern-repeat start-pos end-pos m v)]
|
(pattern-repeat start-pos end-pos m v)]
|
||||||
[(pattern-maybe _ _ v)
|
[(pattern-maybe _ _ v)
|
||||||
(pattern-maybe start-pos end-pos v)]
|
(pattern-maybe start-pos end-pos v)]
|
||||||
[(pattern-elide _ _ v)
|
|
||||||
(pattern-elide start-pos end-pos v)]
|
|
||||||
[(pattern-seq _ _ vs)
|
[(pattern-seq _ _ vs)
|
||||||
(pattern-seq start-pos end-pos vs)]
|
(pattern-seq start-pos end-pos vs)]
|
||||||
[else
|
[else
|
||||||
|
|
|
@ -35,6 +35,9 @@
|
||||||
(struct pattern-choice pattern (vals)
|
(struct pattern-choice pattern (vals)
|
||||||
#:transparent)
|
#:transparent)
|
||||||
|
|
||||||
|
(struct pattern-elide pattern (val)
|
||||||
|
#:transparent)
|
||||||
|
|
||||||
(struct pattern-repeat pattern (min ;; either 0 or 1
|
(struct pattern-repeat pattern (min ;; either 0 or 1
|
||||||
val)
|
val)
|
||||||
#:transparent)
|
#:transparent)
|
||||||
|
@ -42,9 +45,6 @@
|
||||||
(struct pattern-maybe pattern (val)
|
(struct pattern-maybe pattern (val)
|
||||||
#:transparent)
|
#:transparent)
|
||||||
|
|
||||||
(struct pattern-elide pattern (val)
|
|
||||||
#:transparent)
|
|
||||||
|
|
||||||
(struct pattern-seq pattern (vals)
|
(struct pattern-seq pattern (vals)
|
||||||
#:transparent)
|
#:transparent)
|
||||||
|
|
||||||
|
|
|
@ -11,7 +11,7 @@
|
||||||
(define (lit stx) (raise-syntax-error #f "Used out of context of rules" stx))
|
(define (lit stx) (raise-syntax-error #f "Used out of context of rules" stx))
|
||||||
(define (token stx) (raise-syntax-error #f "Used out of context of rules" stx))
|
(define (token stx) (raise-syntax-error #f "Used out of context of rules" stx))
|
||||||
(define (choice stx) (raise-syntax-error #f "Used out of context of rules" stx))
|
(define (choice stx) (raise-syntax-error #f "Used out of context of rules" stx))
|
||||||
|
(define (elide stx) (raise-syntax-error #f "Used out of context of rules" stx))
|
||||||
(define (repeat stx) (raise-syntax-error #f "Used out of context of rules" stx))
|
(define (repeat stx) (raise-syntax-error #f "Used out of context of rules" stx))
|
||||||
(define (maybe stx) (raise-syntax-error #f "Used out of context of rules" stx))
|
(define (maybe stx) (raise-syntax-error #f "Used out of context of rules" stx))
|
||||||
(define (elide stx) (raise-syntax-error #f "Used out of context of rules" stx))
|
|
||||||
(define (seq stx) (raise-syntax-error #f "Used out of context of rules" stx))
|
(define (seq stx) (raise-syntax-error #f "Used out of context of rules" stx))
|
|
@ -67,12 +67,12 @@
|
||||||
`(token ,(datum->syntax #f (string->symbol val) source-location))]
|
`(token ,(datum->syntax #f (string->symbol val) source-location))]
|
||||||
[(struct pattern-choice (start end vals))
|
[(struct pattern-choice (start end vals))
|
||||||
`(choice ,@(map recur vals))]
|
`(choice ,@(map recur vals))]
|
||||||
|
[(struct pattern-elide (start end vals))
|
||||||
|
`(elide ,@(map recur vals))]
|
||||||
[(struct pattern-repeat (start end min val))
|
[(struct pattern-repeat (start end min val))
|
||||||
`(repeat ,min ,(recur val))]
|
`(repeat ,min ,(recur val))]
|
||||||
[(struct pattern-maybe (start end val))
|
[(struct pattern-maybe (start end val))
|
||||||
`(maybe ,(recur val))]
|
`(maybe ,(recur val))]
|
||||||
[(struct pattern-elide (start end val))
|
|
||||||
`(elide ,(recur val))]
|
|
||||||
[(struct pattern-seq (start end vals))
|
[(struct pattern-seq (start end vals))
|
||||||
`(seq ,@(map recur vals))])
|
`(seq ,@(map recur vals))])
|
||||||
source-location))
|
source-location))
|
||||||
|
|
Loading…
Reference in New Issue
Block a user