*** empty log message ***

original commit: 175b3e676da894cafbe6d905adfe0e3b50a24015

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

@@ -185,7 +185,14 @@
                (if (and (non-term? (vector-ref rhs i)) (nullable-non-term? (vector-ref rhs i)))
                    (loop (add1 i))
                    #f))
-              ((= i prod-length) #t)))))))
+              ((= i prod-length) #t)))))
+      
+      (define/public (nullable-non-term-thunk)
+        (lambda (nt)
+          (nullable-non-term? nt)))
+      (define/public (nullable-after-dot?-thunk)
+        (lambda (item)
+          (nullable-after-dot? item)))))
 	
 
   ;; ------------------------ Productions ---------------------------

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

@@ -10,12 +10,6 @@
 	   (lib "class.ss"))
 
   (provide compute-LA)
-
-  (define (list-head l n)
-    (cond
-      ((= 0 n) null)
-      (else (cons (car l) (list-head (cdr l) (sub1 n))))))
-  
   
   ;; compute-DR: LR0-automaton * grammar -> (trans-key -> term set)
   ;; computes for each state, non-term transition pair, the terminals
@@ -33,38 +27,49 @@
   ;; compute-reads: 
   ;;   LR0-automaton * grammar -> (trans-key -> trans-key list)
   (define (compute-reads a g)
-    (lambda (tk)
-      (let ((r (send a run-automaton (trans-key-st tk) (trans-key-gs tk))))
-	(map (lambda (x) (make-trans-key r x))
-	     (filter (lambda (non-term)
-		       (and (send g nullable-non-term? non-term)
-			    (send a run-automaton r non-term)))
-		     (send g get-non-terms ))))))
+    (let ((nullable-non-terms 
+           (filter (lambda (nt) (send g nullable-non-term? nt))
+                   (send g get-non-terms))))
+      (lambda (tk)
+        (let ((r (send a run-automaton (trans-key-st tk) (trans-key-gs tk))))
+          (map (lambda (x) (make-trans-key r x))
+               (filter (lambda (non-term) (send a run-automaton r non-term))
+                       nullable-non-terms))))))
 
   ;; compute-read: LR0-automaton * grammar -> (trans-key -> term set)
   ;; output term set is represented in bit-vector form
   (define (compute-read a g)
     (let* ((dr (compute-DR a g))
 	   (reads (compute-reads a g)))
-      (digraph-tk->terml (send a get-mapped-non-term-keys)
-			 reads
-			 dr
-                         (send a get-num-states)
-			 (send g get-num-terms)
-			 (send g get-num-non-terms))))
+      (time
+       (digraph-tk->terml (send a get-mapped-non-term-keys)
+                          reads
+                          dr
+                          (send a get-num-states)
+                          (send g get-num-terms)
+                          (send g get-num-non-terms))))
+  )
+;  ;; run-lr0-backward: lr0-automaton * gram-sym list * kernel * int -> kernel list
+;  ;; returns the list of all k such that state k transitions to state start on the
+;  ;; transitions in rhs (in order)
+;  (define (run-lr0-backward a rhs start num-states)
+;    (let loop ((states (list start))
+;               (rhs (reverse rhs)))
+;      (cond
+;        ((null? rhs) states)
+;        (else (loop (send a run-automaton-back states (car rhs))
+;		    (cdr rhs))))))
   
-  ;; run-lr0-backward: lr0-automaton * gram-sym list * kernel * int -> kernel list
+  ;; gram-sym list * kernel * int -> kernel list
   ;; returns the list of all k such that state k transitions to state start on the
   ;; transitions in rhs (in order)
-  (define (run-lr0-backward a rhs start num-states)
+  (define (run-lr0-backward a rhs dot-pos start num-states)
     (let loop ((states (list start))
-               (rhs (reverse rhs)))
+               (i (sub1 dot-pos)))
       (cond
-        ((null? rhs) states)
-        (else (loop (kernel-list-remove-duplicates
-                     (send a run-automaton-back states (car rhs))
-                     num-states)
-                    (cdr rhs))))))
+        ((< i 0) states)
+        (else (loop (send a run-automaton-back states (vector-ref rhs i))
+                    (sub1 i))))))
 
   ;; prod->items-for-include: grammar * prod * non-term -> lr0-item list
   ;; returns the list of all (B -> beta . nt gamma) such that prod = (B -> beta nt gamma)
@@ -91,74 +96,75 @@
   ;; and gamma =>* epsilon
   (define (prod-list->items-for-include g prod-list nt)
     (apply append (map (lambda (prod) (prod->items-for-include g prod nt)) prod-list)))
-  
+
   ;; comput-includes: lr0-automaton * grammar -> (trans-key -> trans-key list)
   (define (compute-includes a g)
-    (let ((non-terms (send g get-non-terms))
-          (num-states (send a get-num-states)))
+    (let ((num-states (send a get-num-states))
+          (items-for-input-nt (make-vector (send g get-num-non-terms) null)))
+      (for-each
+       (lambda (input-nt)
+         (vector-set! items-for-input-nt (non-term-index input-nt)
+                      (prod-list->items-for-include g (send g get-prods) input-nt)))
+       (send g get-non-terms))
       (lambda (tk)
-        (let ((goal-state (trans-key-st tk))
-              (non-term (trans-key-gs tk)))
-          (apply append
-                 (map (lambda (B)
-                        (map (lambda (state)
-                               (make-trans-key state B))
-                             (kernel-list-remove-duplicates
-                              (let ((items (prod-list->items-for-include g (send g get-prods-for-non-term B) non-term)))
-                                (apply append
-                                       (map (lambda (item)
-                                              (let ((rhs (prod-rhs (item-prod item))))
-                                                (run-lr0-backward a 
-                                                                  (list-head (vector->list rhs)
-                                                                             (- (vector-length rhs)
-                                                                                (item-dot-pos item)))
-                                                                  goal-state 
-                                                                  num-states)))
-                                            items)))
-                              num-states)))
-                      non-terms))))))
-                 
-        
-  ;; comput-includes: lr0-automaton * grammar -> (trans-key -> trans-key list)
-;  (define (compute-includes a g)
-;    (let* ((non-terms (send g get-non-terms))
-;	   (num-states (vector-length (send a get-states)))
-;	   (num-non-terms (length non-terms))
-;	   (includes (make-array2d num-states num-non-terms null)))
-;      (send a for-each-state
-;	    (lambda (state)
-;              (for-each
-;               (lambda (non-term)
-;                 (for-each
-;                  (lambda (prod)
-;                    (let loop ((i (make-item prod 0))
-;                               (p state))
-;                      (if (and p i)
-;                          (let* ((next-sym (sym-at-dot i))
-;                                 (new-i (move-dot-right i)))
-;                            (if (and (non-term? next-sym)
-;                                     (send g nullable-after-dot? new-i))
-;                                (array2d-add! includes
-;                                              (kernel-index p)
-;                                              (gram-sym-index next-sym)
-;                                              (make-trans-key state non-term)))
-;                            (if next-sym
-;                                (loop new-i
-;                                      (send a run-automaton p next-sym)))))))
-;                  (send g get-prods-for-non-term non-term)))
-;               non-terms)))
+        (let* ((goal-state (trans-key-st tk))
+               (non-term (trans-key-gs tk))
+               (items (vector-ref items-for-input-nt (non-term-index non-term))))
+          (trans-key-list-remove-dups
+           (apply append
+                  (map (lambda (item)
+                         (let* ((prod (item-prod item))
+                                (rhs (prod-rhs prod))
+                                (lhs (prod-lhs prod)))
+                           (map (lambda (state)
+                                  (make-trans-key state lhs))
+                                (run-lr0-backward a 
+                                                  rhs
+                                                  (item-dot-pos item)
+                                                  goal-state 
+                                                  num-states))))
+                       items)))))))
+           
+;   ;; compute-includes: lr0-automaton * grammar -> (trans-key -> trans-key list)
+;   (define (compute-includes a g)
+;     (let* ((non-terms (send g get-non-terms))
+; 	   (num-states (vector-length (send a get-states)))
+; 	   (num-non-terms (length non-terms))
+; 	   (includes (make-array2d num-states num-non-terms null)))
+;       (send a for-each-state
+; 	    (lambda (state)
+; 	      (for-each
+; 	       (lambda (non-term)
+; 		 (for-each
+; 		  (lambda (prod)
+; 		    (let loop ((i (make-item prod 0))
+; 			       (p state))
+; 		      (if (and p i)
+; 			  (let* ((next-sym (sym-at-dot i))
+; 				 (new-i (move-dot-right i)))
+; 			    (if (and (non-term? next-sym)
+; 				     (send g nullable-after-dot? new-i))
+; 				(array2d-add! includes
+; 					      (kernel-index p)
+; 					      (gram-sym-index next-sym)
+; 					      (make-trans-key state non-term)))
+; 			    (if next-sym
+; 				(loop new-i
+; 				      (send a run-automaton p next-sym)))))))
+; 		  (send g get-prods-for-non-term non-term)))
+; 	       non-terms)))
 ;      
-;      (lambda (tk)
-;	(array2d-ref includes 
-;		     (kernel-index (trans-key-st tk))
-;		     (gram-sym-index (trans-key-gs tk))))))
-;  
-  ; compute-lookback: lr0-automaton * grammar -> (kernel * proc -> trans-key list)
+;       (lambda (tk)
+; 	(array2d-ref includes 
+; 		     (kernel-index (trans-key-st tk))
+; 		     (gram-sym-index (trans-key-gs tk))))))
+  
+  ;; compute-lookback: lr0-automaton * grammar -> (kernel * proc -> trans-key list)
   (define (compute-lookback a g)
     (let ((num-states (send a get-num-states)))
       (lambda (state prod)
         (map (lambda (k) (make-trans-key k (prod-lhs prod)))
-             (run-lr0-backward a (vector->list (prod-rhs prod)) state num-states)))))
+             (run-lr0-backward a (prod-rhs prod) (vector-length (prod-rhs prod)) state num-states)))))
   
   ;; compute-follow:  LR0-automaton * grammar -> (trans-key -> term set)
   ;; output term set is represented in bit-vector form
@@ -176,7 +182,7 @@
   (define (compute-LA a g)
     (let* ((includes (compute-includes a g))
 	   (lookback (compute-lookback a g))
-	   (follow (compute-follow a g includes)))
+	   (follow  (compute-follow a g includes)))
       (lambda (k p)
 	(let* ((l (lookback k p))
 	       (f (map follow l)))

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

@@ -10,8 +10,8 @@
 	   (lib "class.ss"))
   
   (provide build-lr0-automaton lr0%
-	   (struct trans-key (st gs))
-	   kernel-items kernel-index kernel-list-remove-duplicates)
+	   (struct trans-key (st gs)) trans-key-list-remove-dups
+	   kernel-items kernel-index)
   
   ;; kernel = (make-kernel (LR1-item list) index)
   ;;   the list must be kept sorted according to item<? so that equal? can
@@ -21,25 +21,30 @@
   (define-struct kernel (items index) (make-inspector))
   (define-struct trans-key (st gs) (make-inspector))
 
+  (define (trans-key<? a b)
+    (let ((kia (kernel-index (trans-key-st a)))
+          (kib (kernel-index (trans-key-st b))))
+    (or (< kia kib)
+        (and (= kia kib)
+             (< (non-term-index (trans-key-gs a))
+                (non-term-index (trans-key-gs b)))))))
   
-  ;; kernel-list-remove-duplicates: kernel list * int -> kernel list
-  (define (kernel-list-remove-duplicates k num-states)
-    (let ((v (make-vector num-states #f)))
-      (for-each
-       (lambda (k)
-	 (vector-set! v (kernel-index k) k))
-       k)
-      (let loop ((i 0))
-	(cond
-          ((< i num-states)
-           (let ((k (vector-ref v i)))
-             (if k 
-                 (cons k (loop (add1 i)))
-                 (loop (add1 i)))))
-          (else null)))))
-  
-	  
-
+  (define (trans-key-list-remove-dups tkl)
+    (let loop ((sorted (quicksort tkl trans-key<?)))
+      (cond
+        ((null? sorted) null)
+        ((null? (cdr sorted)) sorted)
+        (else
+         (if (and (= (non-term-index (trans-key-gs (car sorted)))
+                     (non-term-index (trans-key-gs (cadr sorted))))
+                  (= (kernel-index (trans-key-st (car sorted)))
+                     (kernel-index (trans-key-st (cadr sorted)))))
+             (loop (cdr sorted))
+             (cons (car sorted) (loop (cdr sorted))))))))
+             
+      
+           
+  ;; kernel-list-remove-duplicates
   ;; LR0-automaton = object of class lr0%
   (define lr0%
     (class object%
@@ -48,13 +53,13 @@
       (init term-hash non-term-hash)
       (init-field states epsilons num-terms num-non-terms)
       
-      (define term-transitions (make-lr0-table term-hash (vector-length states) num-terms))
-      (define non-term-transitions (make-lr0-table non-term-hash (vector-length states) num-non-terms))
+      (define term-transitions (make-lr0-table term-hash (vector-length states) num-terms #f))
+      (define non-term-transitions (make-lr0-table non-term-hash (vector-length states) num-non-terms #f))
       
       (define reverse-term-hash (reverse-hash term-hash))
       (define reverse-non-term-hash (reverse-hash non-term-hash))
-      (define reverse-term-transitions (make-lr0-table reverse-term-hash (vector-length states) num-terms))
-      (define reverse-non-term-transitions (make-lr0-table reverse-non-term-hash (vector-length states) num-non-terms))
+      (define reverse-term-transitions (make-lr0-table reverse-term-hash (vector-length states) num-terms null))
+      (define reverse-non-term-transitions (make-lr0-table reverse-non-term-hash (vector-length states) num-non-terms null))
       
       (define mapped-non-terms
 	(hash-table-map non-term-hash (lambda (k v) k)))
@@ -101,8 +106,8 @@
 			  (array2d-ref reverse-non-term-transitions (kernel-index k) (non-term-index s)))
 			k))))))
   
-  (define (make-lr0-table auto-hash states syms)
-    (let ((t (make-array2d states syms #f)))
+  (define (make-lr0-table auto-hash states syms def)
+    (let ((t (make-array2d states syms def)))
       (hash-table-map auto-hash
                       (lambda (k v)
                         (array2d-set! t 

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

@@ -2,9 +2,9 @@
 (module parser-builder mzscheme
   
   (require "input-file-parser.ss"
-           "table.ss"
            "parser-actions.ss"
            "grammar.ss"
+           "table.ss"
            (lib "class.ss"))
   
   (provide build-parser)
@@ -42,41 +42,8 @@
   
   (define (build-parser filename src-pos suppress input-terms start end assocs prods runtime)
     (let* ((grammar (parse-input start end input-terms assocs prods runtime src-pos))
-	   (table (build-table grammar filename suppress))
-           (table-code 
-            `((lambda (table-list)
-                (let ((v (list->vector table-list)))
-                  (let build-table-loop ((i 0))
-                    (cond
-                      ((< i (vector-length v))
-                       (let ((vi (vector-ref v i)))
-                         (cond
-                           ((list? vi) 
-                            (vector-set! v i
-                                         (cond
-                                           ((eq? 's (car vi))
-                                            (make-shift (cadr vi)))
-                                           ((eq? 'r (car vi))
-                                            (make-reduce (cadr vi) (caddr vi) (cadddr vi)))
-                                           ((eq? 'a (car vi)) (make-accept)))))))
-                       (build-table-loop (add1 i)))
-                      (else v)))))
-              (quote
-               ,(map (lambda (action)
-                       (cond
-                         ((shift? action)
-                          `(s ,(shift-state action)))
-                         ((reduce? action)
-                          `(r ,(reduce-prod-num action)
-                              ,(reduce-lhs-num action)
-                              ,(reduce-rhs-length action)))
-                         ((accept? action)
-                          `(a))
-                         (else action)))
-                     (vector->list table)))))
-            
+           (table (build-table grammar filename suppress))
            (num-non-terms (send grammar get-num-non-terms))
-
            (token-code
             `(let ((ht (make-hash-table)))
                (begin
@@ -86,12 +53,22 @@
                                             ,(+ num-non-terms (gram-sym-index term))))
                         (send grammar get-terms))
                  ht)))
-           
            (actions-code
             `(vector ,@(map prod-action (send grammar get-prods)))))
-      (values table-code
-              token-code
-              actions-code
-              (fix-check-syntax start input-terms prods assocs end))))
+      (let loop ((i 1))
+        (if (< i (vector-length table))
+            (let ((a (vector-ref table i)))
+              (vector-set! table i (cond
+                                     ((accept? a) 'accept)
+                                     ((shift? a) (- (shift-state a)))
+                                     ((reduce? a) (vector (reduce-prod-num a)
+                                                          (reduce-lhs-num a)
+                                                          (reduce-rhs-length a)))
+                                     (else a)))
+              (loop (add1 i)))))
+    (values table
+            token-code
+            actions-code
+            (fix-check-syntax start input-terms prods assocs end))))
       
   )

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

@@ -213,9 +213,9 @@
 
   ;; 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
+  ;; buile-table: grammar * string -> action array2d
   (define (build-table g file suppress)
-    (let* ((a (time (build-lr0-automaton g)))
+    (let* ((a (build-lr0-automaton g))
            (terms (send g get-terms))
            (non-terms (send g get-non-terms))
            (get-term (list->vector terms))
@@ -229,7 +229,7 @@
                (+ num-non-terms (gram-sym-index term)))
              (send g get-end-terms)))
            (num-gram-syms (+ num-terms num-non-terms))
-           (table (make-array2d (vector-length (send a get-states)) num-gram-syms #f))
+           (table (make-array2d (send a get-num-states) num-gram-syms #f))
            (array2d-add!
             (lambda (v i1 i2 a)
               (let ((old (array2d-ref v i1 i2)))
@@ -240,69 +240,71 @@
                   (else (if (not (equal? a old))
                             (array2d-set! v i1 i2 (list a old))))))))
            (get-lookahead (time (compute-LA a g))))
-      (time
-       (send a for-each-state
-             (lambda (state)
-               (let loop ((i 0))
-                 (if (< i num-gram-syms)
-                     (begin
-                       (let* ((s (if (< i num-non-terms)
-                                     (vector-ref get-non-term i)
-                                     (vector-ref get-term (- i num-non-terms))))
-                              (goto
-                               (send a run-automaton state s)))
-                         (if goto
-                             (array2d-set! table 
-                                           (kernel-index state) 
-                                           i
-                                           (cond
-                                             ((< i num-non-terms)
-                                              (kernel-index goto))
-                                             ((member i end-term-indexes)
-                                              (make-accept))
-                                             (else
-                                              (make-shift 
-                                               (kernel-index goto)))))))
-                       (loop (add1 i)))))
+     
+      (send a for-each-state
+            (lambda (state)
+              (let loop ((i 0))
+                (if (< i num-gram-syms)
+                    (begin
+                      (let* ((s (if (< i num-non-terms)
+                                    (vector-ref get-non-term i)
+                                    (vector-ref get-term (- i num-non-terms))))
+                             (goto
+                              (send a run-automaton state s)))
+                        (if goto
+                            (array2d-set! table 
+                                          (kernel-index state) 
+                                          i
+                                          (cond
+                                            ((< i num-non-terms)
+                                             (kernel-index goto))
+                                            ((member i end-term-indexes)
+                                             (make-accept))
+                                            (else
+                                             (make-shift 
+                                              (kernel-index goto)))))))
+                      (loop (add1 i)))))
+            
+              (for-each
+               (lambda (item)
+                 (let ((item-prod (item-prod item)))
+                   (bit-vector-for-each 
+                    (lambda (term-index)
+                      (array2d-add! table 
+                                    (kernel-index state)
+                                    (+ num-non-terms term-index)
+                                    (cond
+                                      ((not (start-item? item))
+                                       (make-reduce
+                                        (prod-index item-prod)
+                                        (gram-sym-index (prod-lhs item-prod))
+                                        (vector-length (prod-rhs item-prod)))))))
+                    (get-lookahead state item-prod))))
                
-               (for-each
-                (lambda (item)
-                  (let ((item-prod (item-prod item)))
-                    (bit-vector-for-each 
-                     (lambda (term-index)
-                       (array2d-add! table 
-                                     (kernel-index state)
-                                     (+ num-non-terms term-index)
-                                     (cond
-                                       ((not (start-item? item))
-                                        (make-reduce
-                                         (prod-index item-prod)
-                                         (gram-sym-index (prod-lhs item-prod))
-                                         (vector-length (prod-rhs item-prod)))))))
-                     (get-lookahead state item-prod))))
-                
-                (append (hash-table-get (send a get-epsilon-trans) state (lambda () null))
-                        (filter (lambda (item)
-                                  (not (move-dot-right item)))
-                                (kernel-items state)))))))
-      
+               (append (hash-table-get (send a get-epsilon-trans) state (lambda () null))
+                       (filter (lambda (item)
+                                 (not (move-dot-right item)))
+                               (kernel-items state))))))
+ 
       (resolve-prec-conflicts a table get-term get-prod num-terms
-                              num-non-terms)
-      
-      (if (not (string=? file ""))
-          (with-handlers [(exn:i/o:filesystem?
-                           (lambda (e)
-                             (fprintf 
-                              (current-error-port)
-                              "Cannot write debug output to file \"~a\".  ~a~n"
-                              (exn:i/o:filesystem-pathname e)
-                              (exn:i/o:filesystem-detail e))))]
-            (call-with-output-file file
-              (lambda (port)
-                (display-parser a table get-term get-non-term (send g get-prods)
-                                port)))))
-      (resolve-conflicts a table num-terms num-non-terms suppress)
-      table))
-)
-       
+                            num-non-terms)
+    
+    (if (not (string=? file ""))
+        (with-handlers [(exn:i/o:filesystem?
+                         (lambda (e)
+                           (fprintf 
+                            (current-error-port)
+                            "Cannot write debug output to file \"~a\".  ~a~n"
+                            (exn:i/o:filesystem-pathname e)
+                            (exn:i/o:filesystem-detail e))))]
+          (call-with-output-file file
+            (lambda (port)
+              (display-parser a table get-term get-non-term (send g get-prods)
+                              port)))))
+    (resolve-conflicts a table num-terms num-non-terms suppress)
+    table))
 
+    )
+     
+     
+     

collects/parser-tools/yacc.ss

@@ -3,8 +3,7 @@
   
   (require-for-syntax "private-yacc/parser-builder.ss"
                       "private-yacc/yacc-helper.ss")
-  (require "private-yacc/parser-actions.ss"
-           "private-yacc/array2d.ss"
+  (require "private-yacc/array2d.ss"
            "private-lex/token.ss"
 	   (lib "readerr.ss" "syntax"))
   
@@ -154,6 +153,18 @@
 
   (define (false-thunk) #f) 
 
+  (define shift? integer?)
+  (define (shift-state x) (- x))
+  (define reduce? vector?)
+  (define (reduce-prod-num x) (vector-ref x 0))
+  (define (reduce-lhs-num x) (vector-ref x 1))
+  (define (reduce-rhs-length x) (vector-ref x 2))
+  (define (accept? x) (eq? x 'accept))
+  
+  ;; The table format is an array2d that maps each state/term pair to either
+  ;; 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 err ends table term-sym->index actions src-pos)
     (letrec ((input->token
               (if src-pos