branch: externals/parser-generator
commit 1e0418d33c46e082f6140e22a93d4acff51abad5
Author: Christian Johansson <christ...@cvj.se>
Commit: Christian Johansson <christ...@cvj.se>
Incremental parse and translate of exported parser passes tests
---
parser-generator-lr-export.el | 632 ++++++++++++++-------------
parser-generator-lr.el | 743 ++++++++++++++++----------------
test/parser-generator-lr-export-test.el | 7 +-
3 files changed, 710 insertions(+), 672 deletions(-)
diff --git a/parser-generator-lr-export.el b/parser-generator-lr-export.el
index 0e0c9a1..ec4cdce 100644
--- a/parser-generator-lr-export.el
+++ b/parser-generator-lr-export.el
@@ -402,68 +402,82 @@
pushdown-list
output
translation
- translation-symbol-table
+ translation-symbol-table-list
history)
- \"Perform a LR-parse via lex-analyzer, optionally at INPUT-TAPE-INDEX with
PUSHDOWN-LIST, OUTPUT, TRANSLATION, TRANSLATION-SYMBOL-TABLE and HISTORY.\"
+ \"Perform a LR-parse via lex-analyzer, optionally at INPUT-TAPE-INDEX with
PUSHDOWN-LIST, OUTPUT, TRANSLATION, TRANSLATION-SYMBOL-TABLE-LIST and HISTORY.\"
(unless input-tape-index
(setq input-tape-index 1))
(unless pushdown-list
(push 0 pushdown-list))
- (unless translation-symbol-table
- (setq
- translation-symbol-table
- (make-hash-table :test 'equal)))
-
- (if (and
- input-tape-index
- (> input-tape-index 1))
- (setq
- %s-lex-analyzer--index
- input-tape-index)
- (%s-lex-analyzer--reset))
-
- (let ((accept)
- (pre-index 0))
- (while (not accept)
-
- ;; Save history when index has changed to enable incremental parsing /
translating
- (when
- (>
- %s-lex-analyzer--index
- pre-index)
- (push
- `(,%s-lex-analyzer--index
- ,pushdown-list
- ,output
- ,translation
- ,translation-symbol-table)
- history)
+ (let ((translation-symbol-table
+ (make-hash-table :test 'equal)))
+ (when translation-symbol-table-list
+ (dolist
+ (item translation-symbol-table-list)
+ (puthash
+ (nth 0 item)
+ (nth 1 item)
+ translation-symbol-table)))
+
+ (if (and
+ input-tape-index
+ (> input-tape-index 1))
(setq
- pre-index
- %s-lex-analyzer--index))
-
- ;; (1) The look-ahead string u, consisting of the next k input symbols,
is determined.
- (let ((look-ahead
- (%s-lex-analyzer--peek-next-look-ahead))
- (look-ahead-full))
-
- ;; Save token stream indexes in separate variable if needed later
- (setq look-ahead-full look-ahead)
-
- ;; Create simplified look-ahead for logic below
- (setq look-ahead nil)
- (dolist (look-ahead-item look-ahead-full)
- (if (listp look-ahead-item)
- (push (car look-ahead-item) look-ahead)
- (push look-ahead-item look-ahead)))
- (setq look-ahead (nreverse look-ahead))
-
- (let ((table-index
- (car pushdown-list)))
- (let ((action-table
- (gethash
- table-index
- %s--action-tables)))"
+ %s-lex-analyzer--index
+ input-tape-index)
+ (%s-lex-analyzer--reset))
+
+ (let ((accept)
+ (pre-index 0))
+ (while (not accept)
+
+ ;; Save history when index has changed to enable incremental parsing /
translating
+ (when
+ (>
+ %s-lex-analyzer--index
+ pre-index)
+ ;; We make a copy of the hash-table here to avoid passing same
+ ;; hash-table every-time with pointer
+ (let ((translation-symbol-table-list))
+ (maphash
+ (lambda (key value)
+ (push
+ `(,key ,value)
+ translation-symbol-table-list))
+ translation-symbol-table)
+ (push
+ `(,%s-lex-analyzer--index
+ ,pushdown-list
+ ,output
+ ,translation
+ ,translation-symbol-table-list)
+ history)
+ (setq
+ pre-index
+ %s-lex-analyzer--index)))
+
+ ;; (1) The look-ahead string u, consisting of the next k input
symbols, is determined.
+ (let ((look-ahead
+ (%s-lex-analyzer--peek-next-look-ahead))
+ (look-ahead-full))
+
+ ;; Save token stream indexes in separate variable if needed later
+ (setq look-ahead-full look-ahead)
+
+ ;; Create simplified look-ahead for logic below
+ (setq look-ahead nil)
+ (dolist (look-ahead-item look-ahead-full)
+ (if (listp look-ahead-item)
+ (push (car look-ahead-item) look-ahead)
+ (push look-ahead-item look-ahead)))
+ (setq look-ahead (nreverse look-ahead))
+
+ (let ((table-index
+ (car pushdown-list)))
+ (let ((action-table
+ (gethash
+ table-index
+ %s--action-tables)))"
namespace
namespace
namespace
@@ -473,255 +487,255 @@
namespace
namespace))
(insert "
- (unless action-table
- (error
- \"Action-table with index %s is empty! Push-down-list: %s\"
- table-index
- pushdown-list))")
+ (unless action-table
+ (error
+ \"Action-table with index %s is empty! Push-down-list: %s\"
+ table-index
+ pushdown-list))")
(insert
(format "
- (let ((action-match nil)
- (action-table-length (length action-table))
- (action-index 0)
- (possible-look-aheads))
-
- ;; (2) The parsing action f of the table on top of the pushdown
list is applied to the lookahead string u.
- (while (and
- (not action-match)
- (< action-index action-table-length))
- (let ((action (nth action-index action-table)))
- (let ((action-look-ahead (car action)))
- (push
- action-look-ahead
- possible-look-aheads)
- (when
- (equal
- action-look-ahead
- look-ahead)
- (setq
- action-match
- (cdr action)))
- (when
- (and
- (=
- %s--look-ahead-number
- 0)
- (not
- action-look-ahead))
- ;; LR(0) reduce actions occupy entire row
- ;; and is applied regardless of look-ahead
- (setq
- action-match
- (cdr action))))
- (setq
- action-index
- (1+ action-index))))
-
- (unless action-match
- ;; (c) If f(u) = error, we halt parsing (and, in practice
- ;; transfer to an error recovery routine)."
+ (let ((action-match nil)
+ (action-table-length (length action-table))
+ (action-index 0)
+ (possible-look-aheads))
+
+ ;; (2) The parsing action f of the table on top of the
pushdown list is applied to the lookahead string u.
+ (while (and
+ (not action-match)
+ (< action-index action-table-length))
+ (let ((action (nth action-index action-table)))
+ (let ((action-look-ahead (car action)))
+ (push
+ action-look-ahead
+ possible-look-aheads)
+ (when
+ (equal
+ action-look-ahead
+ look-ahead)
+ (setq
+ action-match
+ (cdr action)))
+ (when
+ (and
+ (=
+ %s--look-ahead-number
+ 0)
+ (not
+ action-look-ahead))
+ ;; LR(0) reduce actions occupy entire row
+ ;; and is applied regardless of look-ahead
+ (setq
+ action-match
+ (cdr action))))
+ (setq
+ action-index
+ (1+ action-index))))
+
+ (unless action-match
+ ;; (c) If f(u) = error, we halt parsing (and, in practice
+ ;; transfer to an error recovery routine)."
namespace))
(insert "
- (error
- (format
- \"Invalid syntax! Expected one of %s found %s at %s\"
- possible-look-aheads
- look-ahead")
+ (error
+ (format
+ \"Invalid syntax! Expected one of %s found %s at %s\"
+ possible-look-aheads
+ look-ahead")
(insert (format "
- %s-lex-analyzer--index)
- possible-look-aheads
- look-ahead
- %s-lex-analyzer--index))
-
- (cond
-
- ((equal action-match '(shift))
- ;; (a) If f(u) = shift, then the next input symbol, say a
- ;; is removed from the input and shifted onto the pushdown
list.
- ;; The goto function g of the table on top of the pushdown list
- ;; is applied to a to determine the new table to be placed on
- ;; top of the pushdown list. We then return to step(1). If
- ;; there is no next input symbol or g(a) is undefined, halt
- ;; and declare error.
-
- (let ((a (list (car look-ahead)))
- (a-full (list (car look-ahead-full))))
- (let ((goto-table
- (gethash
- table-index
- %s--goto-tables)))
- (let ((goto-table-length (length goto-table))
- (goto-index 0)
- (searching-match t)
- (next-index)
- (possible-look-aheads))
-
- (while (and
- searching-match
- (< goto-index goto-table-length))
- (let ((goto-item (nth goto-index goto-table)))
- (let ((goto-item-symbol (list (car goto-item)))
- (goto-item-next-index (car (cdr goto-item))))
- (push goto-item-symbol possible-look-aheads)
-
- (when (equal
- goto-item-symbol
- a)
- (setq next-index goto-item-next-index)
- (setq searching-match nil))))
-
- (setq goto-index (1+ goto-index)))"
+ %s-lex-analyzer--index)
+ possible-look-aheads
+ look-ahead
+ %s-lex-analyzer--index))
+
+ (cond
+
+ ((equal action-match '(shift))
+ ;; (a) If f(u) = shift, then the next input symbol, say a
+ ;; is removed from the input and shifted onto the pushdown
list.
+ ;; The goto function g of the table on top of the pushdown
list
+ ;; is applied to a to determine the new table to be placed on
+ ;; top of the pushdown list. We then return to step(1). If
+ ;; there is no next input symbol or g(a) is undefined, halt
+ ;; and declare error.
+
+ (let ((a (list (car look-ahead)))
+ (a-full (list (car look-ahead-full))))
+ (let ((goto-table
+ (gethash
+ table-index
+ %s--goto-tables)))
+ (let ((goto-table-length (length goto-table))
+ (goto-index 0)
+ (searching-match t)
+ (next-index)
+ (possible-look-aheads))
+
+ (while (and
+ searching-match
+ (< goto-index goto-table-length))
+ (let ((goto-item (nth goto-index goto-table)))
+ (let ((goto-item-symbol (list (car goto-item)))
+ (goto-item-next-index (car (cdr goto-item))))
+ (push goto-item-symbol possible-look-aheads)
+
+ (when (equal
+ goto-item-symbol
+ a)
+ (setq next-index goto-item-next-index)
+ (setq searching-match nil))))
+
+ (setq goto-index (1+ goto-index)))"
namespace
namespace
namespace))
(insert "
- (unless next-index
- (error
- \"In shift, found no GOTO-item for %s at %s, expected
one of %s\"
- a")
+ (unless next-index
+ (error
+ \"In shift, found no GOTO-item for %s at %s,
expected one of %s\"
+ a")
(insert
(format "
- %s-lex-analyzer--index
- possible-look-aheads))
-
- ;; Maybe push both tokens here?
- (push (car a-full) pushdown-list)
- (push next-index pushdown-list)
- (%s-lex-analyzer--pop-token)))))
-
- ((equal (car action-match) 'reduce)
- ;; (b) If f(u) = reduce i and production i is A -> a,
- ;; then 2|a| symbols are removed from the top of the pushdown
- ;; list, and production number i is placed in the output
- ;; buffer. A new table T' is then exposed as the top table
- ;; of the pushdown list, and the goto function of T' is applied
- ;; to A to determine the next table to be placed on top of the
- ;; pushdown list. We place A and this new table on top of the
- ;; the pushdown list and return to step (1)
-
- (let ((production-number (car (cdr action-match))))
-
- (let ((production
- (%s--get-grammar-production-by-number
- production-number)))
- (let ((production-lhs (car production))
- (production-rhs (car (cdr production)))
- (popped-items-contents))
- (unless (equal
- production-rhs
- (list %s--e-identifier))
- (let ((pop-items (* 2 (length production-rhs)))
- (popped-items 0)
- (popped-item))
- (while (< popped-items pop-items)
- (setq popped-item (pop pushdown-list))
- (when (and
- (listp popped-item)
- (%s--valid-symbol-p
- (car popped-item)))
- (push
- popped-item
- popped-items-contents))
- (setq popped-items (1+ popped-items)))))
- (push production-number output)
-
- (let ((popped-items-meta-contents)
- (all-expanded t))
- ;; Collect arguments for translation
- (dolist (popped-item popped-items-contents)
- (if (and
- (listp popped-item)
- (cdr popped-item))
- ;; If item is a terminal, use it's literal value
- (push
- (%s-lex-analyzer--get-function
- popped-item)
- popped-items-meta-contents)
- (if (gethash
+ %s-lex-analyzer--index
+ possible-look-aheads))
+
+ ;; Maybe push both tokens here?
+ (push (car a-full) pushdown-list)
+ (push next-index pushdown-list)
+ (%s-lex-analyzer--pop-token)))))
+
+ ((equal (car action-match) 'reduce)
+ ;; (b) If f(u) = reduce i and production i is A -> a,
+ ;; then 2|a| symbols are removed from the top of the pushdown
+ ;; list, and production number i is placed in the output
+ ;; buffer. A new table T' is then exposed as the top table
+ ;; of the pushdown list, and the goto function of T' is
applied
+ ;; to A to determine the next table to be placed on top of
the
+ ;; pushdown list. We place A and this new table on top of the
+ ;; the pushdown list and return to step (1)
+
+ (let ((production-number (car (cdr action-match))))
+
+ (let ((production
+ (%s--get-grammar-production-by-number
+ production-number)))
+ (let ((production-lhs (car production))
+ (production-rhs (car (cdr production)))
+ (popped-items-contents))
+ (unless (equal
+ production-rhs
+ (list %s--e-identifier))
+ (let ((pop-items (* 2 (length production-rhs)))
+ (popped-items 0)
+ (popped-item))
+ (while (< popped-items pop-items)
+ (setq popped-item (pop pushdown-list))
+ (when (and
+ (listp popped-item)
+ (%s--valid-symbol-p
+ (car popped-item)))
+ (push
popped-item
- translation-symbol-table)
+ popped-items-contents))
+ (setq popped-items (1+ popped-items)))))
+ (push production-number output)
+
+ (let ((popped-items-meta-contents)
+ (all-expanded t))
+ ;; Collect arguments for translation
+ (dolist (popped-item popped-items-contents)
+ (if (and
+ (listp popped-item)
+ (cdr popped-item))
+ ;; If item is a terminal, use it's literal
value
(push
- (gethash
- popped-item
- translation-symbol-table)
+ (%s-lex-analyzer--get-function
+ popped-item)
popped-items-meta-contents)
- (setq
- all-expanded
- nil)
- (push
- nil
- popped-items-meta-contents))))
- (setq
- popped-items-meta-contents
- (nreverse popped-items-meta-contents))
-
- ;; Perform translation at reduction if specified
- (if
- (%s--get-grammar-translation-by-number
- production-number)
- (let ((partial-translation
- (funcall
- (%s--get-grammar-translation-by-number
- production-number)
- popped-items-meta-contents)))
- (puthash
- production-lhs
- partial-translation
- translation-symbol-table)
- (setq
- translation
- partial-translation))
-
- ;; When no translation is specified just use
arguments as translation
- (when all-expanded
- (let ((partial-translation
- popped-items-meta-contents))
- (puthash
- production-lhs
- partial-translation
- translation-symbol-table)
- (setq
- translation
- partial-translation)))))
-
- (let ((new-table-index (car pushdown-list)))
- (let ((goto-table
- (gethash
- new-table-index
- %s--goto-tables)))
- (let ((goto-table-length
- (length goto-table))
- (goto-index 0)
- (searching-match t)
- (next-index))
-
- (while (and
- searching-match
- (< goto-index goto-table-length))
- (let ((goto-item (nth goto-index goto-table)))
- (let ((goto-item-symbol (list (car goto-item)))
- (goto-item-next-index (car (cdr
goto-item))))
-
- (when (equal
- goto-item-symbol
- production-lhs)
- (setq next-index goto-item-next-index)
- (setq searching-match nil))))
-
- (setq goto-index (1+ goto-index)))
-
- (when next-index
- (push production-lhs pushdown-list)
- (push next-index pushdown-list)))))))))
-
- ((equal action-match '(accept))
- ;; (d) If f(u) = accept, we halt and declare the string
- ;; in the output buffer to be the right parse of the
original
- ;; input string.
-
- (setq accept t))"
+ (if (gethash
+ popped-item
+ translation-symbol-table)
+ (push
+ (gethash
+ popped-item
+ translation-symbol-table)
+ popped-items-meta-contents)
+ (setq
+ all-expanded
+ nil)
+ (push
+ nil
+ popped-items-meta-contents))))
+ (setq
+ popped-items-meta-contents
+ (nreverse popped-items-meta-contents))
+
+ ;; Perform translation at reduction if specified
+ (if
+ (%s--get-grammar-translation-by-number
+ production-number)
+ (let ((partial-translation
+ (funcall
+ (%s--get-grammar-translation-by-number
+ production-number)
+ popped-items-meta-contents)))
+ (puthash
+ production-lhs
+ partial-translation
+ translation-symbol-table)
+ (setq
+ translation
+ partial-translation))
+
+ ;; When no translation is specified just use
arguments as translation
+ (when all-expanded
+ (let ((partial-translation
+ popped-items-meta-contents))
+ (puthash
+ production-lhs
+ partial-translation
+ translation-symbol-table)
+ (setq
+ translation
+ partial-translation)))))
+
+ (let ((new-table-index (car pushdown-list)))
+ (let ((goto-table
+ (gethash
+ new-table-index
+ %s--goto-tables)))
+ (let ((goto-table-length
+ (length goto-table))
+ (goto-index 0)
+ (searching-match t)
+ (next-index))
+
+ (while (and
+ searching-match
+ (< goto-index goto-table-length))
+ (let ((goto-item (nth goto-index goto-table)))
+ (let ((goto-item-symbol (list (car
goto-item)))
+ (goto-item-next-index (car (cdr
goto-item))))
+
+ (when (equal
+ goto-item-symbol
+ production-lhs)
+ (setq next-index goto-item-next-index)
+ (setq searching-match nil))))
+
+ (setq goto-index (1+ goto-index)))
+
+ (when next-index
+ (push production-lhs pushdown-list)
+ (push next-index pushdown-list)))))))))
+
+ ((equal action-match '(accept))
+ ;; (d) If f(u) = accept, we halt and declare the string
+ ;; in the output buffer to be the right parse of the
original
+ ;; input string.
+
+ (setq accept t))"
namespace
namespace
namespace
@@ -733,22 +747,30 @@
namespace))
(insert "
- (t (error
- \"Invalid action-match: %s!\"
- action-match))))))))
- (unless accept
- (error
- \"Parsed entire string without getting accepting! Output: %s\"
- (reverse output)))
- (when history
- (setq history (reverse history)))
- (when output
- (setq output (reverse output)))
- (list
- output
- translation
- translation-symbol-table
- history)))\n")
+ (t (error
+ \"Invalid action-match: %s!\"
+ action-match))))))))
+ (unless accept
+ (error
+ \"Parsed entire string without getting accepting! Output: %s\"
+ (reverse output)))
+ (when history
+ (setq history (reverse history)))
+ (when output
+ (setq output (reverse output)))
+ (let ((translation-symbol-table-list))
+ (when translation-symbol-table
+ (maphash
+ (lambda (key value)
+ (push
+ `(,key ,value)
+ translation-symbol-table-list))
+ translation-symbol-table))
+ (list
+ output
+ translation
+ translation-symbol-table-list
+ history)))))\n")
;; Parse
(insert
diff --git a/parser-generator-lr.el b/parser-generator-lr.el
index 1b625f4..bb25210 100644
--- a/parser-generator-lr.el
+++ b/parser-generator-lr.el
@@ -919,397 +919,408 @@
pushdown-list
output
translation
- translation-symbol-table
+ translation-symbol-table-list
history)
- "Perform a LR-parse via lex-analyzer, optionally at INPUT-TAPE-INDEX with
PUSHDOWN-LIST, OUTPUT, TRANSLATION, TRANSLATION-SYMBOL-TABLE and HISTORY."
+ "Perform a LR-parse via lex-analyzer, optionally at INPUT-TAPE-INDEX with
PUSHDOWN-LIST, OUTPUT, TRANSLATION, TRANSLATION-SYMBOL-TABLE-LIST and HISTORY."
(unless input-tape-index
(setq input-tape-index 1))
(unless pushdown-list
(push 0 pushdown-list))
- (unless translation-symbol-table
- (setq
- translation-symbol-table
- (make-hash-table :test 'equal)))
+ (let ((translation-symbol-table
+ (make-hash-table :test 'equal)))
+ (when translation-symbol-table-list
+ (dolist
+ (item translation-symbol-table-list)
+ (puthash
+ (nth 0 item)
+ (nth 1 item)
+ translation-symbol-table)))
- (if (and
- input-tape-index
- (> input-tape-index 1))
- (setq
- parser-generator-lex-analyzer--index
- input-tape-index)
- (parser-generator-lex-analyzer--reset))
-
- ;; Make sure tables exists
- (unless parser-generator-lr--action-tables
- (error "Missing action-tables for grammar!"))
- (unless parser-generator-lr--goto-tables
- (error "Missing GOTO-tables for grammar!"))
-
- (let ((accept)
- (pre-index 0))
- (while (not accept)
-
- ;; Save history when index has changed to enable incremental parsing /
translating
- (when
- (>
- parser-generator-lex-analyzer--index
- pre-index)
- ;; We make a copy of the hash-table here to avoid passing same
- ;; hash-table every-time with pointer
- (let ((translation-symbol-table-copy
- (make-hash-table :test 'equal)))
- (maphash
- (lambda (key value)
- (puthash
- key
- value
- translation-symbol-table-copy))
- translation-symbol-table)
- (push
- `(,parser-generator-lex-analyzer--index
- ,pushdown-list
- ,output
- ,translation
- ,translation-symbol-table-copy)
- history)
- (setq
- pre-index
- parser-generator-lex-analyzer--index)))
-
- ;; (1) The look-ahead string u, consisting of the next k input symbols,
is determined.
- (let ((look-ahead
- (parser-generator-lex-analyzer--peek-next-look-ahead))
- (look-ahead-full))
-
- ;; Save token stream indexes in separate variable if needed later
- (setq look-ahead-full look-ahead)
-
- ;; Create simplified look-ahead for logic below
- (setq look-ahead nil)
- (dolist (look-ahead-item look-ahead-full)
- (if (listp look-ahead-item)
- (push (car look-ahead-item) look-ahead)
- (push look-ahead-item look-ahead)))
- (setq look-ahead (nreverse look-ahead))
+ (if (and
+ input-tape-index
+ (> input-tape-index 1))
+ (setq
+ parser-generator-lex-analyzer--index
+ input-tape-index)
+ (parser-generator-lex-analyzer--reset))
- (parser-generator--debug
- (message "look-ahead: %s" look-ahead)
- (message "look-ahead-full: %s" look-ahead-full))
-
- (let ((table-index
- (car pushdown-list)))
- (let ((action-table
- (gethash
- table-index
- parser-generator-lr--action-tables)))
-
- (unless action-table
- (error
- "Action-table with index %s is empty! Push-down-list: %s"
- table-index
- pushdown-list))
+ ;; Make sure tables exists
+ (unless parser-generator-lr--action-tables
+ (error "Missing action-tables for grammar!"))
+ (unless parser-generator-lr--goto-tables
+ (error "Missing GOTO-tables for grammar!"))
- (parser-generator--debug
- (message
- "Action-table %d: %s"
- table-index
- action-table))
-
- (let ((action-match nil)
- (action-table-length (length action-table))
- (action-index 0)
- (possible-look-aheads))
-
- ;; (2) The parsing action f of the table on top of the pushdown
list is applied to the lookahead string u.
- (while (and
- (not action-match)
- (< action-index action-table-length))
- (let ((action (nth action-index action-table)))
- (let ((action-look-ahead (car action)))
- (push
- action-look-ahead
- possible-look-aheads)
- (when
- (equal
- action-look-ahead
- look-ahead)
- (setq
- action-match
- (cdr action)))
- (when
- (and
- (=
- parser-generator--look-ahead-number
- 0)
- (not
- action-look-ahead))
- ;; LR(0) reduce actions occupy entire row
- ;; and is applied regardless of look-ahead
- (setq
- action-match
- (cdr action))))
- (setq
- action-index
- (1+ action-index))))
+ (let ((accept)
+ (pre-index 0))
+ (while (not accept)
- (unless action-match
- ;; (c) If f(u) = error, we halt parsing (and, in practice
- ;; transfer to an error recovery routine).
+ ;; Save history when index has changed to enable incremental parsing /
translating
+ (when
+ (>
+ parser-generator-lex-analyzer--index
+ pre-index)
+ ;; We make a copy of the hash-table here to avoid passing same
+ ;; hash-table every-time with pointer
+ (let ((translation-symbol-table-list))
+ (maphash
+ (lambda (key value)
+ (push
+ `(,key ,value)
+ translation-symbol-table-list))
+ translation-symbol-table)
+ (push
+ `(,parser-generator-lex-analyzer--index
+ ,pushdown-list
+ ,output
+ ,translation
+ ,translation-symbol-table-list)
+ history)
+ (setq
+ pre-index
+ parser-generator-lex-analyzer--index)))
+
+ ;; (1) The look-ahead string u, consisting of the next k input
symbols, is determined.
+ (let ((look-ahead
+ (parser-generator-lex-analyzer--peek-next-look-ahead))
+ (look-ahead-full))
+
+ ;; Save token stream indexes in separate variable if needed later
+ (setq look-ahead-full look-ahead)
+
+ ;; Create simplified look-ahead for logic below
+ (setq look-ahead nil)
+ (dolist (look-ahead-item look-ahead-full)
+ (if (listp look-ahead-item)
+ (push (car look-ahead-item) look-ahead)
+ (push look-ahead-item look-ahead)))
+ (setq look-ahead (nreverse look-ahead))
+ (parser-generator--debug
+ (message "look-ahead: %s" look-ahead)
+ (message "look-ahead-full: %s" look-ahead-full))
+
+ (let ((table-index
+ (car pushdown-list)))
+ (let ((action-table
+ (gethash
+ table-index
+ parser-generator-lr--action-tables)))
+
+ (unless action-table
(error
- (format
- "Invalid syntax! Expected one of %s found %s at %s"
- possible-look-aheads
- look-ahead
- parser-generator-lex-analyzer--index)
- possible-look-aheads
- look-ahead
- parser-generator-lex-analyzer--index))
+ "Action-table with index %s is empty! Push-down-list: %s"
+ table-index
+ pushdown-list))
(parser-generator--debug
- (message "action-table: %s" action-table)
- (message "action-match: %s" action-match))
-
- (cond
-
- ((equal action-match '(shift))
- ;; (a) If f(u) = shift, then the next input symbol, say a
- ;; is removed from the input and shifted onto the pushdown
list.
- ;; The goto function g of the table on top of the pushdown list
- ;; is applied to a to determine the new table to be placed on
- ;; top of the pushdown list. We then return to step(1). If
- ;; there is no next input symbol or g(a) is undefined, halt
- ;; and declare error.
-
- (let ((a (list (car look-ahead)))
- (a-full (list (car look-ahead-full))))
- (parser-generator--debug
- (message "shift a: %s" a)
- (message "shift a-full: %s" a-full))
- (let ((goto-table
- (gethash
- table-index
- parser-generator-lr--goto-tables)))
- (let ((goto-table-length (length goto-table))
- (goto-index 0)
- (searching-match t)
- (next-index)
- (possible-look-aheads))
-
- (while (and
- searching-match
- (< goto-index goto-table-length))
- (let ((goto-item (nth goto-index goto-table)))
- (let ((goto-item-symbol (list (car goto-item)))
- (goto-item-next-index (car (cdr goto-item))))
- (push goto-item-symbol possible-look-aheads)
+ (message
+ "Action-table %d: %s"
+ table-index
+ action-table))
- (parser-generator--debug
- (message "shift goto-item: %s" goto-item)
- (message "shift goto-item-symbol: %s"
goto-item-symbol))
+ (let ((action-match nil)
+ (action-table-length (length action-table))
+ (action-index 0)
+ (possible-look-aheads))
- (when (equal
- goto-item-symbol
- a)
- (setq next-index goto-item-next-index)
- (setq searching-match nil))))
+ ;; (2) The parsing action f of the table on top of the
pushdown list is applied to the lookahead string u.
+ (while (and
+ (not action-match)
+ (< action-index action-table-length))
+ (let ((action (nth action-index action-table)))
+ (let ((action-look-ahead (car action)))
+ (push
+ action-look-ahead
+ possible-look-aheads)
+ (when
+ (equal
+ action-look-ahead
+ look-ahead)
+ (setq
+ action-match
+ (cdr action)))
+ (when
+ (and
+ (=
+ parser-generator--look-ahead-number
+ 0)
+ (not
+ action-look-ahead))
+ ;; LR(0) reduce actions occupy entire row
+ ;; and is applied regardless of look-ahead
+ (setq
+ action-match
+ (cdr action))))
+ (setq
+ action-index
+ (1+ action-index))))
+
+ (unless action-match
+ ;; (c) If f(u) = error, we halt parsing (and, in practice
+ ;; transfer to an error recovery routine).
+
+ (error
+ (format
+ "Invalid syntax! Expected one of %s found %s at %s"
+ possible-look-aheads
+ look-ahead
+ parser-generator-lex-analyzer--index)
+ possible-look-aheads
+ look-ahead
+ parser-generator-lex-analyzer--index))
- (setq goto-index (1+ goto-index)))
+ (parser-generator--debug
+ (message "action-table: %s" action-table)
+ (message "action-match: %s" action-match))
+
+ (cond
+
+ ((equal action-match '(shift))
+ ;; (a) If f(u) = shift, then the next input symbol, say a
+ ;; is removed from the input and shifted onto the pushdown
list.
+ ;; The goto function g of the table on top of the pushdown
list
+ ;; is applied to a to determine the new table to be placed on
+ ;; top of the pushdown list. We then return to step(1). If
+ ;; there is no next input symbol or g(a) is undefined, halt
+ ;; and declare error.
+
+ (let ((a (list (car look-ahead)))
+ (a-full (list (car look-ahead-full))))
+ (parser-generator--debug
+ (message "shift a: %s" a)
+ (message "shift a-full: %s" a-full))
+ (let ((goto-table
+ (gethash
+ table-index
+ parser-generator-lr--goto-tables)))
+ (let ((goto-table-length (length goto-table))
+ (goto-index 0)
+ (searching-match t)
+ (next-index)
+ (possible-look-aheads))
+
+ (while (and
+ searching-match
+ (< goto-index goto-table-length))
+ (let ((goto-item (nth goto-index goto-table)))
+ (let ((goto-item-symbol (list (car goto-item)))
+ (goto-item-next-index (car (cdr goto-item))))
+ (push goto-item-symbol possible-look-aheads)
- (parser-generator--debug
- (message "shift next-index: %s" next-index))
-
- (unless next-index
- (error
- "In shift, found no GOTO-item for %s at %s, expected
one of %s"
- a
- parser-generator-lex-analyzer--index
- possible-look-aheads))
-
- ;; Maybe push both tokens here?
- (push (car a-full) pushdown-list)
- (push next-index pushdown-list)
- (parser-generator-lex-analyzer--pop-token)))))
-
- ((equal (car action-match) 'reduce)
- ;; (b) If f(u) = reduce i and production i is A -> a,
- ;; then 2|a| symbols are removed from the top of the pushdown
- ;; list, and production number i is placed in the output
- ;; buffer. A new table T' is then exposed as the top table
- ;; of the pushdown list, and the goto function of T' is applied
- ;; to A to determine the next table to be placed on top of the
- ;; pushdown list. We place A and this new table on top of the
- ;; the pushdown list and return to step (1)
-
- (let ((production-number (car (cdr action-match))))
-
- (let ((production
- (parser-generator--get-grammar-production-by-number
- production-number)))
- (let ((production-lhs (car production))
- (production-rhs (car (cdr production)))
- (popped-items-contents))
- (parser-generator--debug
- (message "production-lhs: %s" production-lhs)
- (message "production-rhs: %s" production-rhs))
- (unless (equal
- production-rhs
- (list parser-generator--e-identifier))
- (let ((pop-items (* 2 (length production-rhs)))
- (popped-items 0)
- (popped-item))
- (while (< popped-items pop-items)
- (setq popped-item (pop pushdown-list))
+ (parser-generator--debug
+ (message "shift goto-item: %s" goto-item)
+ (message "shift goto-item-symbol: %s"
goto-item-symbol))
+
+ (when (equal
+ goto-item-symbol
+ a)
+ (setq next-index goto-item-next-index)
+ (setq searching-match nil))))
+
+ (setq goto-index (1+ goto-index)))
+
+ (parser-generator--debug
+ (message "shift next-index: %s" next-index))
+
+ (unless next-index
+ (error
+ "In shift, found no GOTO-item for %s at %s,
expected one of %s"
+ a
+ parser-generator-lex-analyzer--index
+ possible-look-aheads))
+
+ ;; Maybe push both tokens here?
+ (push (car a-full) pushdown-list)
+ (push next-index pushdown-list)
+ (parser-generator-lex-analyzer--pop-token)))))
+
+ ((equal (car action-match) 'reduce)
+ ;; (b) If f(u) = reduce i and production i is A -> a,
+ ;; then 2|a| symbols are removed from the top of the pushdown
+ ;; list, and production number i is placed in the output
+ ;; buffer. A new table T' is then exposed as the top table
+ ;; of the pushdown list, and the goto function of T' is
applied
+ ;; to A to determine the next table to be placed on top of
the
+ ;; pushdown list. We place A and this new table on top of the
+ ;; the pushdown list and return to step (1)
+
+ (let ((production-number (car (cdr action-match))))
+
+ (let ((production
+ (parser-generator--get-grammar-production-by-number
+ production-number)))
+ (let ((production-lhs (car production))
+ (production-rhs (car (cdr production)))
+ (popped-items-contents))
+ (parser-generator--debug
+ (message "production-lhs: %s" production-lhs)
+ (message "production-rhs: %s" production-rhs))
+ (unless (equal
+ production-rhs
+ (list parser-generator--e-identifier))
+ (let ((pop-items (* 2 (length production-rhs)))
+ (popped-items 0)
+ (popped-item))
+ (while (< popped-items pop-items)
+ (setq popped-item (pop pushdown-list))
+ (parser-generator--debug
+ (message "popped-item: %s" popped-item))
+ (when (and
+ (listp popped-item)
+ (parser-generator--valid-symbol-p
+ (car popped-item)))
+ (push
+ popped-item
+ popped-items-contents))
+ (setq popped-items (1+ popped-items)))))
+ (push production-number output)
+
+ (let ((popped-items-meta-contents)
+ (all-expanded t))
+ ;; Collect arguments for translation
+ (dolist (popped-item popped-items-contents)
(parser-generator--debug
- (message "popped-item: %s" popped-item))
- (when (and
- (listp popped-item)
- (parser-generator--valid-symbol-p
- (car popped-item)))
- (push
- popped-item
- popped-items-contents))
- (setq popped-items (1+ popped-items)))))
- (push production-number output)
-
- (let ((popped-items-meta-contents)
- (all-expanded t))
- ;; Collect arguments for translation
- (dolist (popped-item popped-items-contents)
+ (message
+ "popped-item: %s"
+ popped-item))
+ (if (and
+ (listp popped-item)
+ (cdr popped-item))
+ ;; If item is a terminal, use it's literal
value
+ (push
+ (parser-generator-lex-analyzer--get-function
+ popped-item)
+ popped-items-meta-contents)
+ (if (gethash
+ popped-item
+ translation-symbol-table)
+ (push
+ (gethash
+ popped-item
+ translation-symbol-table)
+ popped-items-meta-contents)
+ (setq
+ all-expanded
+ nil)
+ (push
+ nil
+ popped-items-meta-contents))))
+ (setq
+ popped-items-meta-contents
+ (nreverse popped-items-meta-contents))
(parser-generator--debug
(message
- "popped-item: %s"
- popped-item))
- (if (and
- (listp popped-item)
- (cdr popped-item))
- ;; If item is a terminal, use it's literal value
- (push
- (parser-generator-lex-analyzer--get-function
- popped-item)
- popped-items-meta-contents)
- (if (gethash
- popped-item
+ "Production arguments: %s -> %s = %s"
+ production-lhs
+ production-rhs
+ popped-items-meta-contents))
+
+ ;; Perform translation at reduction if specified
+ (if
+
(parser-generator--get-grammar-translation-by-number
+ production-number)
+ (let ((partial-translation
+ (funcall
+
(parser-generator--get-grammar-translation-by-number
+ production-number)
+ popped-items-meta-contents)))
+ (parser-generator--debug
+ (message
+ "translation-symbol-table: %s = %s"
+ production-lhs
+ partial-translation))
+ (puthash
+ production-lhs
+ partial-translation
translation-symbol-table)
- (push
- (gethash
- popped-item
- translation-symbol-table)
- popped-items-meta-contents)
- (setq
- all-expanded
- nil)
- (push
- nil
- popped-items-meta-contents))))
- (setq
- popped-items-meta-contents
- (nreverse popped-items-meta-contents))
- (parser-generator--debug
- (message
- "Production arguments: %s -> %s = %s"
- production-lhs
- production-rhs
- popped-items-meta-contents))
-
- ;; Perform translation at reduction if specified
- (if
-
(parser-generator--get-grammar-translation-by-number
- production-number)
- (let ((partial-translation
- (funcall
-
(parser-generator--get-grammar-translation-by-number
- production-number)
- popped-items-meta-contents)))
- (parser-generator--debug
- (message
- "translation-symbol-table: %s = %s"
- production-lhs
- partial-translation))
- (puthash
- production-lhs
- partial-translation
- translation-symbol-table)
- (setq
- translation
- partial-translation))
+ (setq
+ translation
+ partial-translation))
+
+ ;; When no translation is specified just use
arguments as translation
+ (when all-expanded
+ (let ((partial-translation
+ popped-items-meta-contents))
+ (parser-generator--debug
+ (message
+ "translation-symbol-table: %s = %s (generic)"
+ production-lhs
+ partial-translation))
+ (puthash
+ production-lhs
+ partial-translation
+ translation-symbol-table)
+ (setq
+ translation
+ partial-translation)))))
- ;; When no translation is specified just use
arguments as translation
- (when all-expanded
- (let ((partial-translation
- popped-items-meta-contents))
- (parser-generator--debug
- (message
- "translation-symbol-table: %s = %s (generic)"
- production-lhs
- partial-translation))
- (puthash
- production-lhs
- partial-translation
- translation-symbol-table)
- (setq
- translation
- partial-translation)))))
-
- (let ((new-table-index (car pushdown-list)))
- (let ((goto-table
- (gethash
- new-table-index
- parser-generator-lr--goto-tables)))
- (let ((goto-table-length
- (length goto-table))
- (goto-index 0)
- (searching-match t)
- (next-index))
-
- (while (and
- searching-match
- (< goto-index goto-table-length))
- (let ((goto-item (nth goto-index goto-table)))
- (let ((goto-item-symbol (list (car goto-item)))
- (goto-item-next-index (car (cdr
goto-item))))
- (parser-generator--debug
- (message "reduce goto-item: %s" goto-item)
- (message "reduce goto-item-symbol: %s"
goto-item-symbol))
+ (let ((new-table-index (car pushdown-list)))
+ (let ((goto-table
+ (gethash
+ new-table-index
+ parser-generator-lr--goto-tables)))
+ (let ((goto-table-length
+ (length goto-table))
+ (goto-index 0)
+ (searching-match t)
+ (next-index))
+
+ (while (and
+ searching-match
+ (< goto-index goto-table-length))
+ (let ((goto-item (nth goto-index goto-table)))
+ (let ((goto-item-symbol (list (car
goto-item)))
+ (goto-item-next-index (car (cdr
goto-item))))
+ (parser-generator--debug
+ (message "reduce goto-item: %s" goto-item)
+ (message "reduce goto-item-symbol: %s"
goto-item-symbol))
- (when (equal
- goto-item-symbol
- production-lhs)
- (setq next-index goto-item-next-index)
- (setq searching-match nil))))
+ (when (equal
+ goto-item-symbol
+ production-lhs)
+ (setq next-index goto-item-next-index)
+ (setq searching-match nil))))
- (setq goto-index (1+ goto-index)))
+ (setq goto-index (1+ goto-index)))
- (parser-generator--debug
- (message "reduce next-index: %s" next-index))
-
- (when next-index
- (push production-lhs pushdown-list)
- (push next-index pushdown-list)))))))))
-
- ((equal action-match '(accept))
- ;; (d) If f(u) = accept, we halt and declare the string
- ;; in the output buffer to be the right parse of the
original
- ;; input string.
-
- (setq accept t))
-
- (t (error
- "Invalid action-match: %s!"
- action-match))))))))
- (unless accept
- (error
- "Parsed entire string without getting accepting! Output: %s"
- (reverse output)))
- (when history
- (setq history (reverse history)))
- (when output
- (setq output (reverse output)))
- (list
- output
- translation
- translation-symbol-table
- history)))
+ (parser-generator--debug
+ (message "reduce next-index: %s" next-index))
+
+ (when next-index
+ (push production-lhs pushdown-list)
+ (push next-index pushdown-list)))))))))
+
+ ((equal action-match '(accept))
+ ;; (d) If f(u) = accept, we halt and declare the string
+ ;; in the output buffer to be the right parse of the
original
+ ;; input string.
+
+ (setq accept t))
+
+ (t (error
+ "Invalid action-match: %s!"
+ action-match))))))))
+ (unless accept
+ (error
+ "Parsed entire string without getting accepting! Output: %s"
+ (reverse output)))
+ (when history
+ (setq history (reverse history)))
+ (when output
+ (setq output (reverse output)))
+ (let ((translation-symbol-table-list))
+ (when translation-symbol-table
+ (maphash
+ (lambda (key value)
+ (push
+ `(,key ,value)
+ translation-symbol-table-list))
+ translation-symbol-table))
+ (list
+ output
+ translation
+ translation-symbol-table-list
+ history)))))
(provide 'parser-generator-lr)
diff --git a/test/parser-generator-lr-export-test.el
b/test/parser-generator-lr-export-test.el
index 11b644c..92bf701 100644
--- a/test/parser-generator-lr-export-test.el
+++ b/test/parser-generator-lr-export-test.el
@@ -60,9 +60,13 @@
(should
(equal
t
+ (fboundp 'ba-parse)))
+ (should
+ (equal
+ t
(fboundp 'ba-translate))))
- (when (fboundp 'pa-translate)
+ (when (fboundp 'ba-parse)
(should
(equal
'(2 2 2 1 1)
@@ -164,6 +168,7 @@
;; Export parser
(let ((export (parser-generator-lr-export-to-elisp "e--")))
+ (message "export:\n%s\n" export)
(with-temp-buffer
(insert export)
(eval-buffer)
