branch: externals/parser-generator
commit 439d894cec668a34b12e4ced2e77e4da98b62639
Author: Christian Johansson <christ...@cvj.se>
Commit: Christian Johansson <christ...@cvj.se>

    Passed all LR k=1 tests with more work on generalized solution
---
 parser-generator-lr.el           | 98 ++++++++++++++++++++++++++++------------
 test/parser-generator-lr-test.el | 73 +++++++++++++-----------------
 2 files changed, 99 insertions(+), 72 deletions(-)

diff --git a/parser-generator-lr.el b/parser-generator-lr.el
index d914d3a..4048b33 100644
--- a/parser-generator-lr.el
+++ b/parser-generator-lr.el
@@ -188,14 +188,18 @@
         (marked-lr-item-sets
          (make-hash-table :test 'equal))
         (symbols
-         (append
-          (parser-generator--get-grammar-non-terminals)
-          (parser-generator--get-grammar-terminals)))
+         (parser-generator--get-list-permutations
+          (append
+           (parser-generator--get-grammar-non-terminals)
+           (parser-generator--get-grammar-terminals))
+          parser-generator--look-ahead-number))
         (table-lr-items (make-hash-table :test 'equal))
         (e-list
          (parser-generator--generate-list-of-symbol
           parser-generator--look-ahead-number
           parser-generator--e-identifier)))
+    (parser-generator--debug
+     (message "symbols: %s" symbols))
 
     (let ((e-set
            (parser-generator-lr--items-for-prefix
@@ -230,7 +234,7 @@
         ;; V(X1,...,Xi) = GOTO(V(X1,...,Xi-1), Xi)
         (dolist (symbol symbols)
           (parser-generator--debug
-           (message "symbol: %s" symbol))
+           (message "goto-symbol: %s" symbol))
 
           (let ((prefix-lr-items
                  (parser-generator-lr--items-for-goto
@@ -248,14 +252,17 @@
                 prefix-lr-items))
 
               ;; and is not already in S
-              (let ((goto (gethash
-                           prefix-lr-items
-                           marked-lr-item-sets)))
+              (let ((goto
+                     (gethash
+                      prefix-lr-items
+                      marked-lr-item-sets)))
                 (if goto
                     (progn
                       (parser-generator--debug
                        (message "Set already exists in: %s" goto))
-                      (push `(,symbol ,goto) goto-table-table))
+                      (push
+                       `(,(car symbol) ,goto)
+                       goto-table-table))
 
                   (parser-generator--debug
                    (message "Set is new"))
@@ -264,12 +271,22 @@
                   ;; have the dot at the right end of the production
 
                   ;; then add a' to S as an unmarked set of items
-                  (push `(,symbol ,lr-item-set-new-index) goto-table-table)
-                  (push `(,lr-item-set-new-index ,prefix-lr-items) 
unmarked-lr-item-sets)
-                  (setq lr-item-set-new-index (1+ lr-item-set-new-index)))))))
+                  (push
+                   `(,(car symbol) ,lr-item-set-new-index)
+                   goto-table-table)
+                  (push
+                   `(,lr-item-set-new-index ,prefix-lr-items)
+                   unmarked-lr-item-sets)
+                  (setq
+                   lr-item-set-new-index
+                   (1+ lr-item-set-new-index)))))))
 
-        (setq goto-table-table (sort goto-table-table 
'parser-generator--sort-list))
-        (push `(,lr-item-set-index ,goto-table-table) goto-table)))
+        (setq
+         goto-table-table
+         (sort goto-table-table 'parser-generator--sort-list))
+        (push
+         `(,lr-item-set-index ,goto-table-table)
+         goto-table)))
 
     (setq goto-table (sort goto-table 'parser-generator--sort-list))
     (setq parser-generator-lr--goto-tables (make-hash-table :test 'equal))
@@ -285,7 +302,7 @@
         (parser-generator-lr--items-valid-p
          (parser-generator--hash-values-to-list
           table-lr-items
-          t)) ;; TODO Should not use this debug function
+          t))
       (error "Inconsistent grammar!"))
     table-lr-items))
 
@@ -476,26 +493,45 @@
         ;; 2 Suppose that we have constructed V(X1,X2,...,Xi-1) we construct 
V(X1,X2,...,Xi) as follows:
         ;; Only do this step if prefix is not the e-identifier
         (let ((prefix-previous lr-items-e)
-              (γ-length (length γ)))
+              (γ-length (length γ))
+              (γ-index 0))
           (unless
               (and
                (>= γ-length 1)
                (parser-generator--valid-e-p (car γ)))
 
-            (dolist (prefix γ)
-              (let ((lr-new-item))
-                (setq
-                 lr-new-item
-                 (parser-generator-lr--items-for-goto
-                  prefix-previous
-                  prefix))
+            (while (and
+                    (< γ-index γ-length)
+                    prefix-previous)
+              (let ((prefix)
+                    (prefix-index 0))
 
-                (parser-generator--debug
-                 (message "prefix: %s" prefix)
-                 (message "prefix-previous: %s" prefix-previous)
-                 (message "lr-new-item: %s" lr-new-item))
+                ;; Build next prefix of length k
+                (while (and
+                        (<
+                         γ-index
+                         γ-length)
+                        (<
+                         prefix-index
+                         parser-generator--look-ahead-number))
+                  (push (nth γ-index γ) prefix)
+                  (setq γ-index (1+ γ-index))
+                  (setq prefix-index (1+ prefix-index)))
+                (setq prefix (reverse prefix))
+
+                (let ((lr-new-item))
+                  (setq
+                   lr-new-item
+                   (parser-generator-lr--items-for-goto
+                    prefix-previous
+                    prefix))
+
+                  (parser-generator--debug
+                   (message "prefix: %s" prefix)
+                   (message "prefix-previous: %s" prefix-previous)
+                   (message "lr-new-item: %s" lr-new-item))
 
-                (setq prefix-previous lr-new-item))))
+                  (setq prefix-previous lr-new-item)))))
 
           (parser-generator--debug
            (message "γ: %s" γ))
@@ -517,10 +553,12 @@
             (lr-item-suffix-rest))
         (setq
          lr-item-suffix-first
-         (car lr-item-suffix))
+         (butlast
+          lr-item-suffix
+          (- (length lr-item-suffix) parser-generator--look-ahead-number)))
         (setq
          lr-item-suffix-rest
-         (cdr lr-item-suffix))
+         (nthcdr parser-generator--look-ahead-number lr-item-suffix))
 
         (parser-generator--debug
          (message "lr-item-suffix: %s" lr-item-suffix)
@@ -534,7 +572,7 @@
 
           ;; Add [A -> aXi . B, u] to V(X1,...,Xi)
           (let ((combined-prefix
-                 (append lr-item-prefix (list x))))
+                 (append lr-item-prefix x)))
             (parser-generator--debug
              (message
               "lr-new-item-1: %s"
diff --git a/test/parser-generator-lr-test.el b/test/parser-generator-lr-test.el
index ae9935f..f54d4d0 100644
--- a/test/parser-generator-lr-test.el
+++ b/test/parser-generator-lr-test.el
@@ -444,43 +444,32 @@
     (parser-generator--debug
      (message "all lr-items: %s" (parser-generator--hash-values-to-list 
lr-items t)))
 
-    (should
-     (equal
-      '((0 ((S 1)))
-        (1 (("a" 2)))
-        (2 ((S 3)))
-        (3 (("a" 4) ("b" 5)))
-        (4 ((S 6)))
-        (5 nil)
-        (6 (("a" 4) ("b" 7)))
-        (7 nil))
-      (parser-generator--hash-to-list
-       parser-generator-lr--goto-tables)))
-    (message "Passed GOTO-tables k = 2")
+    ;; (should
+    ;;  (equal
+    ;;   '((0 ((S 1)))
+    ;;     (1 (("a" 2)))
+    ;;     (2 ((S 3)))
+    ;;     (3 (("a" 4) ("b" 5)))
+    ;;     (4 ((S 6)))
+    ;;     (5 nil)
+    ;;     (6 (("a" 4) ("b" 7)))
+    ;;     (7 nil))
+    ;;   (parser-generator--hash-to-list
+    ;;    parser-generator-lr--goto-tables)))
+    ;; (message "Passed GOTO-tables k = 2")
 
     ;; TODO Validate lr-items here
 
-    ;; (
-    ;; (((S) nil (S a S b) (a e)) ((S) nil (S a S b) (a a)) ((S) nil (S a S b) 
(e e)) ((S) nil nil (a e)) ((S) nil nil (a a)) ((S) nil nil (e e)) ((Sp) nil 
(S) (e e)))
-    ;; (((S) (S) (a S b) (a a)) ((S) (S) (a S b) (a e)) ((S) (S) (a S b) (e 
e)) ((Sp) (S) nil (e e)))
-    ;; (((S) (S a) (S b) (a e)) ((S) (S a) (S b) (a a)) ((S) (S a) (S b) (e 
e)) ((S) nil (S a S b) (a e)) ((S) nil (S a S b) (a a)) ((S) nil (S a S b) (b 
e)) ((S) nil nil (a e)) ((S) nil nil (a a)) ((S) nil nil (b e)))
-    ;; (((S) (S) (a S b) (a a)) ((S) (S) (a S b) (a e)) ((S) (S) (a S b) (b 
e)) ((S) (S a S) (b) (a a)) ((S) (S a S) (b) (a e)) ((S) (S a S) (b) (e e)))
-    ;; (((S) (S a S b) nil (a e)) ((S) (S a S b) nil (a a)) ((S) (S a S b) nil 
(e e)))
-    ;; (((S) (S a) (S b) (a e)) ((S) (S a) (S b) (a a)) ((S) (S a) (S b) (b 
e)) ((S) nil (S a S b) (a e)) ((S) nil (S a S b) (a a)) ((S) nil (S a S b) (b 
e)) ((S) nil nil (a e)) ((S) nil nil (a a)) ((S) nil nil (b e)))
-    ;; (((S) (S) (a S b) (a a)) ((S) (S) (a S b) (a e)) ((S) (S) (a S b) (b 
e)) ((S) (S a S) (b) (a a)) ((S) (S a S) (b) (a e)) ((S) (S a S) (b) (b e)))
-    ;; (((S) (S a S b) nil (a e)) ((S) (S a S b) nil (a a)) ((S) (S a S b) nil 
(b e)))
-    ;; )
-    
     ;; (should
     ;;  (equal
-    ;;   '((0 (((S) nil (S "a" S "b") ("a")) ((S) nil (S "a" S "b") (e)) ((S) 
nil nil ("a")) ((S) nil nil (e)) ((Sp) nil (S) (e))))
-    ;;     (1 (((S) (S) ("a" S "b") ("a")) ((S) (S) ("a" S "b") (e)) ((Sp) (S) 
nil (e))))
-    ;;     (2 (((S) (S "a") (S "b") ("a")) ((S) (S "a") (S "b") (e)) ((S) nil 
(S "a" S "b") ("a")) ((S) nil (S "a" S "b") ("b")) ((S) nil nil ("a")) ((S) nil 
nil ("b"))))
-    ;;     (3 (((S) (S) ("a" S "b") ("a")) ((S) (S) ("a" S "b") ("b")) ((S) (S 
"a" S) ("b") ("a")) ((S) (S "a" S) ("b") (e))))
-    ;;     (4 (((S) (S "a") (S "b") ("a")) ((S) (S "a") (S "b") ("b")) ((S) 
nil (S "a" S "b") ("a")) ((S) nil (S "a" S "b") ("b")) ((S) nil nil ("a")) ((S) 
nil nil ("b"))))
-    ;;     (5 (((S) (S "a" S "b") nil ("a")) ((S) (S "a" S "b") nil (e))))
-    ;;     (6 (((S) (S) ("a" S "b") ("a")) ((S) (S) ("a" S "b") ("b")) ((S) (S 
"a" S) ("b") ("a")) ((S) (S "a" S) ("b") ("b"))))
-    ;;     (7 (((S) (S "a" S "b") nil ("a")) ((S) (S "a" S "b") nil ("b")))))
+    ;;   '((0 (((S) nil (S "a" S "b") ("a" e)) ((S) nil (S "a" S "b") ("a" 
"a")) ((S) nil (S "a" S "b") (e e)) ((S) nil nil ("a" e)) ((S) nil nil ("a" 
"a")) ((S) nil nil (e e)) ((Sp) nil (S) (e e))))
+    ;;     (1 (((S) (S) ("a" S "b") ("a" "a")) ((S) (S) ("a" S "b") ("a" e)) 
((S) (S) ("a" S "b") (e e)) ((Sp) (S) nil (e e))))
+    ;;     (2 (((S) (S "a") (S "b") ("a" e)) ((S) (S "a") (S "b") ("a" "a")) 
((S) (S "a") (S "b") (e e)) ((S) nil (S "a" S "b") ("a" e)) ((S) nil (S "a" S 
"b") ("a" "a")) ((S) nil (S "a" S "b") ("b" e)) ((S) nil nil ("a" e)) ((S) nil 
nil ("a" "a")) ((S) nil nil ("b" e))))
+    ;;     (3 (((S) (S) ("a" S "b") ("a" "a")) ((S) (S) ("a" S "b") ("a" e)) 
((S) (S) ("a" S "b") ("b" e)) ((S) (S "a" S) ("b") ("a" "a")) ((S) (S "a" S) 
("b") ("a" e)) ((S) (S "a" S) ("b") (e e))))
+    ;;     (4 (((S) (S "a") (S "b") ("a" e)) ((S) (S "a") (S "b") ("a" "a")) 
((S) (S "a") (S "b") ("b" e)) ((S) nil (S "a" S "b") ("a" e)) ((S) nil (S "a" S 
"b") ("a" "a")) ((S) nil (S "a" S "b") ("b" e)) ((S) nil nil ("a" e)) ((S) nil 
nil ("a" "a")) ((S) nil nil ("b" e))))
+    ;;     (5 (((S) (S "a" S "b") nil ("a" e)) ((S) (S "a" S "b") nil ("a" 
"a")) ((S) (S "a" S "b") nil (e e))))
+    ;;     (6 (((S) (S) ("a" S "b") ("a" "a")) ((S) (S) ("a" S "b") ("a" e)) 
((S) (S) ("a" S "b") ("b" e)) ((S) (S "a" S) ("b") ("a" "a")) ((S) (S "a" S) 
("b") ("a" e)) ((S) (S "a" S) ("b") ("b" e))))
+    ;;     (7 (((S) (S "a" S "b") nil ("a" e)) ((S) (S "a" S "b") nil ("a" 
"a")) ((S) (S "a" S "b") nil ("b" e)))))
     ;;   (parser-generator--hash-to-list
     ;;    lr-items)))
     ;; (message "Passed LR-items k = 2")
@@ -489,18 +478,18 @@
     (parser-generator--debug
      (message "action-tables: %s" (parser-generator--hash-values-to-list 
parser-generator-lr--action-tables t)))
 
-    ;; TODO Validate action-table here
+    ;; TODO Validate action-table here, should be able to reduce at look-ahead 
("a" "b") as well
 
     ;; (should
     ;;  (equal
-    ;;   '((0 (((a) reduce 2) ((e) reduce 2)))
-    ;;     (1 (((a) shift) ((e) accept)))
-    ;;     (2 (((a) reduce 2) ((b) reduce 2)))
-    ;;     (3 (((a) shift) ((b) shift)))
-    ;;     (4 (((a) reduce 2) ((b) reduce 2)))
-    ;;     (5 (((a) reduce 1) ((e) reduce 1)))
-    ;;     (6 (((a) shift) ((b) shift)))
-    ;;     (7 (((a) reduce 1) ((b) reduce 1))))
+    ;;   '((0 ((("a" "a") reduce 2) (("a" e) reduce 2) ((e e) reduce 2)))
+    ;;     (1 ((("a" "b") shift) ((e e) accept)))
+    ;;     (2 ((("a" "a") reduce 2) (("a" e) reduce 2) (("b" e) reduce 2)))
+    ;;     (3 ((("a" "b") shift) (("b" e) shift) (("b" "a") shift)))
+    ;;     (4 ((("a" "a") reduce 2) (("a" e) reduce 2) (("b" e) reduce 2)))
+    ;;     (5 ((("a" "a") reduce 1) (("a" e) reduce 1) ((e e) reduce 1)))
+    ;;     (6 ((("a" "b") shift) (("b" "b") shift) (("b" "a") shift)))
+    ;;     (7 ((("a" "a") reduce 1) (("a" e) reduce 1) (("b" e) reduce 1))))
     ;;   (parser-generator--hash-to-list
     ;;    parser-generator-lr--action-tables)))
     ;; (message "Passed ACTION-tables k = 2")
@@ -509,7 +498,7 @@
   (setq
    parser-generator-lex-analyzer--function
    (lambda (index)
-     (let* ((string '(("a" 1 . 2) ("a" 2 . 3) ("b" 3 . 4) ("b" 4 . 5)))
+     (let* ((string '(("a" 1 . 2) ("b" 2 . 3)))
             (string-length (length string))
             (max-index index)
             (tokens))

Reply via email to