[elpa] externals/parser-generator ccaf4b5 080/434: More stuff

[ELPA Syncer]

branch: externals/parser-generator
commit ccaf4b58e98153642683a59b8c73976de261688d
Author: Christian Johansson <christian@cvj.se>
Commit: Christian Johansson <christian@cvj.se>

    More stuff
---
 parser.el           | 205 ++++++++++++++++++++++++----------------------------
 test/parser-test.el |  18 +----
 2 files changed, 96 insertions(+), 127 deletions(-)

diff --git a/parser.el b/parser.el
index e13a305..7717d9a 100644
--- a/parser.el
+++ b/parser.el
@@ -652,81 +652,50 @@
       (setq follow-set (parser--distinct follow-set)))
     follow-set))
 
-;; TODO Don't check for distincts prefixes but LR-items
 ;; Algorithm 5.9, p. 389
 (defun parser--lr-items-for-grammar ()
   "Calculate set of valid LR(k) items for grammar."
-  (let ((prefixes)
-        (marked-prefixes (make-hash-table :test 'equal))
-        (lr-items)
+  (let ((lr-items)
+        (unmarked-lr-items)
+        (marked-lr-items (make-hash-table :test 'equal))
         (symbols (append (parser--get-grammar-non-terminals) 
(parser--get-grammar-terminals))))
 
     (let ((e-set (parser--lr-items-for-prefix parser--e-identifier)))
       ;;(1) Place V(e) in S. The set V(e) is initially unmarked.
-      (setq lr-items (append lr-items e-set))
-      (push `(,parser--e-identifier) prefixes))
+      (setq unmarked-lr-items (append unmarked-lr-items e-set)))
 
+    ;; (2) If a set of items a in S is unmarked
     ;; (3) Repeat step (2) until all sets of items in S are marked.
-    (let ((prefix)
-          (i-left 100))
+    (let ((lr-item))
+      (while unmarked-lr-items
 
-      ;; (2) If a set of items a in S is unmarked
-      (while (and
-              prefixes
-              (> i-left 0))
-        (setq i-left (1- i-left))
-
-        ;; (2) Mark a by computing for each X in N u E, GOTO (a, X). 
(Algorithm 5.8 can be used here.)
-        (setq prefix (pop prefixes))
-
-        ;; e-identifier is converted to nil prefix
-        (when (and
-               (= (length prefix) 1)
-               (parser--valid-e-p (car prefix)))
-          (setq prefix nil))
+        ;; (2) Mark a
+        (setq lr-item (pop unmarked-lr-items))
+        (puthash lr-item t marked-lr-items)
+        (setq lr-items (append lr-items lr-item))
 
-        ;; (message "prefix: %s" prefix)
-
-        (puthash prefix t marked-prefixes)
+        (message "lr-item: %s" lr-item)
 
+        ;; (2) By computing for each X in N u E, GOTO (a, X). (Algorithm 5.8 
can be used here.)
         ;; V(X1,...,Xi) = GOTO(V(X1,...,Xi-1), Xi)
         (dolist (symbol symbols)
-          (let ((alternative-prefix (append prefix (list symbol))))
-            ;; (message "alternative-prefix: %s" alternative-prefix)
+          (message "symbol: %s" symbol)
 
-            ;; and is not already in S
-            (unless (gethash alternative-prefix marked-prefixes)
-              (let ((prefix-lr-items (parser--lr-items-for-prefix 
alternative-prefix)))
+          (let ((prefix-lr-items (parser--lr-items-for-goto (list lr-item) 
symbol)))
 
-                (message "V%s = %s" alternative-prefix prefix-lr-items)
+            (message "GOTO(%s, %s) = %s" lr-item symbol prefix-lr-items)
+            ;; If a' = GOTO(a, X) is nonempty
+            (when prefix-lr-items
+              (dolist (prefix-lr-item prefix-lr-items)
 
-                
-                (when prefix-lr-items
+                ;; and is not already in S
+                (unless (gethash prefix-lr-item marked-lr-items)
 
                   ;; Note that GOTO(a, X) will always be empty if all items in 
a
                   ;; have the dot at the right end of the production
 
-                  (let ((dot-at-right-end t)
-                        (production-i 0)
-                        (production-length (length prefix-lr-items)))
-                    (while (and
-                            (< production-i production-length)
-                            dot-at-right-end)
-                      (let ((production-item (nth production-i 
prefix-lr-items)))
-
-                        ;; When suffix is not nil dot is at the right end
-                        (when (nth 2 production-item)
-                          (setq dot-at-right-end nil)))
-
-                      (setq production-i (1+ production-i)))
-
-                    (unless dot-at-right-end
-                      ;; If a' = GOTO(a, X) is nonempty
-                      (message "viable-prefix: %s" alternative-prefix)
-
-                      ;; then add a' to S as an unmarked set of items
-                      (push alternative-prefix prefixes)
-                      (setq lr-items (append lr-items 
prefix-lr-items)))))))))))
+                  ;; then add a' to S as an unmarked set of items
+                  (push unmarked-lr-items prefix-lr-item))))))))
 
     lr-items))
 
@@ -816,6 +785,7 @@
 
                                     ;; (c) Repeat (b) until no more items can 
be added to V(e)
                                     (setq found-new t))))))))))))))
+
           (parser--debug
            (message "V(e) = %s" lr-items-e))
 
@@ -838,68 +808,14 @@
 
                 (if (gethash prefix-acc parser--table-lr-items-for-prefix)
                     (setq prefix-previous (gethash prefix-acc 
parser--table-lr-items-for-prefix))
+                  (setq lr-new-item (parser--lr-items-for-goto prefix-previous 
prefix))
+
                   (parser--debug
                    (message "prefix: %s" prefix)
                    (message "prefix-acc: %s" prefix-acc)
-                   (message "prefix-previous: %s" prefix-previous))
-
-                  (dolist (lr-item prefix-previous)
-                    (let ((lr-item-lhs (nth 0 lr-item))
-                          (lr-item-prefix (nth 1 lr-item))
-                          (lr-item-suffix (nth 2 lr-item))
-                          (lr-item-look-ahead (nth 3 lr-item)))
-                      (let ((lr-item-suffix-first (car lr-item-suffix))
-                            (lr-item-suffix-rest (cdr lr-item-suffix)))
+                   (message "prefix-previous: %s" prefix-previous)
+                   (message "lr-new-item: %s" lr-new-item))
 
-                        ;; (a) If [A -> a . XiB, u] is in V(X1,...,Xi-1)
-                        (when (eq lr-item-suffix-first prefix)
-
-                          ;; Add [A -> aXi . B, u] to V(X1,...,Xi)
-                          (let ((combined-prefix (append lr-item-prefix (list 
prefix))))
-                            (parser--debug
-                             (message "lr-new-item-1: %s" `(,lr-item-lhs 
,combined-prefix ,lr-item-suffix-rest ,lr-item-look-ahead)))
-                            (push `(,lr-item-lhs ,combined-prefix 
,lr-item-suffix-rest ,lr-item-look-ahead) lr-new-item))))))
-
-                  ;; (c) Repeat step (2b) until no more new items can be added 
to V(X1,...,Xi)
-                  (let ((added-new t))
-                    (while added-new
-                      (setq added-new nil)
-                      (dolist (lr-item lr-new-item)
-                        (let ((lr-item-suffix (nth 2 lr-item)))
-                          (let ((lr-item-suffix-first (car lr-item-suffix))
-                                (lr-item-suffix-rest (cdr lr-item-suffix)))
-
-                            ;; (b) If [A -> a . Bb, u] has been placed in 
V(X1,...,Xi)
-                            ;; and B -> D is in P
-                            (when (parser--valid-non-terminal-p 
lr-item-suffix-first)
-
-                              (let ((lr-item-suffix-rest-first (parser--first 
lr-item-suffix-rest)))
-                                (unless lr-item-suffix-rest-first
-                                  (setq lr-item-suffix-rest-first (list nil)))
-                                (let ((sub-production (parser--get-grammar-rhs 
lr-item-suffix-first)))
-
-                                  ;; For each production with B as LHS
-                                  (dolist (sub-rhs sub-production)
-
-                                    ;; Transform e-productions into nil
-                                    (when (and
-                                           (= (length sub-rhs) 1)
-                                           (parser--valid-e-p (car sub-rhs)))
-                                      (setq sub-rhs nil))
-
-                                    ;; For each x in FIRST(αu)
-                                    (dolist (f lr-item-suffix-rest-first)
-
-                                      ;; then add [B -> . D, x] to 
V(X1,...,Xi) for each x in FIRST(bu)
-                                      ;; provided it is not already there
-                                      (unless (gethash `(,prefix-acc 
,lr-item-suffix-first nil ,sub-rhs ,f) lr-item-exists)
-                                        (setq added-new t)
-                                        (parser--debug
-                                         (message "lr-new-item-2: %s" 
`(,lr-item-suffix-first nil ,sub-rhs ,f)))
-                                        (puthash `(,prefix-acc 
,lr-item-suffix-first nil ,sub-rhs ,f) t lr-item-exists)
-                                        (push `(,lr-item-suffix-first nil 
,sub-rhs ,f) lr-new-item))))))))))))
-
-                  (setq lr-new-item (sort lr-new-item 'parser--sort-list))
                   (setq prefix-previous lr-new-item)
                   (parser--debug
                    (message "V%s = %s" prefix-acc lr-new-item))
@@ -909,6 +825,71 @@
        (message "γ: %s" γ))
       (gethash γ parser--table-lr-items-for-prefix))))
 
+(defun parser--lr-items-for-goto (previous-lr-item x)
+  "Calculate LR-items for GOTO(PREVIOUS-LR-ITEM, X)."
+  (let ((lr-new-item)
+        (lr-item-exists (make-hash-table :test 'equal)))
+    (parser--debug (message "x: %s" x))
+
+    (dolist (lr-item previous-lr-item)
+      (let ((lr-item-lhs (nth 0 lr-item))
+            (lr-item-prefix (nth 1 lr-item))
+            (lr-item-suffix (nth 2 lr-item))
+            (lr-item-look-ahead (nth 3 lr-item)))
+        (let ((lr-item-suffix-first (car lr-item-suffix))
+              (lr-item-suffix-rest (cdr lr-item-suffix)))
+
+          ;; (a) If [A -> a . XiB, u] is in V(X1,...,Xi-1)
+          (when (eq lr-item-suffix-first x)
+
+            ;; Add [A -> aXi . B, u] to V(X1,...,Xi)
+            (let ((combined-prefix (append lr-item-prefix (list x))))
+              (parser--debug
+               (message "lr-new-item-1: %s" `(,lr-item-lhs ,combined-prefix 
,lr-item-suffix-rest ,lr-item-look-ahead)))
+              (push `(,lr-item-lhs ,combined-prefix ,lr-item-suffix-rest 
,lr-item-look-ahead) lr-new-item))))))
+
+    ;; (c) Repeat step (2b) until no more new items can be added to 
V(X1,...,Xi)
+    (let ((added-new t))
+      (while added-new
+        (setq added-new nil)
+        (dolist (lr-item lr-new-item)
+          (let ((lr-item-suffix (nth 2 lr-item)))
+            (let ((lr-item-suffix-first (car lr-item-suffix))
+                  (lr-item-suffix-rest (cdr lr-item-suffix)))
+
+              ;; (b) If [A -> a . Bb, u] has been placed in V(X1,...,Xi)
+              ;; and B -> D is in P
+              (when (parser--valid-non-terminal-p lr-item-suffix-first)
+
+                (let ((lr-item-suffix-rest-first (parser--first 
lr-item-suffix-rest)))
+                  (unless lr-item-suffix-rest-first
+                    (setq lr-item-suffix-rest-first (list nil)))
+                  (let ((sub-production (parser--get-grammar-rhs 
lr-item-suffix-first)))
+
+                    ;; For each production with B as LHS
+                    (dolist (sub-rhs sub-production)
+
+                      ;; Transform e-productions into nil
+                      (when (and
+                             (= (length sub-rhs) 1)
+                             (parser--valid-e-p (car sub-rhs)))
+                        (setq sub-rhs nil))
+
+                      ;; For each x in FIRST(αu)
+                      (dolist (f lr-item-suffix-rest-first)
+
+                        ;; then add [B -> . D, x] to V(X1,...,Xi) for each x 
in FIRST(bu)
+                        ;; provided it is not already there
+                        (let ((lr-item-to-add `(,lr-item-suffix-first nil 
,sub-rhs ,f)))
+                          (unless (gethash lr-item-to-add lr-item-exists)
+                            (setq added-new t)
+                            (parser--debug (message "lr-item-to-add: %s" 
lr-item-to-add))
+                            (puthash lr-item-to-add t lr-item-exists)
+                            (push lr-item-to-add lr-new-item)))))))))))))
+
+    (setq lr-new-item (sort lr-new-item 'parser--sort-list))
+    lr-new-item))
+
 
 (provide 'parser)
 
diff --git a/test/parser-test.el b/test/parser-test.el
index caed787..90aca30 100644
--- a/test/parser-test.el
+++ b/test/parser-test.el
@@ -231,6 +231,8 @@
   (parser--set-grammar '((Sp S) (a b) ((Sp S) (S (S a S b)) (S e)) Sp))
   (parser--set-look-ahead-number 1)
 
+  (message "LR-items for grammar: %s" (parser--lr-items-for-grammar))
+
   (should
    (equal
     '((S nil (S a S b) (a))
@@ -326,19 +328,6 @@
     (parser--lr-items-for-prefix '(S a b))))
   (message "Passed V(Sab)")
 
-  ;; a4 p. 390
-  (should
-   (equal
-    '((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 (e)))
-    (parser--lr-items-for-prefix '(S a S b))))
-  (message "Passed V(SaSb)")
-
-
   (message "Passed tests for (parser--lr-items-for-prefix)"))
 
 (defun parser-test--valid-grammar-p ()
@@ -477,8 +466,7 @@
   (parser-test--e-free-first)
   (parser-test--follow)
   (parser-test--lr-items-for-prefix)
-  ;; (parser-test--lr-items-for-grammar)
-  )
+  (parser-test--lr-items-for-grammar))
 
 (provide 'parser-test)