diff --git a/collects/parser-tools/lex.ss b/collects/parser-tools/lex.ss index 5ddc4f8..7c19b0a 100644 --- a/collects/parser-tools/lex.ss +++ b/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) diff --git a/collects/parser-tools/private-yacc/parser-builder.ss b/collects/parser-tools/private-yacc/parser-builder.ss index 058a33d..3454100 100644 --- a/collects/parser-tools/private-yacc/parser-builder.ss +++ b/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)) diff --git a/collects/parser-tools/private-yacc/table.ss b/collects/parser-tools/private-yacc/table.ss index ae855d4..61ca87a 100644 --- a/collects/parser-tools/private-yacc/table.ss +++ b/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 (> SR-conflicts 0) - (fprintf (current-error-port) - "~a shift/reduce conflicts~n" - SR-conflicts)) - (if (> RR-conflicts 0) - (fprintf (current-error-port) - "~a reduce/reduce conflicts~n" - RR-conflicts)))) + (if (not suppress) + (begin + (if (> SR-conflicts 0) + (fprintf (current-error-port) + "~a shift/reduce conflicts~n" + SR-conflicts)) + (if (> RR-conflicts 0) + (fprintf (current-error-port) + "~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)) ) diff --git a/collects/parser-tools/yacc.ss b/collects/parser-tools/yacc.ss index 0abd4e4..c7990cc 100644 --- a/collects/parser-tools/yacc.ss +++ b/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