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

refac

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

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

@ -2,7 +2,6 @@
(require (for-template racket/base) (require (for-template racket/base)
racket/list racket/list
racket/set
racket/syntax racket/syntax
syntax/srcloc syntax/srcloc
brag/rules/stx-types brag/rules/stx-types
@ -22,31 +21,23 @@
#: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
(format "The grammar does not appear to have any rules")
rules-stx)]
[(_ RULE ...) [(_ RULE ...)
(begin (begin
;; (listof stx) ;; (listof stx)
(define rules (syntax->list #'(RULE ...))) (define rules (syntax->list #'(RULE ...)))
(when (empty? rules)
(raise-syntax-error 'brag
(format "The grammar does not appear to have any rules")
rules-stx))
(check-all-rules-defined! rules) (check-all-rules-defined! rules)
(check-all-rules-no-duplicates! rules) (check-all-rules-no-duplicates! rules)
(check-all-rules-satisfiable! rules) (check-all-rules-satisfiable! rules)
;; We flatten the rules so we can use the yacc-style ruleset that br-parser-tools ;; We flatten the rules so we can use
;; supports. ;; the yacc-style ruleset that br-parser-tools supports.
(define flattened-rules (flatten-rules rules)) (define generated-rule-codes (map flat-rule->yacc-rule (flatten-rules rules)))
(define rule-ids (map rule-id rules))
(define generated-rule-codes (map flat-rule->yacc-rule flattened-rules))
;; The first rule, by default, is the start rule.
(define rule-ids (for/list ([a-rule (in-list rules)])
(rule-id a-rule)))
(define start-id (first rule-ids))
(define-values (implicit-tokens ;; (listof identifier) (define-values (implicit-tokens ;; (listof identifier)
explicit-tokens) ;; (listof identifier) explicit-tokens) ;; (listof identifier)
@ -54,34 +45,25 @@
;; (listof symbol) ;; (listof symbol)
(define implicit-token-types (define implicit-token-types
(map string->symbol (map string->symbol (remove-duplicates (map syntax-e implicit-tokens))))
(set->list (list->set (map syntax-e implicit-tokens)))))
;; (listof symbol) ;; (listof symbol)
(define explicit-token-types (define explicit-token-types (remove-duplicates (map syntax-e explicit-tokens)))
(set->list (list->set (map syntax-e explicit-tokens))))
;; (listof symbol) ;; (listof symbol)
(define token-types (define token-types
(set->list (list->set (append (map (lambda (x) (string->symbol (syntax-e x))) (remove-duplicates (append implicit-token-types explicit-token-types)))
implicit-tokens)
(map syntax-e explicit-tokens)))))
(with-syntax ([start-id start-id]
(with-syntax ([start-id (first rule-ids)] ; The first rule, by default, is the start rule.
[(token-type ...) token-types] [(token-type ...) token-types]
[(token-type-constructor ...) (for/list ([tt (in-list token-types)])
[(token-type-constructor ...) (string->symbol (format "token-~a" tt)))]
(map (lambda (x) (string->symbol (format "token-~a" x)))
token-types)]
[(explicit-token-types ...) explicit-token-types] [(explicit-token-types ...) explicit-token-types]
[(implicit-token-types ...) implicit-token-types] [(implicit-token-types ...) implicit-token-types]
[(implicit-token-types-str ...) (map symbol->string implicit-token-types)] [(implicit-token-types-str ...) (map symbol->string implicit-token-types)]
[(implicit-token-type-constructor ...) [(implicit-token-type-constructor ...) (for/list ([itt (in-list implicit-token-types)])
(map (lambda (x) (string->symbol (format "token-~a" x))) (string->symbol (format "token-~a" itt)))]
implicit-token-types)] [generated-grammar `(grammar ,@generated-rule-codes)]
[generated-grammar #`(grammar #,@generated-rule-codes)]
[parser-module parser-provider-module] [parser-module parser-provider-module]
[parser-form parser-provider-form] [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)))]
@ -103,18 +85,13 @@
brag/support brag/support
brag/private/internal-support brag/private/internal-support
racket/set racket/set
(for-syntax syntax/parse racket/base)) (for-syntax racket/base))
(provide PARSE (provide PARSE
PARSE-TO-DATUM PARSE-TO-DATUM
PARSE-TREE PARSE-TREE
MAKE-RULE-PARSER MAKE-RULE-PARSER
ALL-TOKEN-TYPES ALL-TOKEN-TYPES)
#;current-source
#;current-parser-error-handler
#;current-tokenizer-error-handler
#;[struct-out exn:fail:parsing]
)
;; helpers from brag/support ;; helpers from brag/support
(define TOKEN token) (define TOKEN token)
@ -124,8 +101,7 @@
(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 (define ALL-TOKEN-TYPES (set-remove (set 'token-type ...) 'EOF))
(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
@ -134,43 +110,36 @@
(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 default-lex/1 (syntax-case rule-id-stx ()
(lexer-src-pos [implicit-token-types-str [(_ start-rule)
(token 'implicit-token-types lexeme)] (and (identifier? #'start-rule)
... (member (syntax-e #'start-rule) '#,(map syntax-e rule-ids)))
[(eof) (token eof)])) (let ()
(define-syntax (MAKE-RULE-PARSER stx-2)
(syntax-parse stx-2
[(_ start-rule:id)
(begin
;; 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.
(unless (member (syntax-e #'start-rule) (with-syntax ([RECOLORED-START-RULE (datum->syntax #'#,rules-stx (syntax-e #'start-rule))])
'#,(map syntax-e rule-ids)) #'(let ([THE-GRAMMAR (parser-form (tokens enumerated-tokens)
(raise-syntax-error #f (src-pos)
(format "Rule ~a is not defined in the grammar" (syntax-e #'start-rule)) (start RECOLORED-START-RULE)
stx-2)) (end EOF)
(error THE-ERROR-HANDLER)
(define recolored-start-rule (datum->syntax (syntax #,rules-stx) (syntax-e #'start-rule))) generated-grammar)])
#`(let ([THE-GRAMMAR (parser-form (tokens enumerated-tokens) (procedure-rename
(src-pos) (case-lambda [(tokenizer)
(start #,recolored-start-rule) (define next-token
(end EOF) (make-permissive-tokenizer tokenizer all-tokens-hash/mutable))
(error THE-ERROR-HANDLER) (THE-GRAMMAR next-token)]
generated-grammar)]) [(source tokenizer)
(procedure-rename (parameterize ([current-source source])
(case-lambda [(tokenizer) (PARSE tokenizer))])
(define next-token (string->symbol (format "~a-rule-parser" 'start-rule))))))]
(make-permissive-tokenizer tokenizer all-tokens-hash/mutable)) [(_ start-rule)
(THE-GRAMMAR next-token)] (raise-syntax-error #f
[(source tokenizer) (format "Rule ~a is not defined in the grammar" (syntax-e #'start-rule))
(parameterize ([current-source source]) rule-id-stx)]))
(PARSE tokenizer))])
(string->symbol (format "~a-rule-parser" 'start-rule)))))]))
(define PARSE (procedure-rename (MAKE-RULE-PARSER start-id) 'PARSE)) (define PARSE (procedure-rename (MAKE-RULE-PARSER start-id) 'PARSE))
@ -192,13 +161,10 @@
;; ;;
(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)
(begin (with-syntax ([translated-clauses (for/list ([clause-stx (syntax->list #'clauses)])
(define translated-clauses (translate-clause clause-stx #'name #'origin))])
(map (lambda (clause) (translate-clause clause #'name #'origin)) #'[name . translated-clauses])]))
(syntax->list #'(clauses ...))))
(with-syntax ([(translated-clause ...) translated-clauses])
#`[name translated-clause ...]))]))
@ -209,8 +175,7 @@
(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) null]
'()]
[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)
@ -246,7 +211,7 @@
(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)))]
@ -282,7 +247,7 @@
;; of explicit token types, though the user is not allow to express it themselves. ;; of explicit token types, though the user is not allow to express it themselves.
(define (rules-collect-token-types rules) (define (rules-collect-token-types rules)
(define-values (implicit explicit) (define-values (implicit explicit)
(for/fold ([implicit '()] (for/fold ([implicit null]
[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)))
@ -297,16 +262,15 @@
(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 seq) (syntax-case a-pattern (id lit token choice repeat maybe seq EOF)
[(id val) [(id val)
(values implicit explicit)] (values implicit explicit)]
[(lit val) [(lit val)
(values (cons #'val implicit) explicit)] (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) [(token val)
(begin (values implicit (cons #'val explicit))]
(when (eq? (syntax-e #'val) 'EOF)
(raise-syntax-error #f "Token EOF is reserved and can not be used in a grammar" #'val))
(values implicit (cons #'val explicit)))]
[(choice vals ...) [(choice vals ...)
(for/fold ([implicit implicit] (for/fold ([implicit implicit]
[explicit explicit]) [explicit explicit])
@ -346,18 +310,18 @@
(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))]) [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 (λ () #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) (λ () #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)
@ -414,7 +378,7 @@
(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 null)
(define (make-leaf) (define (make-leaf)
(define a-leaf (sat:make-and)) (define a-leaf (sat:make-and))

Write Preview
Loading…
Cancel
Save