diff --git a/collects/parser-tools/private-lex/token-syntax.ss b/collects/parser-tools/private-lex/token-syntax.ss index c963f54..a66f33b 100644 --- a/collects/parser-tools/private-lex/token-syntax.ss +++ b/collects/parser-tools/private-lex/token-syntax.ss @@ -3,7 +3,8 @@ ;; The things needed at compile time to handle definition of tokens - (provide make-terminals-def terminals-def-t terminals-def?) - + (provide make-terminals-def terminals-def-t terminals-def? + make-e-terminals-def e-terminals-def-t e-terminals-def?) (define-struct terminals-def (t)) -) + (define-struct e-terminals-def (t)) + ) diff --git a/collects/parser-tools/private-lex/token.ss b/collects/parser-tools/private-lex/token.ss index 72967e4..fb78826 100644 --- a/collects/parser-tools/private-lex/token.ss +++ b/collects/parser-tools/private-lex/token.ss @@ -19,7 +19,9 @@ #'here `(begin (define-syntax ,(syntax name) - (make-terminals-def (quote-syntax ,(syntax (terms ...))))) + ,(if empty? + `(make-e-terminals-def (quote-syntax ,(syntax (terms ...)))) + `(make-terminals-def (quote-syntax ,(syntax (terms ...)))))) ,@(map (lambda (n) (if (eq? (syntax-object->datum n) 'error) diff --git a/collects/parser-tools/private-yacc/input-file-parser.ss b/collects/parser-tools/private-yacc/input-file-parser.ss index 22b07e3..7df038a 100644 --- a/collects/parser-tools/private-yacc/input-file-parser.ss +++ b/collects/parser-tools/private-yacc/input-file-parser.ss @@ -119,6 +119,7 @@ (let ((t (syntax-local-value term-syn (lambda () #f)))) (cond ((terminals-def? t) (syntax->list (terminals-def-t t))) + ((e-terminals-def? t) (syntax->list (e-terminals-def-t t))) (else (raise-syntax-error 'parser-tokens diff --git a/collects/parser-tools/private-yacc/yacc-helper.ss b/collects/parser-tools/private-yacc/yacc-helper.ss index f744b59..ab2f5bf 100644 --- a/collects/parser-tools/private-yacc/yacc-helper.ss +++ b/collects/parser-tools/private-yacc/yacc-helper.ss @@ -1,9 +1,12 @@ #cs (module yacc-helper mzscheme + (require (lib "list.ss") + "../private-lex/token-syntax.ss") + ;; General helper routines - (provide duplicate-list? remove-duplicates overlap? vector-andmap) + (provide duplicate-list? remove-duplicates overlap? vector-andmap display-yacc) (define (vector-andmap f v) (let loop ((i 0)) @@ -28,8 +31,6 @@ (dl? (cdr l))))))) (dl? l))) - (require (lib "pretty.ss")) - ;; remove-duplicates: syntax-object list -> syntax-object list ;; removes the duplicates from the lists (define (remove-duplicates sl) @@ -60,6 +61,59 @@ l2) #f))) + + (define (display-yacc grammar tokens start precs port) + (let-syntax ((p (syntax-rules () + ((_ args ...) (fprintf port args ...))))) + (let* ((tokens (map syntax-local-value (cdr (syntax->list tokens)))) + (eterms (filter e-terminals-def? tokens)) + (terms (filter terminals-def? tokens)) + (term-table (make-hash-table)) + (display-rhs + (lambda (rhs) + (for-each (lambda (sym) (p "~a " (hash-table-get term-table sym (lambda () sym)))) + (car rhs)) + (if (= 3 (length rhs)) + (p "%prec ~a" (cadadr rhs))) + (p "~n")))) + (for-each + (lambda (t) + (for-each + (lambda (t) + (hash-table-put! term-table t (format "'~a'" t))) + (syntax-object->datum (e-terminals-def-t t)))) + eterms) + (for-each + (lambda (t) + (for-each + (lambda (t) + (p "%token ~a~n" t) + (hash-table-put! term-table t (format "~a" t))) + (syntax-object->datum (terminals-def-t t)))) + terms) + (if precs + (for-each (lambda (prec) + (p "%~a " (car prec)) + (for-each (lambda (tok) + (p " ~a" (hash-table-get term-table tok))) + (cdr prec)) + (p "~n")) + (cdr precs))) + (p "%start ~a~n" start) + (p "%%~n") + + (for-each (lambda (prod) + (let ((nt (car prod))) + (p "~a: " nt) + (display-rhs (cadr prod)) + (for-each (lambda (rhs) + (p "| ") + (display-rhs rhs)) + (cddr prod)) + (p ";~n"))) + (cdr grammar)) + (p "%%~n")))) + ) diff --git a/collects/parser-tools/yacc.ss b/collects/parser-tools/yacc.ss index ac3b079..3b80c74 100644 --- a/collects/parser-tools/yacc.ss +++ b/collects/parser-tools/yacc.ss @@ -22,10 +22,11 @@ (end #f) (precs #f) (suppress #f) - (grammar #f)) + (grammar #f) + (yacc-output #f)) (for-each (lambda (arg) - (syntax-case* arg (debug error tokens start end precs grammar suppress src-pos) + (syntax-case* arg (debug error tokens start end precs grammar suppress src-pos yacc-output) (lambda (a b) (eq? (syntax-object->datum a) (syntax-object->datum b))) ((debug filename) @@ -95,6 +96,17 @@ (if grammar (raise-syntax-error #f "Multiple grammar declarations" stx) (set! grammar arg))) + ((yacc-output filename) + (cond + ((not (string? (syntax-object->datum (syntax filename)))) + (raise-syntax-error + 'parser-yacc-output + "Yacc-output filename must be a string" + (syntax filename))) + (yacc-output + (raise-syntax-error #f "Multiple yacc-output declarations" stx)) + (else + (set! yacc-output (syntax-object->datum (syntax filename)))))) (_ (raise-syntax-error 'parser-args "argument must match (debug filename), (error expression), (tokens def ...), (start non-term), (end tokens ...), (precs decls ...), or (grammar prods ...)" arg)))) (syntax->list (syntax (args ...)))) (if (not tokens) @@ -117,6 +129,23 @@ precs grammar stx))) + (if (and yacc-output (not (string=? yacc-output ""))) + (with-handlers [(exn:i/o:filesystem? + (lambda (e) + (fprintf + (current-error-port) + "Cannot write yacc-output to file \"~a\". ~a~n" + (exn:i/o:filesystem-pathname e) + (exn:i/o:filesystem-detail e))))] + (call-with-output-file yacc-output + (lambda (port) + (display-yacc (syntax-object->datum grammar) + tokens + (syntax-object->datum start) + (if precs + (syntax-object->datum precs) + #f) + port))))) (with-syntax ((check-syntax-fix check-syntax-fix) (err error) (ends end) @@ -308,5 +337,7 @@ (raise-read-error "parser: Could not parse input" #f #f #f #f #f)))))))))) + + ) \ No newline at end of file