[elpa] externals/parser-generator 0523eeb 336/434: More work on global precedence

[ELPA Syncer]

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

    More work on global precedence
---
 parser-generator-lr.el           | 213 ++++++++++++++++++++++-----------------
 test/parser-generator-lr-test.el |  23 ++++-
 2 files changed, 142 insertions(+), 94 deletions(-)

diff --git a/parser-generator-lr.el b/parser-generator-lr.el
index 59ea339..bcfdca2 100644
--- a/parser-generator-lr.el
+++ b/parser-generator-lr.el
@@ -40,29 +40,24 @@
   "Attribute used for context-sensitive-precedence.")
 
 (defvar
-  parser-generator-lr--context-sensitive-precedence-comparison-function
+  parser-generator-lr--global-precedence-attributes
   nil
-  "Function used for resolving context-sensitive precedence.")
+  "Global precedence attributes.")
 
 (defvar
-  parser-generator-lr--global-precedence-attribute-left
+  parser-generator-lr--global-precedence-attributes-table
   nil
-  "Global precedence attribute to left symbol.")
+  "Table of global precedence attributes.")
 
 (defvar
-  parser-generator-lr--global-precedence-attribute-right
-  nil
-  "Global precedence attribute to right symbol.")
-
-(defvar
-  parser-generator-lr--global-precedence-attribute-general
+  parser-generator-lr--global-precedence-table
   nil
-  "Global precedence attribute for general precedence.")
+  "Hash-table for fast look-up of global precedence symbols.")
 
 (defvar
-  parser-generator-lr--global-precedence-table
+  parser-generator-lr--precedence-comparison-function
   nil
-  "Hash-table for fast look-up of global precedence symbols.")
+  "Function to calculate precedence.")
 
 
 ;; Main Algorithms
@@ -72,39 +67,27 @@
   (setq
    parser-generator-lr--global-precedence-table
    (make-hash-table :test 'equal))
-  (when (or
-         parser-generator-lr--global-precedence-attribute-left
-         parser-generator-lr--global-precedence-attribute-right
-         parser-generator-lr--global-precedence-attribute-general)
+  (setq
+   parser-generator-lr--global-precedence-attributes-table
+   (make-hash-table :test 'equal))
+  (when parser-generator-lr--global-precedence-attributes
+    (dolist (item parser-generator-lr--global-precedence-attributes)
+      (puthash
+       item
+       t
+       parser-generator-lr--global-precedence-attributes-table))
     (let ((line-index 0))
       (dolist (line parser-generator--global-declaration)
         (let ((attribute (car line))
               (items (cdr line)))
-          (cond
-           ((eq
-             attribute
-             parser-generator-lr--global-precedence-attribute-left)
-            (dolist (item items)
-              (puthash
-               item
-               `(left ,line-index)
-               parser-generator-lr--global-precedence-table)))
-           ((eq
-             attribute
-             parser-generator-lr--global-precedence-attribute-right)
-            (dolist (item items)
-              (puthash
-               item
-               `(right ,line-index)
-               parser-generator-lr--global-precedence-table)))
-           ((eq
-             attribute
-             parser-generator-lr--global-precedence-attribute-general)
-            (dolist (item items)
-              (puthash
-               item
-               `(general ,line-index)
-               parser-generator-lr--global-precedence-table)))))
+          (when
+              (gethash
+               attribute
+               parser-generator-lr--global-precedence-attributes-table)
+            (puthash
+             item
+             `(,attribute ,line-index)
+             parser-generator-lr--global-precedence-table)))
         (setq
          line-index
          (1+ line-index))))))
@@ -995,56 +978,87 @@
             (setq b-index (1+ b-index))))
         (setq a-index (1+ a-index)))
       (setq set-index (1+ set-index)))
-
     valid-p))
 
 (defun parser-generator-lr--symbol-takes-precedence-p (a b)
   "Return t if A takes precedence over B, otherwise nil."
-  (let ((takes-precedence))
-    (cond
-     ((and
-       (listp a)
-       (listp b))
-      (let ((a-value
-             (plist-get
-              (car (cdr a))
-              parser-generator-lr--context-sensitive-precedence-attribute))
-            (b-value
-             (plist-get
-              (car (cdr b))
-              parser-generator-lr--context-sensitive-precedence-attribute)))
-        (condition-case
-            errors
-            (let ((comparison
-                   (funcall
-                    
parser-generator-lr--context-sensitive-precedence-comparison-function
-                    a-value
-                    b-value)))
-              (setq
-               takes-precedence
-               comparison))
-          (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--context-sensitive-precedence-attribute)
+  (let ((takes-precedence)
+        (a-global-reference)
+        (a-precedence)
+        (b-global-reference)
+        (b-precedence))
+    (unless
+        parser-generator-lr--precedence-comparison-function
+      (error
+       "Missing function to compare precedence!"))
+    (when
+        (listp a)
+      (setq
+       a-global-reference
+       (plist-get
+        (car (cdr a))
+        parser-generator-lr--context-sensitive-precedence-attribute)))
+    (when
+        (listp b)
+      (setq
+       b-global-reference
+       (plist-get
+        (car (cdr b))
+        parser-generator-lr--context-sensitive-precedence-attribute)))
+    (if
+        (listp a)
         (setq
-         takes-precedence
-         t)))
-     ((listp b)
-      (when
-          (plist-get
-           (car (cdr b))
-           parser-generator-lr--context-sensitive-precedence-attribute)
+         a-precendence
+         (gethash
+          (car a)
+          parser-generator-lr--global-precedence-table))
+      (setq
+       a-precendence
+       (gethash
+        a
+        parser-generator-lr--global-precedence-table)))
+    (if
+        (listp b)
         (setq
-         takes-precedence
-         nil))))
+         b-precendence
+         (gethash
+          (car b)
+          parser-generator-lr--global-precedence-table))
+      (setq
+       b-precendence
+       (gethash
+        b
+        parser-generator-lr--global-precedence-table)))
+    (when
+        a-global-reference
+      (setq
+       a-precedence
+       (gethash
+        a-global-reference
+        parser-generator-lr--global-precedence-table)))
+    (when
+        b-global-reference
+      (setq
+       b-precedence
+       (gethash
+        b-global-reference
+        parser-generator-lr--global-precedence-table)))
+    (condition-case
+        errors
+        (let ((comparison
+               (funcall
+                parser-generator-lr--precedence-comparison-function
+                a-precedence
+                b-precedence)))
+          (setq
+           takes-precedence
+           comparison))
+      (error
+       (error
+        "Trying to compare '%S' with '%S' resulted in error: '%S'!"
+        a-precedence
+        b-precedence
+        errors)))
     takes-precedence))
 
 (defun parser-generator-lr--conflict-can-be-resolved-by-attributes (a b)
@@ -1052,12 +1066,29 @@
   (let ((can-be-resolved))
     (when
         (and
-         parser-generator-lr--context-sensitive-precedence-attribute
-         parser-generator-lr--context-sensitive-precedence-comparison-function
+         parser-generator-lr--precedence-comparison-function
          (functionp
-          
parser-generator-lr--context-sensitive-precedence-comparison-function)
-         (or (listp a)
-             (listp b)))
+          parser-generator-lr--precedence-comparison-function)
+         (or
+          (and
+           parser-generator-lr--global-precedence-attributes
+           (or
+            (and
+             (not
+              (listp a))
+             (gethash
+              a
+              parser-generator-lr--global-precedence-table))
+            (and
+             (not
+              (listp b))
+             (gethash
+              b
+              parser-generator-lr--global-precedence-table))))
+          (and
+           parser-generator-lr--context-sensitive-precedence-attribute
+           (or (listp a)
+               (listp b)))))
       (if
           (parser-generator-lr--symbol-takes-precedence-p
            a
diff --git a/test/parser-generator-lr-test.el b/test/parser-generator-lr-test.el
index 7bcd8f4..83b7823 100644
--- a/test/parser-generator-lr-test.el
+++ b/test/parser-generator-lr-test.el
@@ -123,6 +123,15 @@
   ;; Inconsistent grammar! ((A) (a b) nil (c)) (index: 0) with look-ahead (c) 
conflicts with ((B) (a b) (c) ($)) (index: 1) with look-ahead (c) in sets: 
((((A) (a b) nil (c)) ((B) (a b) (c) ($))))
 
   (setq
+   parser-generator--global-attributes
+   '(%precedence))
+  (setq
+   parser-generator-lr--global-precedence-attributes
+   '(FIRST))
+  (setq
+   parser-generator--global-declaration
+   '((%precedence FIRST)))
+  (setq
    parser-generator--context-sensitive-attributes
    '(%prec))
   (parser-generator-set-grammar
@@ -133,7 +142,7 @@
       (Sp S)
       (S (A c) B)
       (A (a b))
-      (B (a b (c (%prec 1))))
+      (B (a b (c (%prec FIRST))))
       )
      Sp))
   (parser-generator-set-look-ahead-number 1)
@@ -146,8 +155,16 @@
    parser-generator-lr--context-sensitive-precedence-attribute
    '%prec)
   (setq
-   parser-generator-lr--context-sensitive-precedence-comparison-function
-   #'>)
+   parser-generator-lr--precedence-comparison-function
+   (lambda(a b)
+     (message "LAMBDA %S %S" a b)
+     (cond
+      ((and a b)
+       (string> a b))
+      (a
+       t)
+      (t
+       nil))))
   (parser-generator-lr-generate-parser-tables)
   (message "Grammar not conflicting anymore")