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

morefac

Browse Source
hide-top-rule-name
Matthew Butterick 7 years ago
parent c3b887e219
commit b5c75eee64
1 changed files with 108 additions and 140 deletions
Show Stats Download Patch File Download Diff File

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

@ -21,14 +21,11 @@
#:parser-provider-module [parser-provider-module 'br-parser-tools/yacc] #:parser-provider-module [parser-provider-module 'br-parser-tools/yacc]
#:parser-provider-form [parser-provider-form 'parser]) #:parser-provider-form [parser-provider-form 'parser])
(syntax-case rules-stx () (syntax-case rules-stx ()
[(_) [(_) (raise-syntax-error 'brag
(raise-syntax-error 'brag (format "The grammar does not appear to have any rules")
(format "The grammar does not appear to have any rules") rules-stx)]
rules-stx)] [(_ . RULES)
[(_ RULE ...) (let ([rules (syntax->list #'RULES)]) ;; (listof stx)
(begin
;; (listof stx)
(define rules (syntax->list #'(RULE ...)))
(check-all-rules-defined! rules) (check-all-rules-defined! rules)
(check-all-rules-no-duplicates! rules) (check-all-rules-no-duplicates! rules)
@ -39,33 +36,20 @@
(define generated-rule-codes (map flat-rule->yacc-rule (flatten-rules rules))) (define generated-rule-codes (map flat-rule->yacc-rule (flatten-rules rules)))
(define rule-ids (map rule-id rules)) (define rule-ids (map rule-id rules))
(define-values (implicit-tokens ;; (listof identifier) (define token-types ;; (listof symbol)
explicit-tokens) ;; (listof identifier) (let-values ([(implicit-tokens ;; (listof identifier)
(rules-collect-token-types rules)) explicit-tokens) ;; (listof identifier)
(rules-collect-token-types rules)])
(remove-duplicates (append (map string->symbol (map syntax-e implicit-tokens))
(map syntax-e explicit-tokens)) eq?)))
;; (listof symbol) (with-syntax ([START-ID (first rule-ids)] ; The first rule, by default, is the start rule.
(define implicit-token-types [(TOKEN-TYPE ...) token-types]
(map string->symbol (remove-duplicates (map syntax-e implicit-tokens)))) [(TOKEN-TYPE-CONSTRUCTOR ...) (for/list ([tt (in-list token-types)])
;; (listof symbol)
(define explicit-token-types (remove-duplicates (map syntax-e explicit-tokens)))
;; (listof symbol)
(define token-types
(remove-duplicates (append implicit-token-types explicit-token-types)))
(with-syntax ([start-id (first rule-ids)] ; The first rule, by default, is the start rule.
[(token-type ...) token-types]
[(token-type-constructor ...) (for/list ([tt (in-list token-types)])
(string->symbol (format "token-~a" tt)))] (string->symbol (format "token-~a" tt)))]
[(explicit-token-types ...) explicit-token-types] [GENERATED-GRAMMAR `(grammar ,@generated-rule-codes)]
[(implicit-token-types ...) implicit-token-types] [PARSER-MODULE parser-provider-module]
[(implicit-token-types-str ...) (map symbol->string implicit-token-types)] [PARSER-FORM parser-provider-form]
[(implicit-token-type-constructor ...) (for/list ([itt (in-list implicit-token-types)])
(string->symbol (format "token-~a" itt)))]
[generated-grammar `(grammar ,@generated-rule-codes)]
[parser-module parser-provider-module]
[parser-form parser-provider-form]
[PARSE (syntax-local-introduce (or (syntax-property rules-stx 'parse) (error 'no-parse-id-prop)))] [PARSE (syntax-local-introduce (or (syntax-property rules-stx 'parse) (error 'no-parse-id-prop)))]
[PARSE-TO-DATUM (syntax-local-introduce (or (syntax-property rules-stx 'parse-to-datum) (error 'no-parse-to-datum-id-prop)))] [PARSE-TO-DATUM (syntax-local-introduce (or (syntax-property rules-stx 'parse-to-datum) (error 'no-parse-to-datum-id-prop)))]
[PARSE-TREE (syntax-local-introduce (or (syntax-property rules-stx 'parse-tree) (error 'no-parse-tree-id-prop)))] [PARSE-TREE (syntax-local-introduce (or (syntax-property rules-stx 'parse-tree) (error 'no-parse-tree-id-prop)))]
@ -80,7 +64,7 @@
(quasisyntax/loc rules-stx (quasisyntax/loc rules-stx
(begin (begin
(require br-parser-tools/lex (require br-parser-tools/lex
parser-module PARSER-MODULE
brag/codegen/runtime brag/codegen/runtime
brag/support brag/support
brag/private/internal-support brag/private/internal-support
@ -98,50 +82,49 @@
(define APPLY-LEXER apply-lexer) (define APPLY-LEXER apply-lexer)
(define APPLY-TOKENIZER-MAKER apply-tokenizer-maker) (define APPLY-TOKENIZER-MAKER apply-tokenizer-maker)
(define-tokens enumerated-tokens (token-type ...)) (define-tokens enumerated-tokens (TOKEN-TYPE ...))
;; all-token-types lists all the tokens (except for EOF) ;; all-token-types lists all the tokens (except for EOF)
(define ALL-TOKEN-TYPES (set-remove (set 'token-type ...) 'EOF)) (define ALL-TOKEN-TYPES (set-remove (set 'TOKEN-TYPE ...) 'EOF))
;; 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-syntax (MAKE-RULE-PARSER rule-id-stx) (define-syntax (MAKE-RULE-PARSER rule-id-stx)
(syntax-case rule-id-stx () (syntax-case rule-id-stx ()
[(_ start-rule) [(_ start-rule)
(and (identifier? #'start-rule) (and (identifier? #'start-rule)
(member (syntax-e #'start-rule) '#,(map syntax-e rule-ids))) (member (syntax-e #'start-rule) '#,(map syntax-e rule-ids)))
(let () ;; HACK HACK HACK
;; HACK HACK HACK ;; The cfg-parser depends on the start-rule provided in (start ...) to have the same
;; The cfg-parser depends on the start-rule provided in (start ...) to have the same ;; context as the rest of this body, so I need to hack this. I don't like this, but
;; context as the rest of this body, so I need to hack this. I don't like this, but ;; I don't know what else to do. Hence recolored-start-rule.
;; I don't know what else to do. Hence recolored-start-rule. (with-syntax ([RECOLORED-START-RULE (datum->syntax #'#,rules-stx (syntax-e #'start-rule))])
(with-syntax ([RECOLORED-START-RULE (datum->syntax #'#,rules-stx (syntax-e #'start-rule))]) #'(let ([THE-GRAMMAR (PARSER-FORM (tokens enumerated-tokens)
#'(let ([THE-GRAMMAR (parser-form (tokens enumerated-tokens) (src-pos)
(src-pos) (start RECOLORED-START-RULE)
(start RECOLORED-START-RULE) (end EOF)
(end EOF) (error THE-ERROR-HANDLER)
(error THE-ERROR-HANDLER) GENERATED-GRAMMAR)])
generated-grammar)]) (procedure-rename
(procedure-rename (case-lambda [(tokenizer)
(case-lambda [(tokenizer) (define next-token
(define next-token (make-permissive-tokenizer tokenizer all-tokens-hash/mutable))
(make-permissive-tokenizer tokenizer all-tokens-hash/mutable)) (THE-GRAMMAR next-token)]
(THE-GRAMMAR next-token)] [(source tokenizer)
[(source tokenizer) (parameterize ([current-source source])
(parameterize ([current-source source]) (PARSE tokenizer))])
(PARSE tokenizer))]) (string->symbol (format "~a-rule-parser" 'start-rule)))))]
(string->symbol (format "~a-rule-parser" 'start-rule))))))] [(_ not-a-rule-id)
[(_ start-rule)
(raise-syntax-error #f (raise-syntax-error #f
(format "Rule ~a is not defined in the grammar" (syntax-e #'start-rule)) (format "Rule ~a is not defined in the grammar" (syntax-e #'not-a-rule-id))
rule-id-stx)])) rule-id-stx)]))
(define PARSE (procedure-rename (MAKE-RULE-PARSER start-id) 'PARSE)) (define PARSE (procedure-rename (MAKE-RULE-PARSER START-ID) 'PARSE))
(define (PARSE-TO-DATUM x) (define (PARSE-TO-DATUM x)
(let loop ([x (syntax->datum (PARSE x))]) (let loop ([x (syntax->datum (PARSE x))])
@ -162,7 +145,7 @@
(define (flat-rule->yacc-rule a-flat-rule) (define (flat-rule->yacc-rule a-flat-rule)
(syntax-case a-flat-rule () (syntax-case a-flat-rule ()
[(rule-type origin name . clauses) [(rule-type origin name . clauses)
(with-syntax ([translated-clauses (for/list ([clause-stx (syntax->list #'clauses)]) (with-syntax ([translated-clauses (for/list ([clause-stx (in-list (syntax->list #'clauses))])
(translate-clause clause-stx #'name #'origin))]) (translate-clause clause-stx #'name #'origin))])
#'[name . translated-clauses])])) #'[name . translated-clauses])]))
@ -190,20 +173,17 @@
(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 (in-list (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 (format-id translated-pattern "$~a-start-pos" pos)]
[$X-start-pos [$X-end-pos (format-id translated-pattern "$~a-end-pos" pos)])
(format-id translated-pattern "$~a-start-pos" pos)]
[$X-end-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 ()
@ -249,43 +229,37 @@
(define-values (implicit explicit) (define-values (implicit explicit)
(for/fold ([implicit null] (for/fold ([implicit null]
[explicit (list (datum->syntax (first rules) 'EOF))]) [explicit (list (datum->syntax (first rules) 'EOF))])
([r (in-list rules)]) ([a-rule (in-list rules)])
(rule-collect-token-types r implicit explicit))) (syntax-case a-rule (rule)
[(rule _ a-pattern)
(let loop ([a-pattern #'a-pattern]
[implicit implicit]
[explicit explicit])
(syntax-case a-pattern (id lit token choice repeat maybe seq EOF)
[(id val)
(values implicit explicit)]
[(lit val)
(values (cons #'val implicit) explicit)]
[(token EOF)
(raise-syntax-error #f "Token EOF is reserved and can not be used in a grammar" #'val)]
[(token val)
(values implicit (cons #'val explicit))]
[(choice . vals)
(for/fold ([implicit implicit]
[explicit explicit])
([v (in-list (syntax->list #'vals))])
(loop v implicit explicit))]
[(repeat min max val)
(loop #'val implicit explicit)]
[(maybe val)
(loop #'val implicit explicit)]
[(seq . vals)
(for/fold ([implicit implicit]
[explicit explicit])
([v (in-list (syntax->list #'vals))])
(loop v implicit explicit))]))])))
(values (reverse implicit) (reverse explicit))) (values (reverse implicit) (reverse explicit)))
(define (rule-collect-token-types a-rule implicit explicit)
(syntax-case a-rule (rule)
[(rule id a-pattern)
(pattern-collect-implicit-token-types #'a-pattern implicit explicit)]))
(define (pattern-collect-implicit-token-types a-pattern implicit explicit)
(let loop ([a-pattern a-pattern]
[implicit implicit]
[explicit explicit])
(syntax-case a-pattern (id lit token choice repeat maybe seq EOF)
[(id val)
(values implicit explicit)]
[(lit val)
(values (cons #'val implicit) explicit)]
[(token EOF)
(raise-syntax-error #f "Token EOF is reserved and can not be used in a grammar" #'val)]
[(token val)
(values implicit (cons #'val explicit))]
[(choice vals ...)
(for/fold ([implicit implicit]
[explicit explicit])
([v (in-list (syntax->list #'(vals ...)))])
(loop v implicit explicit))]
[(repeat min max val)
(loop #'val implicit explicit)]
[(maybe val)
(loop #'val implicit explicit)]
[(seq vals ...)
(for/fold ([implicit implicit]
[explicit explicit])
([v (in-list (syntax->list #'(vals ...)))])
(loop v implicit explicit))])))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; rule-id: rule -> identifier-stx ;; rule-id: rule -> identifier-stx
@ -336,7 +310,7 @@
(define (rule-collect-used-ids a-rule) (define (rule-collect-used-ids a-rule)
(syntax-case a-rule (rule) (syntax-case a-rule (rule)
[(rule id a-pattern) [(rule id a-pattern)
(pattern-collect-used-ids #'a-pattern '())])) (pattern-collect-used-ids #'a-pattern null)]))
;; pattern-collect-used-ids: pattern-stx (listof identifier) -> (listof identifier) ;; pattern-collect-used-ids: pattern-stx (listof identifier) -> (listof identifier)
;; Returns a flat list of rule identifiers referenced in the pattern. ;; Returns a flat list of rule identifiers referenced in the pattern.
@ -350,17 +324,17 @@
acc] acc]
[(token val) [(token val)
acc] acc]
[(choice vals ...) [(choice . vals)
(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))]
[(repeat min max val) [(repeat min max val)
(loop #'val acc)] (loop #'val acc)]
[(maybe val) [(maybe val)
(loop #'val acc)] (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))])
(loop v acc))]))) (loop v acc))])))
@ -373,11 +347,10 @@
;; ;;
;; NOTE: Assumes all referenced rules have definitions. ;; NOTE: Assumes all referenced rules have definitions.
(define (check-all-rules-satisfiable! rules) (define (check-all-rules-satisfiable! rules)
(define toplevel-rule-table (make-free-id-table)) (define toplevel-rule-table
(for ([a-rule (in-list rules)]) (make-free-id-table (for/list ([a-rule (in-list rules)])
(free-id-table-set! toplevel-rule-table (cons (rule-id a-rule) (sat:make-and)))))
(rule-id a-rule)
(sat:make-and)))
(define leaves null) (define leaves null)
(define (make-leaf) (define (make-leaf)
@ -393,38 +366,33 @@
(make-leaf)] (make-leaf)]
[(token val) [(token val)
(make-leaf)] (make-leaf)]
[(choice vals ...) [(choice . vals)
(begin (let ([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 ...)))]) [a-child (in-value (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 max val) [(repeat min max val)
(syntax-case #'min () (syntax-case #'min ()
[0 [0 (make-leaf)]
(make-leaf)] [_ (process-pattern #'val)])]
[else [(maybe val) (make-leaf)]
(process-pattern #'val)])] [(seq . vals)
[(maybe val) (let ([an-and-node (sat:make-and)])
(make-leaf)] (for* ([v (in-list (syntax->list #'vals))]
[(seq vals ...) [a-child (in-value (process-pattern v))])
(begin
(define an-and-node (sat:make-and))
(for ([v (in-list (syntax->list #'(vals ...)))])
(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))) [rule-node (in-value (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-each sat:visit! leaves)
(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))) [rule-node (in-value (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
(rule-id a-rule))))) (format "Rule ~a has no finite derivation" (syntax-e (rule-id a-rule)))
(rule-id a-rule))))

Write Preview
Loading…
Cancel
Save