diff --git a/brag/codegen/flatten.rkt b/brag/codegen/flatten.rkt index 74f8a0a..1a4cbae 100755 --- a/brag/codegen/flatten.rkt +++ b/brag/codegen/flatten.rkt @@ -6,38 +6,33 @@ flatten-rules prim-rule) - - (define (make-fresh-name) (let ([n 0]) - (lambda () + (λ () (set! n (add1 n)) (string->symbol (format "%rule~a" n))))) -(define default-fresh-name - (make-fresh-name)) +(define default-fresh-name (make-fresh-name)) ;; Translates rules to lists of primitive rules. (define (flatten-rules rules #:fresh-name [fresh-name default-fresh-name]) - (define ht (make-hash)) - (apply append (map (lambda (a-rule) (flatten-rule a-rule - #:ht ht - #:fresh-name fresh-name)) - rules))) + (define ht (make-hasheq)) + (apply append (for/list ([a-rule (in-list rules)]) + (flatten-rule a-rule + #:ht ht + #:fresh-name fresh-name)))) ;; flatten-rule: rule -> (listof primitive-rule) (define (flatten-rule a-rule #:fresh-name [fresh-name default-fresh-name] - ;; ht: (hashtableof pattern-hash-key pat) - #:ht [ht (make-hash)]) + #:ht [ht (make-hasheq)]) - (let recur ([a-rule a-rule] - [inferred? #f]) + (let recur ([a-rule a-rule] [inferred? #f]) ;; lift-nonprimitive-pattern: pattern -> (values (listof primitive-rule) pattern) ;; Turns non-primitive patterns into primitive patterns, and produces a set of @@ -98,6 +93,14 @@ (append (list #'(HEAD ORIGIN NAME [SUB-PAT ...] ...)) (apply append (reverse inferred-ruless/rev)))))] + [(repeat 0 0 SUB-PAT) + ;; repeat from 0 to 0 (is a no-op) + (recur #'(rule NAME (seq)) #f)] + + [(repeat 0 MAYBE-MAX SUB-PAT) + ;; repeat from 0 (as a maybe rule) + (recur #'(rule NAME (maybe (repeat 1 MAYBE-MAX SUB-PAT))) #f)] + [(repeat MIN #f SUB-PAT) ;; indefinite repeat (begin @@ -115,10 +118,15 @@ (begin (define min (syntax-e #'MIN)) (define max (syntax-e #'MAX)) - (define new-rule-stx (with-syntax ([(MIN-SUBPAT ...) (make-list min #'SUB-PAT)] - [(EXTRA-SUBPAT ...) (make-list (- max min) #'SUB-PAT)]) - ;; has to keep the same name to work correctly - #'(rule NAME (seq MIN-SUBPAT ... (maybe EXTRA-SUBPAT) ...)))) + (unless (<= min max) + (raise-syntax-error #f (format "minimum repeat count cannot be larger than maximum, got {~a,~a}" min max) a-rule)) + ;; has to keep the same rule NAME to work correctly + (define new-rule-stx + (if (= min max) + (with-syntax ([MIN-SUBPATS (make-list min #'SUB-PAT)]) + #'(rule NAME (seq . MIN-SUBPATS))) + (with-syntax ([REPEATS-REMAINING (- max min)]) ; REPEATS-REMAINING is a positive integer + #'(rule NAME (seq (repeat MIN MIN SUB-PAT) (repeat 0 REPEATS-REMAINING SUB-PAT)))))) (recur new-rule-stx #f))] [(maybe SUB-PAT) diff --git a/brag/examples/nested-repeats.rkt b/brag/examples/nested-repeats.rkt new file mode 100644 index 0000000..17eaa5e --- /dev/null +++ b/brag/examples/nested-repeats.rkt @@ -0,0 +1,3 @@ +#lang brag + +start : ( (X | X Y) A* )* diff --git a/brag/test/test-all.rkt b/brag/test/test-all.rkt index 09658b3..a101de0 100755 --- a/brag/test/test-all.rkt +++ b/brag/test/test-all.rkt @@ -12,6 +12,7 @@ "test-flatten.rkt" "test-hide-and-splice.rkt" "test-lexer.rkt" + "test-nested-repeats.rkt" "test-old-token.rkt" "test-parser.rkt" "test-quotation-marks-and-backslashes.rkt" diff --git a/brag/test/test-flatten.rkt b/brag/test/test-flatten.rkt index ee2155f..abfe918 100755 --- a/brag/test/test-flatten.rkt +++ b/brag/test/test-flatten.rkt @@ -33,18 +33,18 @@ (check-equal? (map syntax->datum (flatten-rule #'(rule expr (seq (lit "1") (seq (lit "2") (lit "3")))))) '((prim-rule seq expr - [(lit "1") (lit "2") (lit "3")]))) + [(lit "1") (lit "2") (lit "3")]))) (check-equal? (map syntax->datum (flatten-rule #'(rule expr (seq (seq (lit "1") (lit "2")) (lit "3"))))) '((prim-rule seq expr - [(lit "1") (lit "2") (lit "3")]))) + [(lit "1") (lit "2") (lit "3")]))) (check-equal? (map syntax->datum (flatten-rule #'(rule expr (seq (seq (lit "1")) (seq (lit "2") (lit "3")))))) '((prim-rule seq expr - [(lit "1") (lit "2") (lit "3")]))) + [(lit "1") (lit "2") (lit "3")]))) @@ -96,14 +96,16 @@ ;; repeat (check-equal? (map syntax->datum (flatten-rule #'(rule rule-2+ (repeat 0 #f (id rule-2))))) - '((prim-rule repeat rule-2+ - [(inferred-id rule-2+ repeat) (id rule-2)] - []))) + '((prim-rule maybe rule-2+ ((inferred-id %rule1 repeat)) ()) + (inferred-prim-rule repeat %rule1 + ((inferred-id %rule1 repeat) (id rule-2)) + ((id rule-2))))) (check-equal? (map syntax->datum (flatten-rule #'(rule rule-2+ (repeat 0 #f (seq (lit "+") (id rule-2)))))) - '((prim-rule repeat rule-2+ - [(inferred-id rule-2+ repeat) (lit "+") (id rule-2)] - []))) + '((prim-rule maybe rule-2+ ((inferred-id %rule2 repeat)) ()) + (inferred-prim-rule repeat %rule2 + ((inferred-id %rule2 repeat) (lit "+") (id rule-2)) + ((lit "+") (id rule-2))))) (check-equal? (map syntax->datum (flatten-rule #'(rule rule-2+ (repeat 1 #f (id rule-2))))) @@ -132,8 +134,8 @@ [(lit "x")] [(inferred-id r1 maybe)]) (inferred-prim-rule maybe r1 - [(lit "y")] - []))) + [(lit "y")] + []))) ;; choice, maybe, repeat (check-equal? (map syntax->datum (flatten-rule #'(rule sexp (choice (lit "x") @@ -143,11 +145,11 @@ [(lit "x")] [(inferred-id r1 maybe)]) (inferred-prim-rule maybe r1 - [(inferred-id r2 repeat)] - []) + [(inferred-id r2 repeat)] + []) (inferred-prim-rule repeat r2 - [(inferred-id r2 repeat) (lit "y")] - [(lit "y")]))) + [(inferred-id r2 repeat) (lit "y")] + [(lit "y")]))) ;; choice, seq (check-equal? (map syntax->datum (flatten-rule #'(rule sexp (choice (seq (lit "x") (lit "y")) @@ -174,8 +176,11 @@ (check-equal? (map syntax->datum (flatten-rule #'(rule expr (seq (id term) (repeat 0 #f (seq (lit "+") (id term))))) #:fresh-name (make-fresh-name))) - '((prim-rule seq expr [(id term) (inferred-id r1 repeat)]) - (inferred-prim-rule repeat r1 [(inferred-id r1 repeat) (lit "+") (id term)] []))) + '((prim-rule seq expr ((id term) (inferred-id r1 repeat))) + (prim-rule maybe r1 ((inferred-id r2 repeat)) ()) + (inferred-prim-rule repeat r2 + ((inferred-id r2 repeat) (lit "+") (id term)) + ((lit "+") (id term))))) ;; larger example: simple arithmetic @@ -186,8 +191,14 @@ (rule factor (token INT)))) #:fresh-name (make-fresh-name))) - '((prim-rule seq expr [(id term) (inferred-id r1 repeat)]) - (inferred-prim-rule repeat r1 [(inferred-id r1 repeat) (lit "+") (id term)] []) - (prim-rule seq term [(id factor) (inferred-id r2 repeat)]) - (inferred-prim-rule repeat r2 [(inferred-id r2 repeat) (lit "*") (id factor)] []) - (prim-rule token factor [(token INT)]))) + '((prim-rule seq expr ((id term) (inferred-id r1 repeat))) + (prim-rule maybe r1 ((inferred-id r2 repeat)) ()) + (inferred-prim-rule repeat r2 + ((inferred-id r2 repeat) (lit "+") (id term)) + ((lit "+") (id term))) + (prim-rule seq term ((id factor) (inferred-id r3 repeat))) + (prim-rule maybe r3 ((inferred-id r4 repeat)) ()) + (inferred-prim-rule repeat r4 + ((inferred-id r4 repeat) (lit "*") (id factor)) + ((lit "*") (id factor))) + (prim-rule token factor ((token INT))))) diff --git a/brag/test/test-nested-repeats.rkt b/brag/test/test-nested-repeats.rkt new file mode 100755 index 0000000..1cc518e --- /dev/null +++ b/brag/test/test-nested-repeats.rkt @@ -0,0 +1,9 @@ +#lang racket/base +(require brag/examples/nested-repeats + rackunit) + +(check-equal? + (syntax->datum (parse (list "X" "Y" "X"))) + '(start "X" "Y" "X")) + +