i

original commit: 03b6cde1f73a31100fc18ddd2509dde79cccfe2e

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

@@ -1,20 +1,41 @@
+;; Constructs to create and access grammars, the internal
+;; representation of the input to the parser generator.
+
 #cs
 (module grammar mzscheme
   
   (require (lib "class.ss")
            (lib "list.ss")
-           "yacc-helper.ss")
+           "yacc-helper.ss"
+           (lib "contracts.ss"))
+  
+  ;; Each production has a unique index 0 <= index <= number of productions
+  (define-struct prod (lhs rhs index prec action) (make-inspector))
+
+  ;; The dot-pos field is the index of the element in the rhs
+  ;; of prod that the dot immediately preceeds.
+  ;; Thus 0 <= dot-pos <= (vector-length rhs).
+  (define-struct item (prod dot-pos) (make-inspector))
+  
+  ;; gram-sym = (or/f term? non-term?)
+  ;; Each term has a unique index 0 <= index < number of terms
+  ;; Each non-term has a unique index 0 <= index < number of non-terms  
+  (define-struct term (sym index prec) (make-inspector))
+  (define-struct non-term (sym index) (make-inspector))
+
+  ;; a precedence declaration.
+  (define-struct prec (num assoc) (make-inspector))
+  
+  (provide/contract
+   (make-item (prod? (or/f false? natural-number?) . -> . item?))
+   (make-term (symbol? (or/f false? natural-number?) (or/f prec? false?) . -> . term?))
+   (make-non-term (symbol? (or/f false? natural-number?) . -> . non-term?))
+   (make-prec (natural-number? (symbols 'left 'right 'nonassoc) . -> . prec?))
+   (make-prod (non-term? (vectorof (or/f non-term? term?))
+               (or/f false? natural-number?) (or/f false? prec?) syntax? . -> . prod?)))
   
-  ;; Constructs to create and access grammars, the internal
-  ;; representation of the input to the parser generator.
-    
   (provide 
      
-   make-item
-   make-term
-   make-non-term
-   make-prec
-   make-prod
    
    ;; Things that work on items
    start-item? item-prod item->string 
@@ -36,12 +57,6 @@
 
   ;;---------------------- LR items --------------------------
   
-  ;; LR-item = (make-item production nat)
-  ;; The dot-pos field is the index of the element in the rhs
-  ;; of prod that the dot immediately preceeds.
-  ;; Thus 0 <= dot-pos <= (vector-length rhs).
-  (define-struct item (prod dot-pos) (make-inspector))
-
   ;; item<?: LR-item * LR-item -> bool
   ;; Lexicographic comparison on two items.
   (define (item<? i1 i2)
@@ -99,13 +114,6 @@
 
   ;; --------------------- Grammar Symbols --------------------------
 
-  ;; gram-sym = (make-term symbol int prec)
-  ;;          | (make-non-term symbol int)
-  ;; Each term has a unique index 0 <= index < number of terms
-  ;; Each non-term has a unique index 0 <= index < number of non-terms  
-  (define-struct term (sym index prec) (make-inspector))
-  (define-struct non-term (sym index) (make-inspector))
-
   (define (non-term<? nt1 nt2)
     (< (non-term-index nt1) (non-term-index nt2)))
   
@@ -134,12 +142,6 @@
       (else 
        (bitwise-ior (arithmetic-shift 1 (term-index (car terms))) (term-list->bit-vector (cdr terms))))))
   
-  ;; ------------------------- Precedences ---------------------------
-  
-  ;; a precedence declaration.  the sym should be 'left 'right or 'nonassoc
-  ;; prec = (make-prec int sym)
-  ;;      | #f
-  (define-struct prec (num assoc) (make-inspector))
 
   ;; ------------------------- Grammar ------------------------------
 
@@ -147,10 +149,12 @@
     (class object%
       (super-instantiate ())
       ;; prods: production list list
-      ;; where the nth element in the outermost list is the list of productions with the nth non-term as lhs
+      ;; where there is one production list per non-term
       (init prods)
+      ;; init-prods: production list
+      ;; The productions parsing can start from
       ;; nullable-non-terms is indexed by the non-term-index and is true iff non-term is nullable
-      (init-field terms non-terms end-terms)
+      (init-field init-prods terms non-terms end-terms)
   
       ;; list of all productions
       (define all-prods (apply append prods))
@@ -196,8 +200,7 @@
       (define/public (get-prods-for-non-term nt)
         (vector-ref nt->prods (non-term-index nt)))
       (define/public (get-prods) all-prods)
-      (define/public (get-init-prod)
-        (car (vector-ref nt->prods 0)))
+      (define/public (get-init-prods) init-prods)
       
       (define/public (get-terms) terms)
       (define/public (get-non-terms) non-terms)
@@ -275,9 +278,4 @@
                  nullable)))))))
 
   
-  ;; ------------------------ Productions ---------------------------
-  
-  ;; production = (make-prod non-term (gram-sym vector) int prec syntax-object)
-  ;; Each production has a unique index 0 <= index <= number of productions
-  (define-struct prod (lhs rhs index prec action) (make-inspector))
 )

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

@@ -345,10 +345,13 @@
         (let* ((starts (map (lambda (x) (make-non-term (gensym) #f)) start-syms))
                (end-non-terms (map (lambda (x) (make-non-term (gensym) #f)) start-syms))
                (parsed-prods (map parse-prods-for-nt (cdr (syntax->list prods))))
+               (start-prods
+                (map (lambda (start end-non-term)
+                       (list (make-prod start (vector end-non-term) #f #f 
+                                        (datum->syntax-object runtime `(lambda (x) x)))))
+                     starts end-non-terms))
                (prods 
-                `(,@(map (lambda (start end-non-term)
-                           (list (make-prod start (vector end-non-term) #f #f #f)))
-                         starts end-non-terms)
+                `(,@start-prods
                   ,@(map
                      (lambda (end-nt start-sym)
                        (map
@@ -368,6 +371,7 @@
 
           (make-object grammar%
             prods
+            (map car start-prods)
             terms
             (append starts (append end-non-terms non-terms))
             (map (lambda (term-name)

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

@@ -226,7 +226,7 @@
 	     ;; list for each kernel
 	     (kernels (make-hash-table 'equal))
 
-	     (counter 1)
+	     (counter 0)
 	     
 	     ;; goto: LR1-item list -> LR1-item list list
 	     ;; creates new kernels by moving the dot in each item in the
@@ -331,12 +331,19 @@
 				  (loop (add1 i)))))))
 		       (else null))))))))
 			
-             (start (list (make-item (send grammar get-init-prod) 0)))
-	     (startk (make-kernel start 0))
+             (starts 
+              (map (lambda (init-prod) (list (make-item init-prod 0)))
+                   (send grammar get-init-prods)))
+	     (startk
+              (map (lambda (start)
+                     (let ((k (make-kernel start counter)))
+                       (hash-table-put! kernels start k)
+                       (set! counter (add1 counter))
+                       k))
+                   starts))
 	     (new-kernels (make-queue)))
       
-      (hash-table-put! kernels start startk)
-      (let loop ((old-kernels (list startk))
+      (let loop ((old-kernels startk)
 		 (seen-kernels null))
 	(cond
 	 ((and (empty-queue? new-kernels) (null? old-kernels))

collects/parser-tools/yacc.ss

@@ -150,6 +150,7 @@
            (with-syntax ((check-syntax-fix check-syntax-fix)
                          (err error)
                          (ends end)
+                         (starts start)
                          (debug debug)
                          (table table)
                          (term-sym->index term-sym->index)
@@ -158,7 +159,7 @@
              (syntax
               (begin
                 check-syntax-fix
-                (parser-body debug err (quote ends) table term-sym->index actions src-pos)))))))
+                (parser-body debug err (quote starts) (quote ends) table term-sym->index actions src-pos)))))))
       (_
        (raise-syntax-error #f
                            "parser must have the form (parser args ...)"
@@ -188,7 +189,7 @@
   ;; an accept, shift or reduce structure - or a #f.  Except that we will encode
   ;; by changing (make-accept) -> 'accept, (make-shift i) -> i and
   ;; (make-reduce i1 i2 i3) -> #(i1 i2 i3)
-  (define (parser-body debug err ends table term-sym->index actions src-pos)
+  (define (parser-body debug err starts ends table term-sym->index actions src-pos)
     (letrec ((input->token
               (if src-pos
                   (lambda (ip)
@@ -341,5 +342,12 @@
                              (err #t (token-name tok) (token-value tok) (cadr ip) (caddr ip))
                              (err #t (token-name tok) (token-value tok)))
                          (parsing-loop (fix-error stack tok ip get-token) (get-token))))))))))
-      (make-parser 0)))
+      (cond
+        ((null? (cdr starts)) (make-parser 0))
+        (else
+         (let loop ((l starts)
+                    (i 0))
+           (cond
+             ((null? l) null)
+             (else (cons (make-parser i) (loop (cdr l) (add1 i))))))))))
   )