mbutterick
/
brag
1
0
Fork 0
Code Issues 3 Pull Requests 1 Projects Releases Wiki Activity

make better procedure name

Browse Source
pull/2/head
Matthew Butterick 7 years ago
parent 406234934f
commit 039df34f88
1 changed files with 62 additions and 60 deletions
Show Stats Download Patch File Download Diff File

122
brag/brag/codegen/codegen.rkt
Unescape Escape View File

@ -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))
@ -144,13 +144,15 @@
(end EOF) (end EOF)
(error THE-ERROR-HANDLER) (error THE-ERROR-HANDLER)
generated-grammar)]) generated-grammar)])
(case-lambda [(tokenizer) (procedure-rename
(define next-token (case-lambda [(tokenizer)
(make-permissive-tokenizer tokenizer all-tokens-hash/mutable)) (define next-token
(THE-GRAMMAR next-token)] (make-permissive-tokenizer tokenizer all-tokens-hash/mutable))
[(source tokenizer) (THE-GRAMMAR next-token)]
(parameterize ([current-source source]) [(source tokenizer)
(parse tokenizer))])))])) (parameterize ([current-source source])
(parse tokenizer))])
(string->symbol (format "~a-rule-parser" 'start-rule)))))]))
(define parse (make-rule-parser start-id)) (define parse (make-rule-parser start-id))
(provide parse-to-datum parse-tree) (provide parse-to-datum parse-tree)
@ -209,33 +211,33 @@
(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)])
(if (eq? (syntax-property primitive-pattern 'hide) 'hide) (if (eq? (syntax-property primitive-pattern 'hide) 'hide)
#'null #'null
(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)
;; at this point, the 'hide property is either #f or "splice" ;; at this point, the 'hide property is either #f or "splice"
;; ('hide value is handled at the top of this conditional ;; ('hide value is handled at the top of this conditional
;; we need to use boolean because a symbol is treated as an identifier. ;; we need to use boolean because a symbol is treated as an identifier.
;; also we'll separate it into its own property for clarity and test for it in "runtime.rkt" ;; also we'll separate it into its own property for clarity and test for it in "runtime.rkt"
#`(list (syntax-property $X 'splice-rh-id #,(and (syntax-property primitive-pattern 'hide) #t)))] #`(list (syntax-property $X 'splice-rh-id #,(and (syntax-property primitive-pattern 'hide) #t)))]
[(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)
@ -326,26 +328,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))))
@ -393,9 +395,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)
@ -415,8 +417,8 @@
(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)] an-or-node)]
[(repeat min val) [(repeat min val)
(syntax-case #'min () (syntax-case #'min ()
@ -430,19 +432,19 @@
(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)))))

Write Preview
Loading…
Cancel
Save