*** empty log message ***

original commit: 05ffe8f9eeb1eb268708f90f027afd49a0a47f72

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

@@ -6,6 +6,7 @@
   (require "lr0.ss"
 	   "grammar.ss"
 	   "array2d.ss"
+           "graph.ss"
 	   (lib "list.ss")
 	   (lib "class.ss"))
 
@@ -41,25 +42,12 @@
   (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)
+      (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))))))
-  
-  ;; 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 dot-pos start num-states)
@@ -124,40 +112,6 @@
                                                   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)
   (define (compute-lookback a g)
     (let ((num-states (send a get-num-states)))

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

@@ -171,8 +171,8 @@
     (letrec (
 	     (terms (list->vector (send grammar get-terms)))
 	     (non-terms (list->vector (send grammar get-non-terms)))
-	     (num-non-terms (vector-length non-terms))
+	     (num-non-terms (send grammar get-num-non-terms))
-	     (num-gram-syms (+ num-non-terms (vector-length terms)))
+	     (num-gram-syms (+ num-non-terms (send grammar get-num-terms)))
 	     (epsilons (make-hash-table 'equal))
 	     
 	     ;; first-non-term: non-term -> non-term list
@@ -218,7 +218,6 @@
 		      (cons (car i) (LR0-closure (cdr i))))))))))
 
 
-
 	     ;; maps trans-keys to kernels
 	     (automaton-term (make-hash-table 'equal))
              (automaton-non-term (make-hash-table 'equal))
@@ -275,7 +274,6 @@
 			      (add-item! table item))
 			    (LR0-closure (kernel-items kernel)))
 		  
-		  
 		  ;; each group is a new kernel, with the dot advanced.
 		  ;; sorts the items in a kernel so kernels can be compared
 		  ;; with equal? for using the table kernels to make sure
@@ -333,8 +331,7 @@
 				  (loop (add1 i)))))))
 		       (else null))))))))
 			
-	      
+             (start (list (make-item (send grammar get-init-prod) 0)))
-	     (start (list (make-item (send grammar get-init-prod) 0)))
 	     (startk (make-kernel start 0))
 	     (new-kernels (make-queue)))
       

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

@@ -10,10 +10,21 @@
   ;; action = (shift int)
   ;;        | (reduce int int int)
   ;;        | (accept)
-  ;;        | int
+  ;;        | int>=0
   ;;        | #f
 
-  (define-struct shift (state) (make-inspector))
+  (define (shift? x) (and (integer? x) (< x 0)))
-  (define-struct reduce (prod-num lhs-num rhs-length) (make-inspector))
+  (define (make-shift x) (- (+ x 1)))
-  (define-struct accept () (make-inspector))
+  (define (shift-state x) (- (+ x 1)))
+  (define reduce? vector?)
+  (define make-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))
+  (define (make-accept) 'accept)
+   
+  ;(define-struct shift (state) (make-inspector))
+  ;(define-struct reduce (prod-num lhs-num rhs-length) (make-inspector))
+  ;(define-struct accept () (make-inspector))
   )

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

@@ -2,7 +2,6 @@
 (module parser-builder mzscheme
   
   (require "input-file-parser.ss"
-           "parser-actions.ss"
            "grammar.ss"
            "table.ss"
            (lib "class.ss"))
@@ -55,17 +54,6 @@
                  ht)))
            (actions-code
             `(vector ,@(map prod-action (send grammar get-prods)))))
-      (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

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

@@ -216,13 +216,11 @@
   ;; buile-table: grammar * string -> action array2d
   (define (build-table g file suppress)
     (let* ((a (build-lr0-automaton g))
-           (terms (send g get-terms))
+           (num-terms (send g get-num-terms))
-           (non-terms (send g get-non-terms))
+           (num-non-terms (send g get-num-non-terms))
-           (get-term (list->vector terms))
+           (get-term (list->vector (send g get-terms)))
-           (get-non-term (list->vector non-terms))
+           (get-non-term (list->vector (send g get-non-terms)))
            (get-prod (list->vector (send g get-prods)))
-           (num-terms (vector-length get-term))
-           (num-non-terms (vector-length get-non-term))
            (end-term-indexes 
             (map
              (lambda (term)
@@ -264,7 +262,6 @@
                                              (make-shift 
                                               (kernel-index goto)))))))
                       (loop (add1 i)))))
-            
               (for-each
                (lambda (item)
                  (let ((item-prod (item-prod item)))
@@ -286,25 +283,26 @@
                                  (not (move-dot-right item)))
                                (kernel-items state))))))
       
+      
       (resolve-prec-conflicts a table get-term get-prod num-terms
-                            num-non-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)))))
       
-    (if (not (string=? file ""))
+      (resolve-conflicts a table num-terms num-non-terms suppress)
-        (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))
       
-    )
+      table))
   
+  )
 
 

collects/parser-tools/yacc.ss

@@ -5,6 +5,7 @@
                       "private-yacc/yacc-helper.ss")
   (require "private-yacc/array2d.ss"
            "private-lex/token.ss"
+           "private-yacc/parser-actions.ss"
 	   (lib "readerr.ss" "syntax"))
   
   (provide parser)
@@ -153,14 +154,6 @@
 
   (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