*** empty log message ***

original commit: 8a774b04bc0a1d916fa10955d608b77ea10e001d

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

@@ -4,8 +4,6 @@
   
   (require "lr0.ss"
 	   "grammar.ss"
-	   "array2d.ss"
-           "graph.ss"
 	   (lib "list.ss")
 	   (lib "class.ss"))
 
@@ -35,18 +33,16 @@
           (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
+                         reads
-                          dr
+                         dr
-                          (send a get-num-states)
+                         (send a get-num-states))))
-                          (send g get-num-terms)
-                          (send g get-num-non-terms))))
   ;; 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 dot-pos start num-states)
@@ -125,11 +121,9 @@
       (digraph-tk->terml (send a get-mapped-non-term-keys)
                          includes
                          read
-                         (send a get-num-states)
+                         (send a get-num-states))))
-                         (send g get-num-terms)
-                         (send g get-num-non-terms))))
     
-  ;; compute-LA: LR0-automaton * grammar -> (kernel * prod -> term set)
+  ;; compute-LA: LR0-automaton * grammar -> kernel * prod -> term set
   ;; output term set is represented in bit-vector form
   (define (compute-LA a g)
     (let* ((includes (compute-includes a g))
@@ -202,43 +196,51 @@
 	(gram-sym-symbol (trans-key-gs p))))
      r))
 
+  ;; init-tk-map : int -> (vectorof hashtable?)
+  (define (init-tk-map n)
+    (let ((v (make-vector n #f)))
+      (let loop ((i (sub1 (vector-length v))))
+        (when (>= i 0)
+          (vector-set! v i (make-hash-table))
+          (loop (sub1 i))))
+      v))
+  
+  ;; lookup-tk-map : (vectorof (symbol? int hashtable)) -> trans-key? -> int
+  (define (lookup-tk-map map)
+    (lambda (tk)
+      (let ((st (trans-key-st tk))
+            (gs (trans-key-gs tk)))
+        (hash-table-get (vector-ref map (kernel-index st))
+                        (gram-sym-symbol gs)
+                        (lambda () 0)))))
+
+  ;; add-tk-map : (vectorof (symbol? int hashtable)) -> trans-key int -> 
+  (define (add-tk-map map)
+    (lambda (tk v)
+      (let ((st (trans-key-st tk))
+            (gs (trans-key-gs tk)))
+        (hash-table-put! (vector-ref map (kernel-index st))
+                         (gram-sym-symbol gs)
+                         v))))
+             
   ;; digraph-tk->terml: 
   ;;   (trans-key list) * (trans-key -> trans-key list) * (trans-key -> term list) * int * int * int
   ;;     -> (trans-key -> term list)
   ;; DeRemer and Pennello 1982
   ;; Computes (f x) = (f- x) union Union{(f y) | y in (edges x)}
   ;; A specialization of digraph in the file graph.ss
-  (define (digraph-tk->terml nodes edges f- num-states num-terms num-non-terms)
+  (define (digraph-tk->terml nodes edges f- num-states)
     (letrec (
 	     ;; Will map elements of trans-key to term sets represented as bit vectors
-	     (results-terms (make-array2d num-states num-terms 0))
+	     (results (init-tk-map num-states))
-	     (results-non-terms (make-array2d num-states num-non-terms 0))
+             
-
 	     ;; Maps elements of trans-keys to integers.
-	     (N-terms (make-array2d num-states num-terms 0))
+	     (N (init-tk-map num-states))
-	     (N-non-terms (make-array2d num-states num-non-terms 0))
+             
-
+             (get-N (lookup-tk-map N))
-	     (lookup-tk-map
+	     (set-N (add-tk-map N))
-	      (lambda (map-term map-non-term)
+	     (get-f (lookup-tk-map results))
-		(lambda (tk) 
+	     (set-f (add-tk-map results))
-		  (let ((st (trans-key-st tk))
-			(gs (trans-key-gs tk)))
-		    (if (term? gs)
-			(array2d-ref map-term (kernel-index st) (term-index gs))
-			(array2d-ref map-non-term (kernel-index st) (non-term-index gs)))))))
-	     (add-tk-map
-	      (lambda (map-term map-non-term)
-		(lambda (tk v)
-		  (let ((st (trans-key-st tk))
-			(gs (trans-key-gs tk)))
-		    (if (term? gs)
-			(array2d-set! map-term (kernel-index st) (term-index gs) v)
-			(array2d-set! map-non-term (kernel-index st) (non-term-index gs) v))))))
-		      
-	     (get-N (lookup-tk-map N-terms N-non-terms))
-	     (set-N (add-tk-map N-terms N-non-terms))
-	     (get-f (lookup-tk-map results-terms results-non-terms))
-	     (set-f (add-tk-map results-terms results-non-terms))
 	     
 	     (stack null)
 	     (push (lambda (x)
@@ -257,20 +259,20 @@
 		  (set-N x d)
 		  (set-f x (f- x))
 		  (for-each (lambda (y)
-			      (if (= 0 (get-N y))
+			      (when (= 0 (get-N y))
-				  (traverse y))
+                                (traverse y))
 			      (set-f x (bitwise-ior (get-f x) (get-f y)))
 			      (set-N x (min (get-N x) (get-N y))))
 			    (edges x))
-		  (if (= d (get-N x))
+		  (when (= d (get-N x))
-		      (let loop ((p (pop)))
+                    (let loop ((p (pop)))
-			(set-N p +inf.0)
+                      (set-N p +inf.0)
-			(set-f p (get-f x))
+                      (set-f p (get-f x))
-			(if (not (equal? x p))
+                      (unless (equal? x p)
-			    (loop (pop)))))))))
+                        (loop (pop)))))))))
       (for-each (lambda (x)
-		  (if (= 0 (get-N x))
+		  (when (= 0 (get-N x))
-		      (traverse x)))
+                    (traverse x)))
 		nodes)
       get-f))
 )

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

@@ -4,14 +4,13 @@
   
   (require "grammar.ss"
 	   "graph.ss"
-           "array2d.ss"
 	   (lib "list.ss")
 	   (lib "class.ss"))
   
   (provide build-lr0-automaton lr0%
 	   (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
   ;;   be used to compare kernels
@@ -43,41 +42,76 @@
              
       
            
+  ;; build-transition-table : int (listof (cons/c trans-key X) ->
+  ;;                          (vectorof (symbol X hashtable))
+  (define (build-transition-table num-states assoc)
+    (let ((transitions (make-vector num-states #f)))
+      (let loop ((i (sub1 (vector-length transitions))))
+        (when (>= i 0)
+          (vector-set! transitions i (make-hash-table))
+          (loop (sub1 i))))
+      (for-each
+       (lambda (trans-key/kernel)
+         (let ((tk (car trans-key/kernel)))
+           (hash-table-put! (vector-ref transitions (kernel-index (trans-key-st tk)))
+                            (gram-sym-symbol (trans-key-gs tk))
+                            (cdr trans-key/kernel))))
+       assoc)
+      transitions))
+  
+  ;; reverse-assoc : (listof (cons/c trans-key? kernel?)) ->
+  ;;                 (listof (cons/c trans-key? (listof kernel?)))
+  (define (reverse-assoc assoc)
+    (let ((reverse-hash (make-hash-table 'equal))
+	  (hash-table-add!
+	   (lambda (ht k v)
+	     (hash-table-put! ht k (cons v (hash-table-get ht k (lambda () null)))))))
+      (for-each
+       (lambda (trans-key/kernel)
+         (let ((tk (car trans-key/kernel)))
+           (hash-table-add! reverse-hash 
+                            (make-trans-key (cdr trans-key/kernel)
+                                            (trans-key-gs tk))
+                            (trans-key-st tk))))
+       assoc)
+      (hash-table-map reverse-hash cons)))
+
+
   ;; kernel-list-remove-duplicates
   ;; LR0-automaton = object of class lr0%
   (define lr0%
     (class object%
       (super-instantiate ())
-      ;; Hash tables that map a trans-keys to a kernel
+      ;; term-assoc : (listof (cons/c trans-key? kernel?))
-      (init term-hash non-term-hash)
+      ;; non-term-assoc : (listof (cons/c trans-key? kernel?))
-      (init-field states epsilons num-terms num-non-terms)
+      ;; states : (vectorof kernel?)
-      
+      ;; epsilons : ???
-      (define term-transitions (make-lr0-table term-hash (vector-length states) num-terms #f))
+      (init-field term-assoc non-term-assoc states epsilons)
-      (define non-term-transitions (make-lr0-table non-term-hash (vector-length states) num-non-terms #f))
+            
+      (define transitions (build-transition-table (vector-length states)
+                                                  (append term-assoc non-term-assoc)))
       
-      (define reverse-term-hash (reverse-hash term-hash))
+      (define reverse-term-assoc (reverse-assoc term-assoc))
-      (define reverse-non-term-hash (reverse-hash non-term-hash))
+      (define reverse-non-term-assoc (reverse-assoc non-term-assoc))
-      (define reverse-term-transitions (make-lr0-table reverse-term-hash (vector-length states) num-terms null))
+      (define reverse-transitions
-      (define reverse-non-term-transitions (make-lr0-table reverse-non-term-hash (vector-length states) num-non-terms null))
+        (build-transition-table (vector-length states)
+                                (append reverse-term-assoc reverse-non-term-assoc)))
       
-      (define mapped-non-terms
+      (define mapped-non-terms (map car non-term-assoc))
-	(hash-table-map non-term-hash (lambda (k v) k)))
-      
-      (define reverse-mapped-non-terms
-	(hash-table-map reverse-non-term-hash (lambda (k v) k)))
       
       (define/public (get-mapped-non-term-keys)
 	mapped-non-terms)
 
-      (define/public (get-states)
-	states)
-
       (define/public (get-num-states)
         (vector-length states))
       
       (define/public (get-epsilon-trans)
 	epsilons)
 
+      (define/public (get-transitions)
+        (append term-assoc non-term-assoc))
+      
+      ;; for-each-state : (state ->) ->
       ;; Iteration over the states in an automaton
       (define/public (for-each-state f)
 	(let ((num-states (vector-length states)))
@@ -87,47 +121,25 @@
 		  (f (vector-ref states i))
 		  (loop (add1 i)))))))
       
-      ;; run-automaton: kernel * gram-sym -> kernel | #f
+      ;; run-automaton: kernel? gram-sym? -> (union kernel #f)
-      ;; returns the state that the transition trans-key provides or #f
+      ;; returns the state reached from state k on input s, or #f when k
-      ;; if there is no such state
+      ;; has no transition on s
       (define/public (run-automaton k s)
-	(if (term? s)
+        (hash-table-get (vector-ref transitions (kernel-index k))
-	    (array2d-ref term-transitions (kernel-index k) (term-index s))
+                        (gram-sym-symbol s)
-	    (array2d-ref non-term-transitions (kernel-index k) (non-term-index s))))
+                        (lambda () #f)))
-      
+
+      ;; run-automaton-back : (listof kernel?) gram-sym? -> (listof kernel)
+      ;; returns the list of states that can reach k by transitioning on s.
       (define/public (run-automaton-back k s)
 	(apply append
-	       (if (term? s)
+               (map 
-		   (map (lambda (k)
+                (lambda (k)
-			  (array2d-ref reverse-term-transitions (kernel-index k) (term-index s)))
+                  (hash-table-get (vector-ref reverse-transitions (kernel-index k))
-			k)
+                                  (gram-sym-symbol s)
-		   (map (lambda (k)
+                                  (lambda () null)))
-			  (array2d-ref reverse-non-term-transitions (kernel-index k) (non-term-index s)))
+                k)))))
-			k))))))
+      			
-  
-  (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 
-                                      (kernel-index (trans-key-st k))
-                                      (gram-sym-index (trans-key-gs k))
-                                      v)))
-      t))
-  
-  (define (reverse-hash hash)
-    (let ((reverse-hash (make-hash-table 'equal))
-	  (hash-table-add!
-	   (lambda (ht k v)
-	     (hash-table-put! ht k (cons v (hash-table-get ht k (lambda () null)))))))
-      (hash-table-for-each hash
-			   (lambda (k v)
-			     (hash-table-add! reverse-hash 
-					      (make-trans-key v (trans-key-gs k))
-					      (trans-key-st k))))
-      reverse-hash))
-
-			
   (define (union comp<?)
     (letrec ((union
 	      (lambda (l1 l2)
@@ -153,27 +165,14 @@
 			(kernel-items k)) 
 	     "}")))
 
-
-  (define (add-lr0-transition! ttable nttable key value)
-    (hash-table-put!
-     (if (term? (trans-key-gs key))
-         ttable
-         nttable)
-     key
-     value))
-		      
-  
   ;; build-LR0-automaton: grammar -> LR0-automaton
   ;; Constructs the kernels of the sets of LR(0) items of g
   (define (build-lr0-automaton grammar)
 ;    (printf "LR(0) automaton:~n")
     (letrec (
-	     (terms (list->vector (send grammar get-terms)))
-	     (non-terms (list->vector (send grammar get-non-terms)))
-	     (num-non-terms (send grammar get-num-non-terms))
-	     (num-gram-syms (+ num-non-terms (send grammar get-num-terms)))
 	     (epsilons (make-hash-table 'equal))
-	     
+	     (grammar-symbols (append (send grammar get-non-terms)
+                                      (send grammar get-terms)))
 	     ;; first-non-term: non-term -> non-term list
 	     ;; given a non-terminal symbol C, return those non-terminal 
 	     ;; symbols A s.t. C -> An for some string of terminals and
@@ -218,8 +217,8 @@
 
 
 	     ;; maps trans-keys to kernels
-	     (automaton-term (make-hash-table 'equal))
+	     (automaton-term null)
-             (automaton-non-term (make-hash-table 'equal))
+             (automaton-non-term null)
 	     
 	     ;; keeps the kernels we have seen, so we can have a unique
 	     ;; list for each kernel
@@ -235,12 +234,11 @@
 	     (goto
 	      (lambda (kernel)
 		(let (
-		      ;; maps each gram-syms to a list of items
+		      ;; maps a gram-syms to a list of items
-
+		      (table (make-hash-table))
-		      (table (make-vector num-gram-syms null))
 
 		      ;; add-item!: 
-		      ;;   (item list) vector * item ->
+		      ;;   (symbol (listof item) hashtable) item? ->
 		      ;; adds i into the table grouped with the grammar
 		      ;; symbol following its dot
 		      (add-item!
@@ -248,17 +246,14 @@
 			 (let ((gs (sym-at-dot i)))
 			   (cond
 			    (gs
-			     (let* ((add (if (term? gs)
+			     (let ((already 
-					     num-non-terms
+                                    (hash-table-get table
-					     0))
+                                                    (gram-sym-symbol gs)
-				    (already 
+                                                    (lambda () null))))
-				     (vector-ref table 
+			       (unless (member i already)
-						 (+ add 
+                                 (hash-table-put! table 
-						    (gram-sym-index gs)))))
+                                                  (gram-sym-symbol gs)
-			       (if (not (member i already))
+                                                  (cons i already)))))
-				   (vector-set! table 
-						(+ add (gram-sym-index gs))
-						(cons i already)))))
 			    ((= 0 (vector-length (prod-rhs (item-prod i))))
 			     (let ((current (hash-table-get epsilons
 							    kernel
@@ -301,34 +296,34 @@
 								  new-kernel
 								  k)
 						 k)))))
-			(add-lr0-transition! automaton-term automaton-non-term
+                        (cond
-                                             (make-trans-key kernel gs)
+                          ((term? gs)
-                                             unique-kernel)
+                           (set! automaton-term (cons (cons (make-trans-key kernel gs)
-; 			(printf "~a -> ~a on ~a~n" 
+                                                            unique-kernel)
-; 				(kernel->string kernel)
+                                                      automaton-term)))
-; 				(kernel->string unique-kernel)
+                          (else
-;				(gram-sym-symbol gs))
+                           (set! automaton-non-term (cons (cons (make-trans-key kernel gs)
+                                                                unique-kernel)
+                                                          automaton-non-term))))
+                        #;(printf "~a -> ~a on ~a~n" 
+ 				(kernel->string kernel)
+ 				(kernel->string unique-kernel)
+				(gram-sym-symbol gs))
 			(if new
 			    unique-kernel
 			    #f)))
-		    (let loop ((i 0))
+		    (let loop ((gsyms grammar-symbols))
 		      (cond
-		       ((< i num-non-terms)
+                        ((null? gsyms) null)
-			(let ((items (vector-ref table i)))
+                        (else
-			  (cond
+                         (let ((items (hash-table-get table
-			   ((null? items) (loop (add1 i)))
+                                                      (gram-sym-symbol (car gsyms))
-			   (else
+                                                      (lambda () null))))
-			    (cons (list (vector-ref non-terms i) items)
+                           (cond
-				  (loop (add1 i)))))))
+                             ((null? items) (loop (cdr gsyms)))
-		       ((< i num-gram-syms)
+                             (else
-			(let ((items (vector-ref table i)))
+                              (cons (list (car gsyms) items)
-			  (cond
+                                    (loop (cdr gsyms))))))))))))))
-			   ((null? items) (loop (add1 i)))
-			   (else
-			    (cons (list (vector-ref terms (- i num-non-terms))
-					items)
-				  (loop (add1 i)))))))
-		       (else null))))))))
 			
              (starts 
               (map (lambda (init-prod) (list (make-item init-prod 0)))
@@ -341,7 +336,7 @@
                        k))
                    starts))
 	     (new-kernels (make-queue)))
-      
+
       (let loop ((old-kernels startk)
 		 (seen-kernels null))
 	(cond
@@ -350,9 +345,7 @@
 		       automaton-term
 		       automaton-non-term		       
 		       (list->vector (reverse! seen-kernels))
-		       epsilons
+		       epsilons))
-		       (vector-length terms)
-		       num-non-terms))
 	 ((null? old-kernels)
 	  (loop (deq! new-kernels) seen-kernels))
 	 (else 

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

@@ -224,29 +224,29 @@
   ;; build-table: grammar string bool -> parse-table
   (define (build-table g file suppress)
     (let* ((a (build-lr0-automaton g))
-           (term-list (send g get-terms))
+           (term-vector (list->vector (send g get-terms)))
-           (term-vector (list->vector term-list))
-           (non-term-list (send g get-non-terms))
            (end-terms (send g get-end-terms))
            (table (make-parse-table (send a get-num-states)))
-           (get-lookahead (compute-LA a g)))
+           (get-lookahead (time (compute-LA a g))))
+
+      (for-each
+       (lambda (trans-key/state)
+         (let ((from-state-index (kernel-index (trans-key-st (car trans-key/state))))
+               (gs (trans-key-gs (car trans-key/state)))
+               (to-state (cdr trans-key/state)))
+           (table-add! table from-state-index gs
+                       (cond
+                         ((non-term? gs)
+                          (make-goto (kernel-index to-state)))
+                         ((member gs end-terms)
+                          (make-accept))
+                         (else
+                          (make-shift 
+                           (kernel-index to-state)))))))
+       (send a get-transitions))
+
       (send a for-each-state
         (lambda (state)
-          (for-each
-           (lambda (gs)
-             (let ((goto (send a run-automaton state gs)))
-               (when goto
-                 (table-add! table (kernel-index state) gs
-                             (cond
-                               ((non-term? gs)
-                                (make-goto (kernel-index goto)))
-                               ((member gs end-terms)
-                                (make-accept))
-                               (else
-                                (make-shift 
-                                 (kernel-index goto))))))))
-           (append non-term-list term-list))
-          
           (for-each
            (lambda (item)
              (let ((item-prod (item-prod item)))
@@ -258,7 +258,6 @@
                                 (vector-ref term-vector term-index)
                                 (make-reduce 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)))