branch: externals/parser-generator
commit d5284b5cd9c8fccef3df4b4b1e26e7522657de64
Author: Christian Johansson <christ...@cvj.se>
Commit: Christian Johansson <christ...@cvj.se>
Added algorithm 5.10
---
parser.el | 92 +++++++++++++++++++++++++++++++++++++++++++++++++++++
test/parser-test.el | 19 ++++++++++-
2 files changed, 110 insertions(+), 1 deletion(-)
diff --git a/parser.el b/parser.el
index c629be9..9644ad2 100644
--- a/parser.el
+++ b/parser.el
@@ -128,6 +128,19 @@
(sort (nreverse result) (lambda (a b) (< (car a) (car b))))))
nil)))
+(defun parser--hash-values-to-list (hash-table &optional un-sorted)
+ "Return a list that represent the HASH-TABLE. Each element is a list: (list
key value), optionally UN-SORTED."
+ (let (result)
+ (if (hash-table-p hash-table)
+ (progn
+ (maphash
+ (lambda (_k v) (push v result))
+ hash-table)
+ (if un-sorted
+ (nreverse result)
+ (sort (nreverse result) (lambda (a b) (< (car a) (car b))))))
+ nil)))
+
(defun parser--load-symbols ()
"Load terminals and non-terminals in grammar."
(let ((terminals (parser--get-grammar-terminals)))
@@ -765,6 +778,85 @@
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-look-ahead b-suffix-follow-eff-item)
+ (parser--debug
+ (message "Inconsistent grammar!"))
+ (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 Γ."
diff --git a/test/parser-test.el b/test/parser-test.el
index 6a9372a..7e662ad 100644
--- a/test/parser-test.el
+++ b/test/parser-test.el
@@ -467,6 +467,22 @@
(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))))
+
+ ;; TODO Figure out a grammar here that should be inconsistent
+
+ (message "Passed tests for (parser--lr-items-valid-p)"))
+
(defun parser-test ()
"Run test."
;; (setq debug-on-error t)
@@ -485,7 +501,8 @@
(parser-test--e-free-first)
(parser-test--follow)
(parser-test--lr-items-for-prefix)
- (parser-test--generate-tables-for-lr))
+ (parser-test--generate-tables-for-lr)
+ (parser-test--lr-items-valid-p))
(provide 'parser-test)
