emacs-elpa-diffs
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[elpa] externals/parser-generator 043e375 095/434: Refactored LR-parser


From: ELPA Syncer
Subject: [elpa] externals/parser-generator 043e375 095/434: Refactored LR-parser into stand-alone file
Date: Mon, 29 Nov 2021 15:59:16 -0500 (EST)

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

    Refactored LR-parser into stand-alone file
---
 Makefile               |  11 +-
 parser-lr.el           | 369 +++++++++++++++++++++++++++++++++++++++++++++++++
 parser.el              | 354 +----------------------------------------------
 test/parser-lr-test.el | 170 +++++++++++++++++++++++
 test/parser-test.el    | 114 +--------------
 5 files changed, 552 insertions(+), 466 deletions(-)

diff --git a/Makefile b/Makefile
index 4db76fa..951c98d 100644
--- a/Makefile
+++ b/Makefile
@@ -15,6 +15,13 @@ clean:
 compile:
        $(EMACS_CMD) -f batch-byte-compile $(EL)
 
-.PHONY: tests
-tests:
+.PHONY: test
+test:
        $(EMACS_CMD) -l test/parser-test.el -f "parser-test"
+
+.PHONY: test-lr
+test-lr:
+       $(EMACS_CMD) -l test/parser-lr-test.el -f "parser-lr-test"
+
+.PHONY: tests
+tests: test test-lr
diff --git a/parser-lr.el b/parser-lr.el
new file mode 100644
index 0000000..5562ad8
--- /dev/null
+++ b/parser-lr.el
@@ -0,0 +1,369 @@
+;;; parser-el.el --- LR(k) Parser -*- lexical-binding: t -*-
+
+
+;;; Commentary:
+
+
+;;; Code:
+
+
+(require 'parser)
+
+
+;;; Variables:
+
+
+(defvar parser-lr--goto-tables
+  nil
+  "GOTO-tables for grammar.")
+
+(defvar parser-lr--items
+  nil
+  "Hash-table for distinct LR-items in grammar.")
+
+
+;; Main Algorithms
+
+;; Algorithm 5.9, p. 389
+(defun parser-lr--generate-goto-tables ()
+  "Calculate set of valid LR(k) items for grammar and a GOTO-table."
+  (unless (or
+           parser-lr--goto-tables
+           parser-lr--items)
+    (setq parser--goto-table nil)
+    (setq parser--table-lr-items (make-hash-table :test 'equal))
+    (let ((lr-item-set-new-index 0)
+          (goto-table)
+          (unmarked-lr-item-sets)
+          (marked-lr-item-sets (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.
+        (push `(,lr-item-set-new-index ,e-set) unmarked-lr-item-sets)
+        (setq lr-item-set-new-index (1+ lr-item-set-new-index)))
+
+      ;; (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 ((popped-item)
+            (lr-item-set-index)
+            (lr-items)
+            (goto-table-table))
+        (while unmarked-lr-item-sets
+
+          (setq popped-item (pop unmarked-lr-item-sets))
+          (setq lr-item-set-index (car popped-item))
+          (setq lr-items (car (cdr popped-item)))
+          (parser--debug
+           (message "lr-item-set-index: %s" lr-item-set-index)
+           (message "lr-items: %s" lr-items)
+           (message "popped-item: %s" popped-item))
+
+          ;; (2) Mark a
+          (puthash lr-items lr-item-set-index marked-lr-item-sets)
+
+          (puthash lr-item-set-index lr-items parser--table-lr-items)
+          (setq goto-table-table nil)
+
+          ;; (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)
+            (parser--debug
+             (message "symbol: %s" symbol))
+
+            (let ((prefix-lr-items (parser-lr--items-for-goto lr-items 
symbol)))
+
+              ;; If a' = GOTO(a, X) is nonempty
+              (when prefix-lr-items
+
+                (parser--debug
+                 (message "GOTO(%s, %s) = %s" lr-items symbol prefix-lr-items))
+
+                ;; and is not already in S
+                (let ((goto (gethash prefix-lr-items marked-lr-item-sets)))
+                  (if goto
+                      (progn
+                        (parser--debug
+                         (message "Set already exists in: %s" goto))
+                        (push `(,symbol ,goto) goto-table-table))
+
+                    (parser--debug
+                     (message "Set is new"))
+
+                    ;; Note that GOTO(a, X) will always be empty if all items 
in a
+                    ;; 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)))))))
+
+          (setq goto-table-table (sort goto-table-table 'parser--sort-list))
+          (push `(,lr-item-set-index ,goto-table-table) goto-table)))
+      (setq parser--goto-table (sort goto-table 'parser--sort-list)))
+    (unless
+        (parser-lr--items-valid-p
+         (parser--hash-values-to-list parser--table-lr-items t))
+      (error "Inconsistent grammar!")))
+  t)
+
+;; Algorithm 5.10, p. 391
+(defun parser-lr--items-valid-p (lr-item-sets)
+  "Return whether the set collection LR-ITEM-SETS is valid or not."
+  (parser--debug
+   (message "lr-item-sets: %s" lr-item-sets))
+  (let ((valid-p t)
+        (set-index 0)
+        (set)
+        (sets-length (length lr-item-sets))
+        (set-length 0)
+        (a)
+        (a-look-ahead)
+        (a-follow)
+        (a-index 0)
+        (b)
+        (b-suffix)
+        (b-follow)
+        (b-suffix-follow)
+        (b-suffix-follow-eff)
+        (b-index 0))
+
+    ;; Iterate each set
+    (while (and
+            valid-p
+            (< set-index sets-length))
+      (setq set (nth set-index lr-item-sets))
+      (parser--debug
+       (message "set: %s" set))
+
+      ;; Iterate each set
+      (setq a-index 0)
+      (setq b-index 0)
+      (setq set-length (length set))
+      (while (and
+              valid-p
+              (< a-index set-length))
+        (setq a (nth a-index set))
+        (setq a-look-ahead (nth 2 a))
+
+        (parser--debug
+         (message "a: %s" a)
+         (message "a-look-ahead: %s" a-look-ahead))
+
+        ;; The only sets of LR items which need to be tested are those that 
contain a dot at the right end of a production
+        (unless a-look-ahead
+          (setq a-follow (nth 3 a))
+
+          (parser--debug
+           (message "a-follow: %s" a-follow))
+
+          ;; Iterate each set again
+          (while (and
+                  valid-p
+                  (< b-index set-length))
+            (unless (= a-index b-index)
+              (setq b (nth b-index set))
+              (setq b-suffix (nth 2 b))
+              (setq b-follow (nth 3 b))
+              (setq b-suffix-follow (append b-suffix b-follow))
+              (setq b-suffix-follow-eff (parser--e-free-first b-suffix-follow))
+
+              (parser--debug
+               (message "b: %s" b)
+               (message "b-suffix: %s" b-suffix)
+               (message "b-follow: %s" b-follow)
+               (message "b-suffix-follow: %s" b-suffix-follow)
+               (message "b-suffix-follow-eff: %s" b-suffix-follow-eff))
+
+              (dolist (b-suffix-follow-eff-item b-suffix-follow-eff)
+                (when (equal a-follow b-suffix-follow-eff-item)
+                  (parser--debug
+                   (message "Inconsistent grammar! %s conflicts with %s" a b))
+                  (setq valid-p nil))))
+            (setq b-index (1+ b-index))))
+        (setq a-index (1+ a-index)))
+      (setq set-index (1+ set-index)))
+
+    valid-p))
+
+;; Algorithm 5.8, p. 386
+(defun parser-lr--items-for-prefix (γ)
+  "Calculate valid LR-items for the viable prefix Γ."
+  (let ((start (parser--get-grammar-start)))
+    (unless (listp γ)
+      (setq γ (list γ)))
+    (unless (parser--valid-sentential-form-p γ)
+      (error "Invalid sentential form γ!"))
+
+    (let ((lr-item-exists (make-hash-table :test 'equal)))
+
+      ;; 1
+
+      ;; Iterate all productions in grammar
+      (let ((lr-items-e)
+            (start-productions (parser--get-grammar-rhs start)))
+
+        ;; (a)
+        (dolist (rhs start-productions)
+          ;; Add [S -> . α] to V(e)
+          (push `(,start nil ,rhs (e)) lr-items-e)
+          (puthash `(,parser--e-identifier ,start nil ,rhs 
(,parser--e-identifier)) t lr-item-exists))
+
+        ;; (b) Iterate every item in v-set(e), if [A -> . Bα, u] is an item 
and B -> β is in P
+        ;; then for each x in FIRST(αu) add [B -> . β, x] to v-set(e), 
provided it is not already there
+        (let ((found-new t))
+
+          ;; Repeat this until no new item is found
+          (while found-new
+            (setq found-new nil)
+
+            ;; Iterate every item in V(e)
+            (dolist (item lr-items-e)
+              (let ((prefix (nth 1 item))
+                    (rhs (nth 2 item))
+                    (suffix (nth 3 item)))
+
+                ;; Without prefix
+                (unless prefix
+
+                  ;; Check if RHS starts with a non-terminal
+                  (let ((rhs-first (car rhs)))
+                    (parser--debug
+                     (message "rhs-first: %s" rhs-first))
+                    (when (parser--valid-non-terminal-p rhs-first)
+                      (let ((rhs-rest (append (cdr rhs) suffix)))
+                        (let ((rhs-rest-first (parser--first rhs-rest)))
+                          (parser--debug
+                           (message "rhs-rest-first: %s" rhs-rest-first))
+                          (unless rhs-rest-first
+                            (setq rhs-rest-first `((,parser--e-identifier))))
+                          (let ((sub-production (parser--get-grammar-rhs 
rhs-first)))
+                            (parser--debug
+                             (message "sub-production: %s" sub-production))
+
+                            ;; For each production with B as LHS
+                            (dolist (sub-rhs sub-production)
+
+                              ;; Set follow to nil if it's the e-identifier
+                              (when (and
+                                     (= (length sub-rhs) 1)
+                                     (parser--valid-e-p (car sub-rhs)))
+                                (setq sub-rhs nil))
+
+                              (parser--debug
+                               (message "sub-rhs: %s" sub-rhs))
+
+                              ;; For each x in FIRST(αu)
+                              (dolist (f rhs-rest-first)
+                                (parser--debug
+                                 (message "f: %s" f))
+
+                                ;; Add [B -> . β, x] to V(e), provided it is 
not already there
+                                (unless (gethash `(e ,rhs-first nil ,sub-rhs 
,f) lr-item-exists)
+                                  (puthash `(e ,rhs-first nil ,sub-rhs ,f) t 
lr-item-exists)
+                                  (push `(,rhs-first nil ,sub-rhs ,f) 
lr-items-e)
+
+                                  ;; (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))
+
+        (setq lr-items-e (sort lr-items-e 'parser--sort-list))
+
+        ;; 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))
+          (unless (and
+                   (= (length γ) 1)
+                   (parser--valid-e-p (car γ)))
+            (dolist (prefix γ)
+              (let ((lr-new-item))
+                (setq lr-new-item (parser-lr--items-for-goto prefix-previous 
prefix))
+
+                (parser--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))))
+
+          (parser--debug
+           (message "γ: %s" γ))
+          prefix-previous)))))
+
+(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))
+
+;; Algorithm 5.11, p. 393
+(defun parser-lr--generate-action-tables ()
+  "Generate action-tables for lr-grammar."
+  ;; TODO This
+  t)
+
+
+(provide 'parser-lr)
+
+;;; parser-lr.el ends here
diff --git a/parser.el b/parser.el
index bd8c3c2..8b25813 100644
--- a/parser.el
+++ b/parser.el
@@ -1,4 +1,4 @@
-;;; parser.el --- LR(k) Parser -*- lexical-binding: t -*-
+;;; parser.el --- Parser library -*- lexical-binding: t -*-
 
 
 ;;; Commentary:
@@ -26,18 +26,10 @@
   nil
   "Generated F-sets for grammar.")
 
-(defvar parser--goto-table
-  nil
-  "GOTO-table for grammar.")
-
 (defvar parser--look-ahead-number
   nil
   "Current look-ahead number used.")
 
-(defvar parser--table-lr-items
-  nil
-  "Hash-table for distinct LR-items in grammar.")
-
 (defvar parser--table-non-terminal-p
   nil
   "Hash-table of terminals for quick checking.")
@@ -65,9 +57,7 @@
 
 (defun parser--clear-cache ()
   "Clear cache."
-  (setq parser--f-sets nil)
-  (setq parser--goto-table nil)
-  (setq parser--table-lr-items nil))
+  (setq parser--f-sets nil))
 
 (defun parser--distinct (elements)
   "Return distinct of ELEMENTS."
@@ -698,346 +688,6 @@
       (setq follow-set (parser--distinct follow-set)))
     follow-set))
 
-;; Algorithm 5.9, p. 389
-(defun parser--generate-tables-for-lr ()
-  "Calculate set of valid LR(k) items for grammar and a GOTO-table."
-  (unless (or
-           parser--goto-table
-           parser--table-lr-items)
-    (setq parser--goto-table nil)
-    (setq parser--table-lr-items (make-hash-table :test 'equal))
-    (let ((lr-item-set-new-index 0)
-          (goto-table)
-          (unmarked-lr-item-sets)
-          (marked-lr-item-sets (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.
-        (push `(,lr-item-set-new-index ,e-set) unmarked-lr-item-sets)
-        (setq lr-item-set-new-index (1+ lr-item-set-new-index)))
-
-      ;; (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 ((popped-item)
-            (lr-item-set-index)
-            (lr-items)
-            (goto-table-table))
-        (while unmarked-lr-item-sets
-
-          (setq popped-item (pop unmarked-lr-item-sets))
-          (setq lr-item-set-index (car popped-item))
-          (setq lr-items (car (cdr popped-item)))
-          (parser--debug
-           (message "lr-item-set-index: %s" lr-item-set-index)
-           (message "lr-items: %s" lr-items)
-           (message "popped-item: %s" popped-item))
-
-          ;; (2) Mark a
-          (puthash lr-items lr-item-set-index marked-lr-item-sets)
-
-          (puthash lr-item-set-index lr-items parser--table-lr-items)
-          (setq goto-table-table nil)
-
-          ;; (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)
-            (parser--debug
-             (message "symbol: %s" symbol))
-
-            (let ((prefix-lr-items (parser--lr-items-for-goto lr-items 
symbol)))
-
-              ;; If a' = GOTO(a, X) is nonempty
-              (when prefix-lr-items
-
-                (parser--debug
-                 (message "GOTO(%s, %s) = %s" lr-items symbol prefix-lr-items))
-
-                ;; and is not already in S
-                (let ((goto (gethash prefix-lr-items marked-lr-item-sets)))
-                  (if goto
-                      (progn
-                        (parser--debug
-                         (message "Set already exists in: %s" goto))
-                        (push `(,symbol ,goto) goto-table-table))
-
-                    (parser--debug
-                     (message "Set is new"))
-
-                    ;; Note that GOTO(a, X) will always be empty if all items 
in a
-                    ;; 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)))))))
-
-          (setq goto-table-table (sort goto-table-table 'parser--sort-list))
-          (push `(,lr-item-set-index ,goto-table-table) goto-table)))
-      (setq parser--goto-table (sort goto-table 'parser--sort-list)))
-    (unless
-        (parser--lr-items-valid-p
-         (parser--hash-values-to-list parser--table-lr-items t))
-      (error "Inconsistent grammar!")))
-  t)
-
-;; Algorithm 5.10, p. 391
-(defun parser--lr-items-valid-p (lr-item-sets)
-  "Return whether the set collection LR-ITEM-SETS is valid or not."
-  (parser--debug
-   (message "lr-item-sets: %s" lr-item-sets))
-  (let ((valid-p t)
-        (set-index 0)
-        (set)
-        (sets-length (length lr-item-sets))
-        (set-length 0)
-        (a)
-        (a-look-ahead)
-        (a-follow)
-        (a-index 0)
-        (b)
-        (b-suffix)
-        (b-follow)
-        (b-suffix-follow)
-        (b-suffix-follow-eff)
-        (b-index 0))
-
-    ;; Iterate each set
-    (while (and
-            valid-p
-            (< set-index sets-length))
-      (setq set (nth set-index lr-item-sets))
-      (parser--debug
-       (message "set: %s" set))
-
-      ;; Iterate each set
-      (setq a-index 0)
-      (setq b-index 0)
-      (setq set-length (length set))
-      (while (and
-              valid-p
-              (< a-index set-length))
-        (setq a (nth a-index set))
-        (setq a-look-ahead (nth 2 a))
-
-        (parser--debug
-         (message "a: %s" a)
-         (message "a-look-ahead: %s" a-look-ahead))
-
-        ;; The only sets of LR items which need to be tested are those that 
contain a dot at the right end of a production
-        (unless a-look-ahead
-          (setq a-follow (nth 3 a))
-
-          (parser--debug
-           (message "a-follow: %s" a-follow))
-
-          ;; Iterate each set again
-          (while (and
-                  valid-p
-                  (< b-index set-length))
-            (unless (= a-index b-index)
-              (setq b (nth b-index set))
-              (setq b-suffix (nth 2 b))
-              (setq b-follow (nth 3 b))
-              (setq b-suffix-follow (append b-suffix b-follow))
-              (setq b-suffix-follow-eff (parser--e-free-first b-suffix-follow))
-
-              (parser--debug
-               (message "b: %s" b)
-               (message "b-suffix: %s" b-suffix)
-               (message "b-follow: %s" b-follow)
-               (message "b-suffix-follow: %s" b-suffix-follow)
-               (message "b-suffix-follow-eff: %s" b-suffix-follow-eff))
-
-              (dolist (b-suffix-follow-eff-item b-suffix-follow-eff)
-                (when (equal a-follow b-suffix-follow-eff-item)
-                  (parser--debug
-                   (message "Inconsistent grammar! %s conflicts with %s" a b))
-                  (setq valid-p nil))))
-            (setq b-index (1+ b-index))))
-        (setq a-index (1+ a-index)))
-      (setq set-index (1+ set-index)))
-
-    valid-p))
-
-;; Algorithm 5.8, p. 386
-(defun parser--lr-items-for-prefix (γ)
-  "Calculate valid LR-items for the viable prefix Γ."
-  (let ((start (parser--get-grammar-start)))
-    (unless (listp γ)
-      (setq γ (list γ)))
-    (unless (parser--valid-sentential-form-p γ)
-      (error "Invalid sentential form γ!"))
-
-    (let ((lr-item-exists (make-hash-table :test 'equal)))
-
-      ;; 1
-
-      ;; Iterate all productions in grammar
-      (let ((lr-items-e)
-            (start-productions (parser--get-grammar-rhs start)))
-
-        ;; (a)
-        (dolist (rhs start-productions)
-          ;; Add [S -> . α] to V(e)
-          (push `(,start nil ,rhs (e)) lr-items-e)
-          (puthash `(,parser--e-identifier ,start nil ,rhs 
(,parser--e-identifier)) t lr-item-exists))
-
-        ;; (b) Iterate every item in v-set(e), if [A -> . Bα, u] is an item 
and B -> β is in P
-        ;; then for each x in FIRST(αu) add [B -> . β, x] to v-set(e), 
provided it is not already there
-        (let ((found-new t))
-
-          ;; Repeat this until no new item is found
-          (while found-new
-            (setq found-new nil)
-
-            ;; Iterate every item in V(e)
-            (dolist (item lr-items-e)
-              (let ((prefix (nth 1 item))
-                    (rhs (nth 2 item))
-                    (suffix (nth 3 item)))
-
-                ;; Without prefix
-                (unless prefix
-
-                  ;; Check if RHS starts with a non-terminal
-                  (let ((rhs-first (car rhs)))
-                    (parser--debug
-                     (message "rhs-first: %s" rhs-first))
-                    (when (parser--valid-non-terminal-p rhs-first)
-                      (let ((rhs-rest (append (cdr rhs) suffix)))
-                        (let ((rhs-rest-first (parser--first rhs-rest)))
-                          (parser--debug
-                           (message "rhs-rest-first: %s" rhs-rest-first))
-                          (unless rhs-rest-first
-                            (setq rhs-rest-first `((,parser--e-identifier))))
-                          (let ((sub-production (parser--get-grammar-rhs 
rhs-first)))
-                            (parser--debug
-                             (message "sub-production: %s" sub-production))
-
-                            ;; For each production with B as LHS
-                            (dolist (sub-rhs sub-production)
-
-                              ;; Set follow to nil if it's the e-identifier
-                              (when (and
-                                     (= (length sub-rhs) 1)
-                                     (parser--valid-e-p (car sub-rhs)))
-                                (setq sub-rhs nil))
-
-                              (parser--debug
-                               (message "sub-rhs: %s" sub-rhs))
-
-                              ;; For each x in FIRST(αu)
-                              (dolist (f rhs-rest-first)
-                                (parser--debug
-                                 (message "f: %s" f))
-
-                                ;; Add [B -> . β, x] to V(e), provided it is 
not already there
-                                (unless (gethash `(e ,rhs-first nil ,sub-rhs 
,f) lr-item-exists)
-                                  (puthash `(e ,rhs-first nil ,sub-rhs ,f) t 
lr-item-exists)
-                                  (push `(,rhs-first nil ,sub-rhs ,f) 
lr-items-e)
-
-                                  ;; (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))
-
-        (setq lr-items-e (sort lr-items-e 'parser--sort-list))
-
-        ;; 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))
-          (unless (and
-                   (= (length γ) 1)
-                   (parser--valid-e-p (car γ)))
-            (dolist (prefix γ)
-              (let ((lr-new-item))
-                (setq lr-new-item (parser--lr-items-for-goto prefix-previous 
prefix))
-
-                (parser--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))))
-
-          (parser--debug
-           (message "γ: %s" γ))
-          prefix-previous)))))
-
-(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))
-
-;; Algorithm 5.11, p. 393
-(defun parser--generate-action-tables-for-lr-grammar ()
-  "Generate action-tables for lr-grammar."
-  ;; TODO This
-  t)
-
-
 (provide 'parser)
 
 ;;; parser.el ends here
diff --git a/test/parser-lr-test.el b/test/parser-lr-test.el
new file mode 100644
index 0000000..d2483f0
--- /dev/null
+++ b/test/parser-lr-test.el
@@ -0,0 +1,170 @@
+;;; parser-lr-test.el --- Tests for LR(k) Parser -*- lexical-binding: t -*-
+
+
+;;; Commentary:
+
+
+;;; Code:
+
+(require 'parser-lr)
+(require 'ert)
+
+(defun parser-lr-test--generate-goto-tables ()
+  "Test `parser-lr--generate-goto-tables'."
+  (message "Starting tests for (parser-lr--generate-goto-tables)")
+
+  ;; Example 5.30, p. 389
+  (parser--set-grammar '((Sp S) (a b) ((Sp S) (S (S a S b)) (S e)) Sp))
+  (parser--set-look-ahead-number 1)
+
+  (parser-lr--generate-goto-tables)
+
+  ;; (message "GOTO-table: %s" parser--goto-table)
+  ;; (message "LR-items: %s" (parser--hash-to-list parser--table-lr-items))
+
+  (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--goto-table))
+
+  (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)))))
+    (parser--hash-to-list parser--table-lr-items)))
+
+  (message "Passed LR-items for example 5.30")
+
+  (message "Passed tests for (parser-r--generate-goto-tables)"))
+
+(defun parser-lr-test--items-for-prefix ()
+  "Test `parser-lr--items-for-prefix'."
+  (message "Starting tests for (parser-lr--items-for-prefix)")
+
+  ;; Example 5.29 p 387
+  (parser--set-grammar '((Sp S) (a b) ((Sp S) (S (S a S b)) (S e)) Sp))
+  (parser--set-look-ahead-number 1)
+
+  (should
+   (equal
+    '((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)))
+    (parser-lr--items-for-prefix 'e)))
+  (message "Passed V(e)")
+
+  (should
+   (equal
+    '((S (S) (a S b) (a))
+      (S (S) (a S b) (e))
+      (Sp (S) nil (e)))
+    (parser-lr--items-for-prefix 'S)))
+  (message "Passed V(S)")
+
+  (should
+   (equal
+    nil
+    (parser-lr--items-for-prefix 'a)))
+  (message "Passed V(a)")
+
+  (should
+   (equal
+    nil
+    (parser-lr--items-for-prefix 'b)))
+  (message "Passed V(b)")
+
+  (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 (b)))
+    (parser-lr--items-for-prefix '(S a))))
+  (message "Passed V(Sa)")
+
+  (should
+   (equal
+    nil
+    (parser-lr--items-for-prefix '(S S))))
+  (message "Passed V(SS)")
+
+  (should
+   (equal
+    nil
+    (parser-lr--items-for-prefix '(S b))))
+  (message "Passed V(Sb)")
+
+  ;; a3 p. 390
+  (should
+   (equal
+    '((S (S) (a S b) (a))
+      (S (S) (a S b) (b))
+      (S (S a S) (b) (a))
+      (S (S a S) (b) (e)))
+    (parser-lr--items-for-prefix '(S a S))))
+  (message "Passed V(SaS)")
+
+  (should
+   (equal
+    nil
+    (parser-lr--items-for-prefix '(S a a))))
+  (message "Passed V(Saa)")
+
+  (should
+   (equal
+    nil
+    (parser-lr--items-for-prefix '(S a b))))
+  (message "Passed V(Sab)")
+
+  (message "Passed tests for (parser-lr--items-for-prefix)"))
+
+(defun parser-lr-test--items-valid-p ()
+  "Test `parser-lr--items-valid-p'."
+  (message "Started tests for (parser-lr--items-valid-p)")
+
+  (parser--set-grammar '((Sp S) (a b) ((Sp S) (S (S a S b)) (S e)) Sp))
+  (parser--set-look-ahead-number 1)
+  (parser-lr--generate-goto-tables)
+  (should
+   (equal
+    t
+    (parser-lr--items-valid-p (parser--hash-values-to-list 
parser--table-lr-items t))))
+
+  (message "Passed first")
+
+  (should
+   (equal
+    nil
+    (parser-lr--items-valid-p
+     '(((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))) ((S (S) (a S b) (a)) (S (S) (a S b) (e)) (Sp (S) nil 
(e))) ((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))) ((S (S) (a S b) (a)) (S (S) (a S 
b) (b)) (S (S a S) (b) (a)) (S (S a S) (b) (e))) ((S (S a S b) nil (a)) (S (S a 
S b) (a) (a)) (S (S a S b) nil (e))) ((S (S a) (S b) (a)) (S (S a) (S b) (b)) 
(S nil (S a S b) (a))  [...]
+
+  (message "Passed tests for (parser-lr--items-valid-p)"))
+
+(defun parser-lr-test ()
+  "Run test."
+  ;; (setq debug-on-error t)
+
+  (parser-lr-test--items-for-prefix)
+  (parser-lr-test--generate-goto-tables)
+  (parser-lr-test--items-valid-p))
+
+(provide 'parser-lr-test)
+
+;;; parser-lr-test.el ends here
diff --git a/test/parser-test.el b/test/parser-test.el
index c8fdfed..a8467b3 100644
--- a/test/parser-test.el
+++ b/test/parser-test.el
@@ -1,4 +1,4 @@
-;;; parser-test.el --- Tests for parser -*- lexical-binding: t -*-
+;;; parser-test.el --- Tests for Parser -*- lexical-binding: t -*-
 
 
 ;;; Commentary:
@@ -264,91 +264,6 @@
 
   (message "Passed tests for (parser--generate-tables-for-lr)"))
 
-(defun parser-test--lr-items-for-prefix ()
-  "Test `parser--lr-items-for-prefix'."
-  (message "Starting tests for (parser--lr-items-for-prefix)")
-
-  ;; Example 5.29 p 387
-  (parser--set-grammar '((Sp S) (a b) ((Sp S) (S (S a S b)) (S e)) Sp))
-  (parser--set-look-ahead-number 1)
-
-  (should
-   (equal
-    '((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)))
-    (parser--lr-items-for-prefix 'e)))
-  (message "Passed V(e)")
-
-  (should
-   (equal
-    '((S (S) (a S b) (a))
-      (S (S) (a S b) (e))
-      (Sp (S) nil (e)))
-    (parser--lr-items-for-prefix 'S)))
-  (message "Passed V(S)")
-
-  (should
-   (equal
-    nil
-    (parser--lr-items-for-prefix 'a)))
-  (message "Passed V(a)")
-
-  (should
-   (equal
-    nil
-    (parser--lr-items-for-prefix 'b)))
-  (message "Passed V(b)")
-
-  (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 (b)))
-    (parser--lr-items-for-prefix '(S a))))
-  (message "Passed V(Sa)")
-
-  (should
-   (equal
-    nil
-    (parser--lr-items-for-prefix '(S S))))
-  (message "Passed V(SS)")
-
-  (should
-   (equal
-    nil
-    (parser--lr-items-for-prefix '(S b))))
-  (message "Passed V(Sb)")
-
-  ;; a3 p. 390
-  (should
-   (equal
-    '((S (S) (a S b) (a))
-      (S (S) (a S b) (b))
-      (S (S a S) (b) (a))
-      (S (S a S) (b) (e)))
-    (parser--lr-items-for-prefix '(S a S))))
-  (message "Passed V(SaS)")
-
-  (should
-   (equal
-    nil
-    (parser--lr-items-for-prefix '(S a a))))
-  (message "Passed V(Saa)")
-
-  (should
-   (equal
-    nil
-    (parser--lr-items-for-prefix '(S a b))))
-  (message "Passed V(Sab)")
-
-  (message "Passed tests for (parser--lr-items-for-prefix)"))
-
 (defun parser-test--valid-grammar-p ()
   "Test function `parser--valid-grammar-p'."
   (message "Starting tests for (parser--valid-grammar-p)")
@@ -467,28 +382,6 @@
 
   (message "Passed tests  for (parser--get-grammar-rhs)"))
 
-(defun parser-test--lr-items-valid-p ()
-  "Test `parser--lr-items-valid-p'."
-  (message "Started tests for (parser--lr-items-valid-p)")
-
-  (parser--set-grammar '((Sp S) (a b) ((Sp S) (S (S a S b)) (S e)) Sp))
-  (parser--set-look-ahead-number 1)
-  (parser--generate-tables-for-lr)
-  (should
-   (equal
-    t
-    (parser--lr-items-valid-p (parser--hash-values-to-list 
parser--table-lr-items t))))
-
-  (message "Passed first")
-
-  (should
-   (equal
-    nil
-    (parser--lr-items-valid-p
-     '(((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))) ((S (S) (a S b) (a)) (S (S) (a S b) (e)) (Sp (S) nil 
(e))) ((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))) ((S (S) (a S b) (a)) (S (S) (a S 
b) (b)) (S (S a S) (b) (a)) (S (S a S) (b) (e))) ((S (S a S b) nil (a)) (S (S a 
S b) (a) (a)) (S (S a S b) nil (e))) ((S (S a) (S b) (a)) (S (S a) (S b) (b)) 
(S nil (S a S b) (a))  [...]
-
-  (message "Passed tests for (parser--lr-items-valid-p)"))
-
 (defun parser-test ()
   "Run test."
   ;; (setq debug-on-error t)
@@ -505,10 +398,7 @@
   ;; Algorithms
   (parser-test--first)
   (parser-test--e-free-first)
-  (parser-test--follow)
-  (parser-test--lr-items-for-prefix)
-  (parser-test--generate-tables-for-lr)
-  (parser-test--lr-items-valid-p))
+  (parser-test--follow))
 
 (provide 'parser-test)
 



reply via email to

[Prev in Thread] Current Thread [Next in Thread]