*** empty log message ***

original commit: 899f8afb5c8d0a51950f65a2b4d3b5200a4b0a54

collects/parser-tools/private-yacc/input-file-parser.ss

@@ -235,7 +235,7 @@
            (terms (build-terms list-of-terms precs))
            
            (non-terms (begin
-                        (set! counter 1)
+                        (set! counter 2)
                         (map (lambda (non-term)
                                (begin0
                                  (make-non-term non-term counter)
@@ -252,8 +252,6 @@
 		  (hash-table-put! non-term-table (gram-sym-symbol nt) nt))
 		non-terms)
       
-      (set! counter 1)
-      
       (let* (
 	     ;; parse-prod: syntax-object -> gram-sym vector
 	     (parse-prod
@@ -299,41 +297,39 @@
                 (syntax-case prod-so (prec)
                   ((prod-rhs action)
                    (let ((p (parse-prod (syntax prod-rhs))))
-                     (begin0
-                       (make-prod 
-                        nt 
-                        p
-                        counter 
-                        (let loop ((i (sub1 (vector-length p))))
-                          (if (>= i 0)
-                              (let ((gs (vector-ref p i)))
-                                (if (term? gs)
-                                    (term-prec gs)
-                                    (loop (sub1 i))))
-                              #f))
-                        (parse-action p (syntax action)))
-                       (set! counter (add1 counter)))))
+                     (set! counter (add1 counter))
+                     (make-prod 
+                      nt
+                      p
+                      counter 
+                      (let loop ((i (sub1 (vector-length p))))
+                        (if (>= i 0)
+                            (let ((gs (vector-ref p i)))
+                              (if (term? gs)
+                                  (term-prec gs)
+                                  (loop (sub1 i))))
+                            #f))
+                      (parse-action p (syntax action)))))
                   ((prod-rhs (prec term) action)
                    (identifier? (syntax term))
                    (let ((p (parse-prod (syntax prod-rhs))))
-                     (begin0
-                       (make-prod 
-                        nt 
-                        p
-                        counter
-                        (term-prec
-                         (hash-table-get 
-                          term-table 
-                          (syntax-object->datum (syntax term))
-                          (lambda ()
-                            (raise-syntax-error
-                             'parser-production-rhs
-                             (format
-                              "unrecognized terminal ~a in precedence declaration"
-                              (syntax-object->datum (syntax term)))
-                             (syntax term)))))
-                        (parse-action p (syntax action)))
-                       (set! counter (add1 counter)))))
+                     (set! counter (add1 counter))
+                     (make-prod 
+                      nt 
+                      p
+                      counter
+                      (term-prec
+                       (hash-table-get 
+                        term-table 
+                        (syntax-object->datum (syntax term))
+                        (lambda ()
+                          (raise-syntax-error
+                           'parser-production-rhs
+                           (format
+                            "unrecognized terminal ~a in precedence declaration"
+                            (syntax-object->datum (syntax term)))
+                           (syntax term)))))
+                      (parse-action p (syntax action)))))
                   (_
                    (raise-syntax-error
                     'parser-production-rhs
@@ -357,24 +353,31 @@
                     "A production for a non-terminal must be (non-term right-hand-side ...) with at least 1 right hand side"
                     prods-so))))))
 	
-        (let* ((start (make-non-term 'Start 0))
+        (set! counter 0)
+        (let* ((start (make-non-term (gensym) 0))
+               (end-non-term (make-non-term (gensym) 1))
                (prods 
-                (cons
-                 (list (make-prod start
-                                  (vector (hash-table-get non-term-table start-sym)
-                                          (hash-table-get term-table (car end-terms)))
-                                  0
-                                  #f
-                                  (datum->syntax-object
-                                   runtime
-                                   `(lambda (x) x))))
-                 (map parse-prods-for-nt (cdr (syntax->list prods)))))
+                `((,(make-prod start (vector end-non-term) 0 #f #f))
+                  ,(map
+                    (lambda (end)
+                      (set! counter (add1 counter))
+                      (make-prod end-non-term
+                                 (vector
+                                  (hash-table-get non-term-table start-sym)
+                                  (hash-table-get term-table end))
+                                 counter
+                                 #f
+                                 (datum->syntax-object
+                                  runtime
+                                  `(lambda (x) x))))
+                    end-terms)
+                  ,@(map parse-prods-for-nt (cdr (syntax->list prods)))))
                (nulls (nullable (apply append prods) 
-                                (add1 (length non-terms)))))
+                                (+ 2 (length non-terms)))))
           
           
 ;          (printf "nullable: {~a}~n~n"
-;                  (apply string-append 
+;                  (apply string-append
 ;                         (let loop ((i 0))
 ;                           (cond
 ;                             ((>= i (vector-length nulls)) null)
@@ -389,7 +392,7 @@
            (list->vector prods)
            (apply append prods)
            nulls
-           (cons start non-terms)
+           (cons start (cons end-non-term non-terms))
            terms
-           counter
+           (add1 counter)
            end-terms))))))

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

@@ -40,13 +40,21 @@
   ;;   action array2d * term vector * non-term vector * kernel vector * 
   ;;     output-port ->
   ;; Prints out the parser given by table.
-  (define (display-parser table terms non-terms states port)
+  (define (display-parser table terms non-terms states prods port)
     (let* ((num-terms (vector-length terms))
 	   (num-non-terms (vector-length non-terms))
 	   (num-gram-syms (+ num-terms num-non-terms))
 	   (num-states (vector-length states))
 	   (SR-conflicts 0)
 	   (RR-conflicts 0))
+      (for-each
+       (lambda (prod)
+         (fprintf port 
+                  "~a\t~a\t=\t~a~n" 
+                  (prod-index prod)
+                  (gram-sym-symbol (prod-lhs prod))
+                  (map gram-sym-symbol (vector->list (prod-rhs prod)))))
+       prods)
       (let loop ((i 0))
 	(if (< i num-states)
 	    (begin
@@ -278,7 +286,8 @@
 			      (exn:i/o:filesystem-detail e))))]
 	    (call-with-output-file file
 	      (lambda (port)
-		(display-parser table get-term get-non-term get-state port)))))
+		(display-parser table get-term get-non-term get-state (grammar-prods g)
+                                port)))))
       (resolve-conflicts table num-states num-terms num-non-terms)
       table))
 )

collects/parser-tools/yacc.ss

@@ -64,6 +64,18 @@
                            "End token must be a symbol"
                            sym)))
                     (syntax->list (syntax (symbols ...))))
+                   (let ((d (duplicate-list? (syntax-object->datum 
+                                              (syntax (symbols ...))))))
+                     (if d
+                         (raise-syntax-error
+                          'parser-end
+                          (format "Duplicate end token definition for ~a" d)
+                          arg)))
+                   (if (= 0 (length (syntax->list (syntax (symbols ...)))))
+                       (raise-syntax-error
+                        'parser-end
+                        "end declaration must contain at least 1 token"
+                        arg))
                    (if end
                        (raise-syntax-error #f "Multiple end declarations" stx))
                    (set! end (syntax->list (syntax (symbols ...))))))