Add expected-SR-conflicts + expected-RR-conflicts.

Add options for informing the yacc parser how many shift/reduce and
reduce/reduce conflicts to expect.

The options are inherited by cfg-parser but probably not useful there.

Closes racket/racket#1669

parser-tools-doc/parser-tools/parser-tools.scrbl

@@ -495,7 +495,8 @@ be the right choice when using @racket[lexer] in other situations.
 @defmodule[parser-tools/yacc]
 
 @defform/subs[#:literals (grammar tokens start end precs src-pos
-                          suppress debug yacc-output prec)
+                          suppress expected-SR-conflicts expected-RR-conflicts
+                          debug yacc-output prec)
               (parser clause ...)
               ([clause (grammar (non-terminal-id 
                                  ((grammar-id ...) maybe-prec expr)
@@ -508,6 +509,8 @@ be the right choice when using @racket[lexer] in other situations.
                        (precs (assoc token-id ...) ...)
                        (src-pos)
                        (suppress)
+                       (expected-SR-conflicts num)
+                       (expected-RR-conflicts num)
                        (debug filename)
                        (yacc-output filename)]
                [maybe-prec code:blank
@@ -656,6 +659,18 @@ be the right choice when using @racket[lexer] in other situations.
       Causes the parser generator not to report shift/reduce or
       reduce/reduce conflicts.}
 
+      @item{@racket[(expected-SR-conflicts _n)] @italic{OPTIONAL}
+
+      Causes the parser generator to expect exactly @racket[_num]
+      shift/reduce conflicts, where @racket[_num] must be a literal number.
+      The @racket[suppress] option overrides this option.}
+
+      @item{@racket[(expected-RR-conflicts _n)] @italic{OPTIONAL}
+
+      Causes the parser generator to expect exactly @racket[_num]
+      reduce/reduce conflicts, where @racket[_num] must be a literal number.
+      The @racket[suppress] option overrides this option.}
+
     ]
 
     The result of a @racket[parser] expression with one @racket[start]
@@ -696,7 +711,8 @@ library provides a parser generator that is an alternative to that of
 @racketmodname[parser-tools/yacc].}
 
 @defform/subs[#:literals (grammar tokens start end precs src-pos
-                          suppress debug yacc-output prec)
+                          suppress expected-SR-conflicts expected-RR-conflicts
+                          debug yacc-output prec)
               (cfg-parser clause ...)
               ([clause (grammar (non-terminal-id 
                                  ((grammar-id ...) maybe-prec expr)
@@ -721,8 +737,9 @@ library provides a parser generator that is an alternative to that of
       a single non-terminal-id.}
                        
       @item{The @racket[cfg-parser] form does not support the @racket[precs], 
-             @racket[suppress], @racket[debug], or @racket[yacc-output]
+             @racket[suppress], @racket[expected-SR-conflicts],
-             options of @racket[parser].}
+             @racket[expected-RR-conflicts], @racket[debug],
+             or @racket[yacc-output] options of @racket[parser].}
    ]
 }                                            
                                             

parser-tools-lib/parser-tools/private-yacc/parser-builder.rkt

@@ -8,7 +8,7 @@
   (require-for-template mzscheme)
   
   (provide/contract
-   (build-parser (-> string? any/c any/c
+   (build-parser (-> string? any/c any/c any/c any/c
                      (listof identifier?)
                      (listof identifier?)
                      (listof identifier?)
@@ -74,9 +74,22 @@
             (let ((bind void) ... (tmp void) ...)
               (void bound ... ... term-group ... start ... end ... prec ...))))))
   (require mzlib/list "parser-actions.rkt")
-  (define (build-parser filename src-pos suppress input-terms start end assocs prods)
+  (define (build-parser filename
+                        src-pos
+                        suppress
+                        expected-SR-conflicts
+                        expected-RR-conflicts
+                        input-terms
+                        start
+                        end
+                        assocs
+                        prods)
     (let* ((grammar (parse-input input-terms start end assocs prods src-pos))
-           (table (build-table grammar filename suppress))
+           (table (build-table grammar
+                               filename
+                               suppress
+                               expected-SR-conflicts
+                               expected-RR-conflicts))
            (all-tokens (make-hash-table))
            (actions-code
             `(vector ,@(map prod-action (send grammar get-prods)))))

parser-tools-lib/parser-tools/private-yacc/table.rkt

@@ -12,7 +12,7 @@
 
   (define (is-a-grammar%? x) (is-a? x grammar%))
   (provide/contract 
-   (build-table (-> is-a-grammar%? string? any/c
+   (build-table (-> is-a-grammar%? string? any/c any/c any/c
                     (vectorof (listof (cons/c (or/c term? non-term?) action?))))))
 
   ;; A parse-table is (vectorof (listof (cons/c gram-sym? action)))
@@ -164,7 +164,10 @@
              (else (loop current-guess (cdr rest)))))))))
   
   ;; resolve-conflicts : grouped-parse-table bool -> parse-table
-  (define (resolve-conflicts grouped-table suppress)
+  (define (resolve-conflicts grouped-table
+                             suppress
+                             expected-SR-conflicts
+                             expected-RR-conflicts)
     (let* ((SR-conflicts 0)
            (RR-conflicts 0)
            (table (table-map
@@ -178,14 +181,24 @@
                        action))
                    grouped-table)))
       (unless suppress
-        (when (> SR-conflicts 0)
+        (when (if expected-SR-conflicts
-          (eprintf "~a shift/reduce conflict~a\n"
+                  (not (= SR-conflicts expected-SR-conflicts))
+                  (> SR-conflicts 0))
+          (eprintf "~a shift/reduce conflict~a~a\n"
                    SR-conflicts
-                   (if (= SR-conflicts 1) "" "s")))
+                   (if (= SR-conflicts 1) "" "s")
-        (when (> RR-conflicts 0)
+                   (if expected-SR-conflicts
-          (eprintf "~a reduce/reduce conflict~a\n"
+                       (format ", expected ~a" expected-SR-conflicts)
+                       "")))
+        (when (if expected-RR-conflicts
+                  (not (= RR-conflicts expected-RR-conflicts))
+                  (> RR-conflicts 0))
+          (eprintf "~a reduce/reduce conflict~a~a\n"
                    RR-conflicts
-                   (if (= RR-conflicts 1) "" "s"))))
+                   (if (= RR-conflicts 1) "" "s")
+                   (if expected-RR-conflicts
+                       (format ", expected ~a" expected-RR-conflicts)
+                       ""))))
       table))
   
 
@@ -227,8 +240,12 @@
          (else actions)))
      (group-table table)))
                         
-  ;; build-table: grammar string bool -> parse-table
+  ;; build-table: grammar string bool #f|int #f|int -> parse-table
-  (define (build-table g file suppress)
+  (define (build-table g
+                       file
+                       suppress
+                       expected-SR-conflicts
+                       expected-RR-conflicts)
     (let* ((a (build-lr0-automaton g))
            (term-vector (list->vector (send g get-terms)))
            (end-terms (send g get-end-terms))
@@ -287,4 +304,7 @@
               (lambda (port)
                 (display-parser a grouped-table (send g get-prods) port))
               #:exists 'truncate)))
-        (resolve-conflicts grouped-table suppress))))
+        (resolve-conflicts grouped-table
+                           suppress
+                           expected-SR-conflicts
+                           expected-RR-conflicts))))

parser-tools-lib/parser-tools/yacc.rkt

@@ -42,12 +42,16 @@
              (end #f)
              (precs #f)
              (suppress #f)
+             (expected-SR-conflicts #f)
+             (expected-RR-conflicts #f)
              (grammar #f)
              (yacc-output #f))
          (for-each
           (lambda (arg)
             (syntax-case* arg (debug error tokens start end precs grammar
-                               suppress src-pos yacc-output)
+                               suppress src-pos yacc-output
+                               expected-SR-conflicts
+                               expected-RR-conflicts)
               (lambda (a b)
                 (eq? (syntax-e a) (syntax-e b)))
               ((debug filename)
@@ -64,6 +68,10 @@
                   (set! debug (syntax-e (syntax filename))))))
               ((suppress)
                (set! suppress #t))
+              ((expected-SR-conflicts n)
+               (set! expected-SR-conflicts (syntax-e (syntax n))))
+              ((expected-RR-conflicts n)
+               (set! expected-RR-conflicts (syntax-e (syntax n))))
               ((src-pos)
                (set! src-pos #t))
               ((error expression)
@@ -164,6 +172,8 @@
                        (build-parser (if debug debug "")
                                      src-pos
                                      suppress
+                                     expected-SR-conflicts
+                                     expected-RR-conflicts
                                      tokens
                                      start
                                      end