*** empty log message ***

original commit: 0dd00658cbc5e0b9d3c6b574051b628ec590f622

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))
   )

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)

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

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)
@@ -61,5 +62,58 @@
 	#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"))))
+  
+
 )  
   

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)
@@ -309,4 +338,6 @@
                       "parser: Could not parse input"
                       #f #f #f #f #f))))))))))
 
+  
+
   )