*** empty log message ***

original commit: 6b32165ccb7a18f2ef44c454684ea8d3df46da6b
23 years ago · 8525a6ab43
parent f00785e838
commit 8525a6ab43
5 changed files with 293 additions and 208 deletions
--- a/collects/parser-tools/private-yacc/input-file-parser.ss
+++ b/collects/parser-tools/private-yacc/input-file-parser.ss
@ -119,7 +119,9 @@
                          
           
           (list-of-terms
-            (syntax-case term-defs (tokens)
+            (syntax-case* term-defs (tokens)
+              (lambda (a b)
+                (eq? (syntax-object->datum a) (syntax-object->datum b)))
              ((tokens term-def ...)
               (andmap identifier? (syntax->list (syntax (term-def ...))))
               (remove-duplicates
@ -148,7 +150,9 @@
           ;; Get the list of terminals out of input-terms
           
           (list-of-non-terms
-            (syntax-case prods (grammar)
+            (syntax-case* prods (grammar)
+              (lambda (a b)
+                (eq? (syntax-object->datum a) (syntax-object->datum b)))
              ((grammar (non-term production ...) ...)
               (begin
                 (for-each
@ -179,7 +183,9 @@
           
           ;; Check the precedence declarations for errors and turn them into data
           (precs
-            (syntax-case prec-decls (precs)
+            (syntax-case* prec-decls (precs)
+              (lambda (a b)
+                (eq? (syntax-object->datum a) (syntax-object->datum b)))
              ((precs (type term ...) ...)
               (let ((p-terms 
                      (apply append (syntax-object->datum 
@ -286,7 +292,9 @@
 	     ;; parse-prod+action: non-term * syntax-object -> production
 	     (parse-prod+action
 	      (lambda (nt prod-so)
-                (syntax-case prod-so (prec)
+                (syntax-case* prod-so (prec)
+                  (lambda (a b)
+                    (eq? (syntax-object->datum a) (syntax-object->datum b)))
                  ((prod-rhs action)
                   (let ((p (parse-prod (syntax prod-rhs))))
                     (set! counter (add1 counter))
--- a/collects/parser-tools/private-yacc/lalr.ss
+++ b/collects/parser-tools/private-yacc/lalr.ss
@ -53,47 +53,46 @@
  ;;   lr0-automaton * grammar -> (value (trans-key -> trans-key list)
  ;;                                     (kernel * prod -> trans-key list))
  (define (compute-includes-and-lookback a g)
-    (let* ((states (lr0-states a))
-	   (non-terms (grammar-non-terms g))
-	   (num-states (vector-length states))
+    (let* ((non-terms (grammar-non-terms g))
+	   (num-states (vector-length (lr0-states a)))
 	   (num-non-terms (length non-terms))
 	   (includes (make-array2d num-states num-non-terms null))
 	   (lookback (make-array2d num-states
 				   (grammar-num-prods g)
 				   null)))
-      (let loop ((state 0))
-	(if (< state num-states)
-	    (begin
-	      (for-each
-	       (lambda (non-term)
-		 (for-each
-		  (lambda (prod)
-		    (let loop ((i (make-item prod 0))
-			       (p (vector-ref states state)))
-		      (if (and p i)
-			  (begin
-			    (if (and (non-term? (sym-at-dot i))
-				     (nullable-after-dot? (move-dot-right i)
-							  g))
-				(array2d-add! includes
-					      (kernel-index p)
-					      (gram-sym-index 
-					       (sym-at-dot i))
-					      (make-trans-key
-					       (vector-ref states state)
-					       non-term)))
-			    (if (not (move-dot-right i))
-				(array2d-add! lookback
-					      (kernel-index p)
-					      (prod-index prod)
-					      (make-trans-key
-					       (vector-ref states state)
-					       non-term)))
-			    (loop (move-dot-right i)
-				  (run-automaton p (sym-at-dot i) a))))))
-		  (get-nt-prods g non-term)))
-	       non-terms)
-	      (loop (add1 state)))))
+
+      (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)
+                     (begin
+                       (if (and (non-term? (sym-at-dot i))
+                                (nullable-after-dot? (move-dot-right i)
+                                                     g))
+                           (array2d-add! includes
+                                         (kernel-index p)
+                                         (gram-sym-index 
+                                          (sym-at-dot i))
+                                         (make-trans-key
+                                          state
+                                          non-term)))
+                       (if (not (move-dot-right i))
+                           (array2d-add! lookback
+                                         (kernel-index p)
+                                         (prod-index prod)
+                                         (make-trans-key
+                                          state
+                                          non-term)))
+                       (loop (move-dot-right i)
+                             (run-automaton p (sym-at-dot i) a))))))
+             (get-nt-prods g non-term)))
+          non-terms))
+       a)
      (values (lambda (tk)
 		(array2d-ref includes 
 			     (kernel-index (trans-key-st tk))
@ -118,9 +117,79 @@
  (define (compute-LA a g)
    (let-values (((includes lookback) (compute-includes-and-lookback a g)))
      (let ((follow (compute-follow a g includes)))
+        (print-lookback lookback a g)
+        (print-follow follow a g)
 	(lambda (k p)
 	  (let* ((l (lookback k p))
 		 (f (map follow l)))
 	    (apply append f))))))

+
+  (define (print-DR dr a g)
+    (print-input-st-sym dr "DR" a g print-output-terms))
+  (define (print-Read Read a g)
+    (print-input-st-sym Read "Read" a g print-output-terms))
+  (define (print-includes i a g)
+    (print-input-st-sym i "includes" a g print-output-st-nt))
+  (define (print-lookback l a g)
+    (print-input-st-prod l "lookback" a g print-output-st-nt))
+  (define (print-follow f a g)
+    (print-input-st-sym f "follow" a g print-output-terms))
+  (define (print-LA l a g)
+    (print-input-st-prod l "LA" a g print-output-terms))
+
+  (define (print-input-st-sym f name a g print-output)
+    (printf "~a:~n" name)
+    (for-each-state
+     (lambda (state)
+       (for-each
+        (lambda (non-term)
+          (let ((res (f (make-trans-key state non-term))))
+            (if (not (null? res))
+                (printf "~a(~a, ~a) = ~a~n"
+                        name
+                        state
+                        (gram-sym-symbol non-term)
+                        (print-output res)))))
+        (grammar-non-terms g)))
+     a)
+    (newline))
+
+  (define (print-input-st-prod f name a g print-output)
+    (printf "~a:~n" name)
+    (for-each-state
+     (lambda (state)
+       (for-each
+        (lambda (non-term)
+          (for-each
+           (lambda (prod)
+             (let ((res (f state prod)))
+               (if (not (null? res))
+                   (printf "~a(~a, ~a) = ~a~n"
+                           name
+                           (kernel-index state)
+                           (prod-index prod)
+                           (print-output res)))))
+           (get-nt-prods g non-term)))
+        (grammar-non-terms g)))
+     a))
+  
+  (define (print-output-terms r)
+    (map 
+     (lambda (p)
+       (gram-sym-symbol p))
+     r))
+  
+  (define (print-output-st-nt r)
+    (map
+     (lambda (p)
+       (list
+	(kernel-index (trans-key-st p))
+	(gram-sym-symbol (trans-key-gs p))))
+     r))
+
+
 )
+
+
+
--- a/collects/parser-tools/private-yacc/lr0.ss
+++ b/collects/parser-tools/private-yacc/lr0.ss
@ -8,7 +8,7 @@
 	   (lib "list.ss"))
  
  (provide union build-lr0-automaton run-automaton (struct trans-key (st gs))
-	   lr0-transitions lr0-states kernel-items kernel-index)
+	   lr0-transitions lr0-states kernel-items kernel-index for-each-state)

  (define (union comp<?)
    (letrec ((union
@ -35,6 +35,18 @@
  (define-struct trans-key (st gs) (make-inspector))
  (define-struct lr0 (transitions states) (make-inspector))

+  ;; A macro to allow easy iteration over the states in an automaton
+  (define-syntax for-each-state
+    (syntax-rules ()
+      ((_ function automaton)
+       (let* ((states (lr0-states automaton))
+              (num-states (vector-length states)))
+         (let loop ((i 0))
+           (if (< i num-states)
+               (begin
+                 (function (vector-ref states i))
+                 (loop (add1 i)))))))))
+  
  ;; The kernels in the automaton are represented cannonically.
  ;; That is (equal? a b) <=> (eq? a b)
  (define (kernel->string k)
--- a/collects/parser-tools/private-yacc/table.ss
+++ b/collects/parser-tools/private-yacc/table.ss
@ -39,11 +39,9 @@
  ;;   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 prods port)
+  (define (display-parser a table terms non-terms 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
@ -54,62 +52,62 @@
                  (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
-	      (fprintf port "State ~a~n" i)
-	      (for-each (lambda (item)
-			  (fprintf port "\t~a~n" (item->string item)))
-			(kernel-items (vector-ref states i)))
-	      (newline port)
-	      (let loop ((j 0))
-		(if (< j num-terms)
-		    (begin
-		      (let ((act (array2d-ref 
-				  table 
-				  i
-				  (+ j num-non-terms))))
-			(cond
-			 ((list? act) 
-			  (fprintf port "begin conflict:~n")
-			  (if (> (count reduce? act) 1)
-			      (set! RR-conflicts (add1 RR-conflicts)))
-			  (if (> (count shift? act) 0)
-			      (set! SR-conflicts (add1 SR-conflicts)))
-			  (map (lambda (x) 
-				 (print-entry 
-				  (gram-sym-symbol (vector-ref terms j))
-				  x
-				  port))
-			       act)
-			  (fprintf port "end conflict~n"))
-			 (act (print-entry
-			       (gram-sym-symbol (vector-ref terms j))
-			       act
-			       port))))
-		      (loop (add1 j)))))
+      (for-each-state
+       (lambda (state)
+         (fprintf port "State ~a~n" (kernel-index state))
+         (for-each (lambda (item)
+                     (fprintf port "\t~a~n" (item->string item)))
+                   (kernel-items state))
+         (newline port)
+         (let loop ((j 0))
+           (if (< j num-terms)
+               (begin
+                 (let ((act (array2d-ref 
+                             table 
+                             (kernel-index state)
+                             (+ j num-non-terms))))
+                   (cond
+                     ((list? act) 
+                      (fprintf port "begin conflict:~n")
+                      (if (> (count reduce? act) 1)
+                          (set! RR-conflicts (add1 RR-conflicts)))
+                      (if (> (count shift? act) 0)
+                          (set! SR-conflicts (add1 SR-conflicts)))
+                      (map (lambda (x) 
+                             (print-entry 
+                              (gram-sym-symbol (vector-ref terms j))
+                              x
+                              port))
+                           act)
+                      (fprintf port "end conflict~n"))
+                     (act (print-entry
+                           (gram-sym-symbol (vector-ref terms j))
+                           act
+                           port))))
+                 (loop (add1 j)))))
+         
+         (newline port)
         
-	      (newline port)
+         (let loop ((j 0))
+           (if (< j num-non-terms)
+               (begin
+                 (let ((s (array2d-ref table (kernel-index state) j)))
+                   (if s
+                       (print-entry
+                        (gram-sym-symbol (vector-ref non-terms j))
+                        s
+                        port)))
+                 (loop (add1 j)))))
         
-	      (let loop ((j 0))
-		(if (< j num-non-terms)
-		    (begin
-		      (let ((s (array2d-ref table i j)))
-			(if s
-			    (print-entry
-			     (gram-sym-symbol (vector-ref non-terms j))
-			     s
-			     port)))
-		      (loop (add1 j)))))
+         (newline port))
+       a)

-	      (newline port)
-	      (loop (add1 i)))))
      (if (> SR-conflicts 0)
 	  (fprintf port "~a shift/reduce conflicts~n" SR-conflicts))
      (if (> RR-conflicts 0)
 	  (fprintf port "~a reduce/reduce conflicts~n" RR-conflicts))))

-  (define (resolve-conflicts table num-states num-terms num-non-terms)
+  (define (resolve-conflicts a table num-terms num-non-terms)
    (letrec ((SR-conflicts 0)
 	     (RR-conflicts 0)
 	     (get-action
@ -130,19 +128,19 @@
 		      (loop (car rest) (cdr rest)))
 		     (else (loop current-guess (cdr rest))))))
 		 (else entry)))))
-      (let loop ((state 0))
-	(if (< state num-states)
-	    (begin
-	      (let loop ((term 0))
-		(if (< term num-terms)
-		    (begin
-		      (array2d-set! table state (+ num-non-terms term)
-				    (get-action
-				     (array2d-ref table 
-						  state 
-						  (+ num-non-terms term))))
-		      (loop (add1 term)))))
-	      (loop (add1 state)))))
+      (for-each-state
+       (lambda (state)
+         (let loop ((term 0))
+           (if (< term num-terms)
+               (begin
+                 (array2d-set! table (kernel-index state) (+ num-non-terms term)
+                               (get-action
+                                (array2d-ref table 
+                                             (kernel-index state) 
+                                             (+ num-non-terms term))))
+                 (loop (add1 term))))))
+       a)
+
      (if (> SR-conflicts 0)
 	  (fprintf (current-error-port) 
 		   "~a shift/reduce conflicts~n" 
@ -154,53 +152,52 @@
    


-  (define (resolve-prec-conflicts table get-term get-prod
-				  num-states num-terms num-non-terms)
-    (let loop ((state 0))
-      (if (< state num-states)
-	  (begin
-	    (let loop ((term 0))
-	      (if (< term num-terms)
-		  (begin
-		    (let ((action (array2d-ref table 
-					       state 
-					       (+ num-non-terms term))))
-		      (if (and (list? action)
-			       (= 2 (length action))
-			       (or (shift? (car action))
-				   (shift? (cadr action))))
-			  (let* ((shift (if (shift? (car action))
-					    (car action)
-					    (cadr action)))
-				 (reduce (if (shift? (car action))
-					     (cadr action)
-					     (car action)))
-				 (s-prec (term-prec
-					  (vector-ref get-term
-						      term)))
-				 (r-prec (prod-prec
-					  (vector-ref 
-					   get-prod
-					   (reduce-prod-num reduce)))))
-			    (if (and s-prec r-prec)
-				(array2d-set!
-				 table
-				 state
-				 (+ num-non-terms term)
-				 (cond
-				  ((< (prec-num s-prec)
-				      (prec-num r-prec))
-				   reduce)
-				  ((> (prec-num s-prec)
-				      (prec-num r-prec))
-				   shift)
-				  ((eq? 'left (prec-assoc s-prec))
-				   reduce)
-				  ((eq? 'right (prec-assoc s-prec))
-				   shift)
-				  (else #f)))))))
-		    (loop (add1 term)))))
-	    (loop (add1 state))))))
+  (define (resolve-prec-conflicts a table get-term get-prod
+				  num-terms num-non-terms)
+    (for-each-state
+     (lambda (state)
+       (let loop ((term 0))
+         (if (< term num-terms)
+             (begin
+               (let ((action (array2d-ref table 
+                                          (kernel-index state)
+                                          (+ num-non-terms term))))
+                 (if (and (list? action)
+                          (= 2 (length action))
+                          (or (shift? (car action))
+                              (shift? (cadr action))))
+                     (let* ((shift (if (shift? (car action))
+                                       (car action)
+                                       (cadr action)))
+                            (reduce (if (shift? (car action))
+                                        (cadr action)
+                                        (car action)))
+                            (s-prec (term-prec
+                                     (vector-ref get-term
+                                                 term)))
+                            (r-prec (prod-prec
+                                     (vector-ref 
+                                      get-prod
+                                      (reduce-prod-num reduce)))))
+                       (if (and s-prec r-prec)
+                           (array2d-set!
+                            table
+                            (kernel-index state)
+                            (+ num-non-terms term)
+                            (cond
+                              ((< (prec-num s-prec)
+                                  (prec-num r-prec))
+                               reduce)
+                              ((> (prec-num s-prec)
+                                  (prec-num r-prec))
+                               shift)
+                              ((eq? 'left (prec-assoc s-prec))
+                               reduce)
+                              ((eq? 'right (prec-assoc s-prec))
+                               shift)
+                              (else #f)))))))
+               (loop (add1 term))))))
+     a))

  ;; 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)
@ -234,56 +231,53 @@
 			   (array2d-set! v i1 i2 (list a old))))))))
 	   (get-lookahead (compute-LA a g)))

-      (let loop ((state 0))
-	(if (< state num-states)
-	    (begin
-	      (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
-			      (run-automaton (vector-ref get-state state)
-					     s
-					     a)))
-			(if goto
-			    (array2d-set! table 
-					  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)))))
-	      (let ((items
-		     (filter (lambda (item)
-			       (not (move-dot-right item)))
-			     (kernel-items
-			      (vector-ref get-state state)))))
-		(for-each
-		 (lambda (item)
-		   (for-each 
-		    (lambda (t)
-		      (array2d-add! table 
-				    state
-				    (+ num-non-terms (gram-sym-index t))
-				    (cond
-				     ((not (start-item? item))
-				      (make-reduce
-				       (item-prod-index item)
-                                       (gram-sym-index (prod-lhs (item-prod item)))
-                                       (vector-length (prod-rhs (item-prod item))))))))
-		    (get-lookahead (vector-ref get-state state)
-				   (item-prod item))))
-		 items))	      
-	      (loop (add1 state)))))
-      (resolve-prec-conflicts table get-term get-prod num-states num-terms
-			      num-non-terms)
+      (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
+                         (run-automaton (vector-ref get-state (kernel-index state))
+                                        s
+                                        a)))
+                   (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)
+            (for-each 
+             (lambda (t)
+               (array2d-add! table 
+                             (kernel-index state)
+                             (+ num-non-terms (gram-sym-index t))
+                             (cond
+                               ((not (start-item? item))
+                                (make-reduce
+                                 (item-prod-index item)
+                                 (gram-sym-index (prod-lhs (item-prod item)))
+                                 (vector-length (prod-rhs (item-prod item))))))))
+             (get-lookahead (vector-ref get-state (kernel-index state))
+                            (item-prod item))))
+          (filter (lambda (item)
+                    (not (move-dot-right item)))
+                  (kernel-items
+                   (vector-ref get-state (kernel-index state))))))
+       a)
+      (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)
@ -294,9 +288,9 @@
 			      (exn:i/o:filesystem-detail e))))]
 	    (call-with-output-file file
 	      (lambda (port)
-		(display-parser table get-term get-non-term get-state (grammar-prods g)
+		(display-parser a table get-term get-non-term (grammar-prods g)
                                port)))))
-      (resolve-conflicts table num-states num-terms num-non-terms)
+      (resolve-conflicts a table num-terms num-non-terms)
      table))
 )

--- a/collects/parser-tools/yacc.ss
+++ b/collects/parser-tools/yacc.ss
@ -23,7 +23,9 @@
               (grammar #f))
           (for-each
            (lambda (arg)
-              (syntax-case arg (debug error tokens start end precs grammar)
+              (syntax-case* arg (debug error tokens start end precs grammar)
+                (lambda (a b)
+                  (eq? (syntax-object->datum a) (syntax-object->datum b)))
                ((debug filename)
                 (cond
                   ((not (string? (syntax-object->datum (syntax filename))))