branch: externals/parser-generator
commit 06bff4bfa6032c99162d2a68c140abad03a63089
Author: Christian Johansson <[email protected]>
Commit: Christian Johansson <[email protected]>
Improved validation of conflict-resolution using attributes
---
parser-generator-lr.el | 86 +++++++++++++++++++++++++++++++++-------
test/parser-generator-lr-test.el | 10 ++++-
2 files changed, 79 insertions(+), 17 deletions(-)
diff --git a/parser-generator-lr.el b/parser-generator-lr.el
index 5da6882..8741f4e 100644
--- a/parser-generator-lr.el
+++ b/parser-generator-lr.el
@@ -778,22 +778,11 @@
b-suffix-follow-eff-item)
;; If it's the same symbol but we have a precedence
- ;; attribute on any of them, or both, pass anyway
+ ;; attributes on any of them, or both, pass anyway
(unless
- (and
- parser-generator-lr--precedence-attribute
- parser-generator-lr--precedence-comparison-function
- (or
- (and
- (listp (car a-follow-full))
- (plist-get
- (car (cdr (car a-follow-full)))
- parser-generator-lr--precedence-attribute))
- (and
- (listp (car b-suffix-follow-eff-item-full))
- (plist-get
- (car (cdr (car b-suffix-follow-eff-item-full)))
- parser-generator-lr--precedence-attribute))))
+
(parser-generator-lr--conflict-can-be-resolved-by-attributes
+ (car a-follow-full)
+ (car b-suffix-follow-eff-item-full))
(when
signal-on-false
(error
@@ -812,6 +801,73 @@
valid-p))
+(defun parser-generator-lr--conflict-can-be-resolved-by-attributes (a b)
+ "Return whether a conflict between A and B can be resolved by attributes."
+ (let ((can-be-resolved nil))
+ (when
+ (and
+ parser-generator-lr--precedence-attribute
+ parser-generator-lr--precedence-comparison-function
+ (functionp
+ parser-generator-lr--precedence-comparison-function)
+ (or (listp a)
+ (listp b)))
+ (cond
+ ((and
+ (listp a)
+ (listp b))
+ (let ((a-value
+ (plist-get
+ (car (cdr a))
+ parser-generator-lr--precedence-attribute))
+ (b-value
+ (plist-get
+ (car (cdr b))
+ parser-generator-lr--precedence-attribute)))
+ (condition-case
+ errors
+ (let ((comparison1
+ (funcall
+ parser-generator-lr--precedence-comparison-function
+ a-value
+ b-value))
+ (comparison2
+ (funcall
+ parser-generator-lr--precedence-comparison-function
+ b-value
+ a-value)))
+ (unless
+ (eq
+ comparison1
+ comparison2)
+ (setq
+ can-be-resolved
+ t)))
+ (error
+ (error
+ "Trying to compare '%S' with '%S' resulted in error: '%S'!"
+ a-value
+ b-value
+ errors)))))
+ ((listp a)
+ (when
+ (plist-get
+ (car (cdr a))
+ parser-generator-lr--precedence-attribute)
+ (setq
+ can-be-resolved
+ t)))
+ ((listp b)
+ (when
+ (plist-get
+ (car (cdr b))
+ parser-generator-lr--precedence-attribute)
+ (setq
+ can-be-resolved
+ t)
+ ))))
+ can-be-resolved))
+
;; Algorithm 5.8, p. 386
(defun parser-generator-lr--items-for-prefix (γ)
"Calculate valid LR-items for the viable prefix Γ."
diff --git a/test/parser-generator-lr-test.el b/test/parser-generator-lr-test.el
index 9aebd32..36e5b27 100644
--- a/test/parser-generator-lr-test.el
+++ b/test/parser-generator-lr-test.el
@@ -143,7 +143,7 @@
'%prec)
(setq
parser-generator-lr--precedence-comparison-function
- #'<)
+ #'>)
(parser-generator-lr-generate-parser-tables)
(message "Grammar not conflicting anymore")
@@ -163,7 +163,13 @@
"conflict-action-tables: %s"
(parser-generator-lr--get-expanded-action-tables))
(should
(equal
- '((0 (((a) shift))) (1 (((c) shift))) (2 ((($) reduce 2))) (3 ((($)
accept))) (4 (((b) shift))) (5 ((((c (%prec 1))) shift))) (6 ((($) reduce 1))))
+ '((0 (((a) shift)))
+ (1 (((c) shift)))
+ (2 ((($) reduce 2)))
+ (3 ((($) accept)))
+ (4 (((b) shift)))
+ (5 (((c) shift)))
+ (6 ((($) reduce 1))))
(parser-generator-lr--get-expanded-action-tables))))
(message "Passed tests for (parser-generator-lr--generate-action-tables)"))
