*** empty log message ***

original commit: 1134ea0926802ae6d41c0138924a4e0c90056665

collects/parser-tools/lex.ss

@@ -7,13 +7,13 @@
   (require-for-syntax "private-lex/structs.ss")
   (require (lib "list.ss")
            "private-lex/token.ss")
-  (provide lex define-lex-abbrev define-lex-abbrevs
+  (provide lexer define-lex-abbrev define-lex-abbrevs
 	   make-lex-buf
 	   get-position position-offset position-line position-col position?
            define-tokens define-empty-tokens)
 
 
-  (define-syntax lex
+  (define-syntax lexer
     (let ((code
 	   `(letrec ((match
 		      (lambda (lb first-pos end-pos longest-match-length longest-match-action length)

collects/parser-tools/private-yacc/parser-builder.ss

@@ -8,9 +8,9 @@
   
   (provide build-parser)
   
-  (define (build-parser filename error-expr input-terms start end assocs prods runtime src)
+  (define (build-parser filename suppress error-expr input-terms start end assocs prods runtime src)
     (let* ((grammar (parse-input start end input-terms assocs prods runtime))
-           (table (build-table grammar filename))
+           (table (build-table grammar filename suppress))
            (table-code 
             `((lambda (table-list)
                 (let ((v (list->vector table-list)))
@@ -151,7 +151,7 @@
                         ;; (printf "accept~n")
                         (cadr stack))
                        (else 
-                        (err)
+                        (err ip)
                         (let ((new-stack (fix-error stack ip get-token)))
                           (if new-stack
                               (parsing-loop new-stack (get-token))

collects/parser-tools/private-yacc/table.ss

@@ -107,7 +107,7 @@
       (if (> RR-conflicts 0)
 	  (fprintf port "~a reduce/reduce conflicts~n" RR-conflicts))))
 
-  (define (resolve-conflicts a table num-terms num-non-terms)
+  (define (resolve-conflicts a table num-terms num-non-terms suppress)
     (letrec ((SR-conflicts 0)
 	     (RR-conflicts 0)
 	     (get-action
@@ -140,15 +140,16 @@
                                              (+ num-non-terms term))))
                  (loop (add1 term))))))
        a)
-
+      (if (not suppress)
-      (if (> SR-conflicts 0)
+          (begin
-	  (fprintf (current-error-port) 
+            (if (> SR-conflicts 0)
-		   "~a shift/reduce conflicts~n" 
+                (fprintf (current-error-port) 
-		   SR-conflicts))
+                         "~a shift/reduce conflicts~n" 
-      (if (> RR-conflicts 0)
+                         SR-conflicts))
-	  (fprintf (current-error-port)
+            (if (> RR-conflicts 0)
-		   "~a reduce/reduce conflicts~n"
+                (fprintf (current-error-port)
-		   RR-conflicts))))
+                         "~a reduce/reduce conflicts~n"
+                         RR-conflicts))))))
     
 
 
@@ -202,7 +203,7 @@
   ;; In the result table the first index is the state and the second is the 
   ;; term/non-term index (with the non-terms coming first)
   ;; buile-table: grammar * string -> action2d-array
-  (define (build-table g file)
+  (define (build-table g file suppress)
     (let* ((a (build-lr0-automaton g))
 	   (terms (grammar-terms g))
 	   (non-terms (grammar-non-terms g))
@@ -287,7 +288,7 @@
 	      (lambda (port)
 		(display-parser a table get-term get-non-term (grammar-prods g)
                                 port)))))
-      (resolve-conflicts a table num-terms num-non-terms)
+      (resolve-conflicts a table num-terms num-non-terms suppress)
       table))
 )
 

collects/parser-tools/yacc.ss

@@ -20,10 +20,11 @@
                (start #f)
                (end #f)
                (precs #f)
+               (suppress #f)
                (grammar #f))
            (for-each
             (lambda (arg)
-              (syntax-case* arg (debug error tokens start end precs grammar)
+              (syntax-case* arg (debug error tokens start end precs grammar suppress)
                 (lambda (a b)
                   (eq? (syntax-object->datum a) (syntax-object->datum b)))
                 ((debug filename)
@@ -37,6 +38,8 @@
                     (raise-syntax-error #f "Multiple debug declarations" stx))
                    (else
                     (set! debug (syntax-object->datum (syntax filename))))))
+                ((suppress)
+                 (set! suppress #t))
                 ((error expression)
                  (if error
                      (raise-syntax-error #f "Multiple error declarations" stx)
@@ -102,6 +105,7 @@
 	   (if (not start)
                (raise-syntax-error #f "missing start declaration" stx))
            (build-parser (if debug debug "")
+                         suppress
                          error
                          tokens
                          start