branch: externals/parser-generator
commit e904d4687b7b5fbbb0fff9d3ec5a3cd4ea827609
Author: Christian Johansson <christ...@cvj.se>
Commit: Christian Johansson <christ...@cvj.se>
Moved LR-parser exporter to stand-alone file and added documentation about
export
---
Makefile | 8 +-
README.md | 2 +-
docs/Syntax-Analysis/LR0.md | 63 ++-
docs/Syntax-Analysis/LRk.md | 57 ++-
parser-generator-lr-export.el | 821 ++++++++++++++++++++++++++++++++
parser-generator-lr.el | 806 -------------------------------
test/parser-generator-lr-export-test.el | 74 +++
test/parser-generator-lr-test.el | 52 +-
8 files changed, 1021 insertions(+), 862 deletions(-)
diff --git a/Makefile b/Makefile
index 999e63b..4965a61 100644
--- a/Makefile
+++ b/Makefile
@@ -4,7 +4,7 @@ ifdef emacs
endif
EMACS_CMD := $(EMACS) -Q -batch -L . -L test/
-EL := parser-generator.el parser-generator-lex-analyzer.el
parser-generator-lr.el test/parser-generator-test.el
test/parser-generator-lex-analyzer-test.el test/parser-generator-lr-test.el
+EL := parser-generator.el parser-generator-lex-analyzer.el
parser-generator-lr.el parser-generator-lr-export.el
test/parser-generator-test.el test/parser-generator-lex-analyzer-test.el
test/parser-generator-lr-export-test.el test/parser-generator-lr-test.el
ELC := $(EL:.el=.elc)
.PHONY: clean
@@ -27,5 +27,9 @@ test-lex-analyzer:
test-lr:
$(EMACS_CMD) -l test/parser-generator-lr-test.el -f
"parser-generator-lr-test"
+.PHONY: test-lr-export
+test-lr-export:
+ $(EMACS_CMD) -l test/parser-generator-lr-export-test.el -f
"parser-generator-lr-export-test"
+
.PHONY: tests
-tests: test test-lex-analyzer test-lr
+tests: test test-lex-analyzer test-lr test-lr-export
diff --git a/README.md b/README.md
index eda19bd..e2b7477 100644
--- a/README.md
+++ b/README.md
@@ -3,7 +3,7 @@
[](https://www.gnu.org/licenses/gpl-3.0.txt)
[](https://travis-ci.org/cjohansson/emacs-parser-generator)
-The idea of this plugin is to provide functions for various kinds of
context-free grammar parser generations with support for
syntax-directed-translations (SDT) and semantic actions (SA) and the
possibility of exporting parsers and translators (as code) to enable
plugin-agnostic usage. This project is also about implementing algorithms
described in the book `The Theory of Parsing, Translation and Compiling (Volume
1)` by `Alfred V. Aho and Jeffrey D. Ullman` (1972). Also this project is [...]
+The idea of this plugin is to provide functions for various kinds of
context-free grammar parser generations with support for
syntax-directed-translations (SDT) and semantic actions (SA) and the
possibility of exporting parsers and translators (as elisp code) to enable
plugin-agnostic usage. This project is also about implementing algorithms
described in the book `The Theory of Parsing, Translation and Compiling (Volume
1)` by `Alfred V. Aho and Jeffrey D. Ullman` (1972). Also this proje [...]
This is just started, so most stuff are *WIP*.
diff --git a/docs/Syntax-Analysis/LR0.md b/docs/Syntax-Analysis/LR0.md
index 5dd9262..39c8a4d 100644
--- a/docs/Syntax-Analysis/LR0.md
+++ b/docs/Syntax-Analysis/LR0.md
@@ -2,7 +2,7 @@
LR(k) parser is a Left-to-right, Rightmost derivation in reverse without a
look-ahead invented by Donald Knuth.
-This library contains functions to parse, translate, validate grammars as well
as exporting parser, parser/translators as stand-alone emacs-lisp code. *WIP*
+This library contains functions to parse, translate, validate grammars as well
as exporting parser, parser/translators as stand-alone emacs-lisp code.
## LR Item
@@ -111,4 +111,65 @@ Each production RHS can optionally contain a
lambda-expression that will be call
(kill-buffer))
```
+## Export
+
+The export should be executed after a parser has been generated, example:
+
+```emacs-lisp
+(let ((buffer (generate-new-buffer "*a*")))
+ (switch-to-buffer buffer)
+ (kill-region (point-min) (point-max))
+ (insert "1+1")
+
+ (parser-generator-set-grammar
+ '((S E B) ("*" "+" "0" "1") ((S (E $)) (E (E "*" B) (E "+" B) (B)) (B ("0")
("1"))) S))
+ (parser-generator-set-look-ahead-number 0)
+ (parser-generator-process-grammar)
+ (parser-generator-lr-generate-parser-tables)
+
+ ;; Setup lex-analyzer
+ (setq
+ parser-generator-lex-analyzer--function
+ (lambda (index)
+ (with-current-buffer buffer
+ (when (<= (+ index 1) (point-max))
+ (let ((start index)
+ (end (+ index 1)))
+ (let ((token (buffer-substring-no-properties start end)))
+ `(,token ,start . ,end)))))))
+ (setq
+ parser-generator-lex-analyzer--get-function
+ (lambda (token)
+ (with-current-buffer buffer
+ (let ((start (car (cdr token)))
+ (end (cdr (cdr token))))
+ (when (<= end (point-max))
+ (buffer-substring-no-properties
+ start
+ end))))))
+
+ (should
+ (equal
+ '(5 3 5 2)
+ (parser-generator-lr-parse)))
+
+ ;; Export parser
+ (let ((export (parser-generator-lr-export-to-elisp "e--")))
+
+ (with-temp-buffer
+ (insert export)
+ (eval-buffer)
+ (should
+ (equal
+ t
+ (fboundp 'e---parse)))
+
+ (when (fboundp 'e---parse)
+ (should
+ (equal
+ '(5 3 5 2)
+ (e---parse))))
+ (message "Passed parse for exported parser"))))
+```
+
[Back to syntax analysis](../Syntax-Analysis.md)
diff --git a/docs/Syntax-Analysis/LRk.md b/docs/Syntax-Analysis/LRk.md
index 70b3cd0..25fa359 100644
--- a/docs/Syntax-Analysis/LRk.md
+++ b/docs/Syntax-Analysis/LRk.md
@@ -2,7 +2,7 @@
LR(k) parser is a Left-to-right, Rightmost derivation in reverse with
look-ahead number k invented by Donald Knuth.
-This library contains functions to parse, translate, validate grammars as well
as exporting parser, parser/translators as stand-alone emacs-lisp code. *WIP*
+This library contains functions to parse, translate, validate grammars as well
as exporting parser, parser/translators as stand-alone emacs-lisp code.
## LR Item
@@ -186,4 +186,59 @@ Each production RHS can optionally contain a
lambda-expression that will be call
(kill-buffer buffer))
```
+## Export
+
+The export should be executed after a parser has been generated, example:
+
+```emacs-lisp
+ ;; Generate parser
+ (parser-generator-set-grammar
+ '((Sp S) (a b) ((Sp S) (S (S a S b)) (S e)) Sp))
+ (parser-generator-set-look-ahead-number 1)
+ (parser-generator-process-grammar)
+ (parser-generator-lr-generate-parser-tables)
+ (setq
+ parser-generator-lex-analyzer--function
+ (lambda (index)
+ (let* ((string '((a 1 . 2) (a 2 . 3) (b 3 . 4) (b 4 . 5)))
+ (string-length (length string))
+ (max-index index)
+ (tokens))
+ (while (and
+ (< (1- index) string-length)
+ (< (1- index) max-index))
+ (push (nth (1- index) string) tokens)
+ (setq index (1+ index)))
+ (nreverse tokens))))
+ (setq
+ parser-generator-lex-analyzer--get-function
+ (lambda (token)
+ (car token)))
+
+ ;; Test parser
+ (should
+ (equal
+ '(2 2 2 1 1)
+ (parser-generator-lr-parse)))
+
+ ;; Export parser
+ (let ((export (parser-generator-lr-export-to-elisp "e--")))
+
+ (with-temp-buffer
+ (insert export)
+ (eval-buffer)
+ (should
+ (equal
+ t
+ (fboundp 'e---parse)))
+
+ (when (fboundp 'e---parse)
+ (should
+ (equal
+ '(2 2 2 1 1)
+ (e---parse))))
+ (message "Passed parse for exported parser")))
+```
+
+
[Back to syntax analysis](../Syntax-Analysis.md)
diff --git a/parser-generator-lr-export.el b/parser-generator-lr-export.el
new file mode 100644
index 0000000..9ecd2b7
--- /dev/null
+++ b/parser-generator-lr-export.el
@@ -0,0 +1,821 @@
+;;; parser-generator-lr-export.el --- Export LR(k) Parser -*- lexical-binding:
t -*-
+
+
+;;; Commentary:
+
+
+;;; Code:
+
+
+(require 'parser-generator-lr)
+
+(defun parser-generator-lr-export-to-elisp (namespace)
+ "Export parser with NAMESPACE."
+
+ ;; Make sure all requisites are defined
+ (unless parser-generator-lr--action-tables
+ (error "Missing generated ACTION-tables!"))
+ (unless parser-generator-lr--goto-tables
+ (error "Missing generated GOTO-tables!"))
+ (unless parser-generator--table-productions-number-reverse
+ (error "Table for reverse production-numbers is undefined!"))
+ (unless parser-generator--table-look-aheads-p
+ (error "Table for valid look-aheads is undefined!"))
+ (unless parser-generator--look-ahead-number
+ (error "Missing a look-ahead number!"))
+ (unless parser-generator--e-identifier
+ (error "Missing definition for e-identifier!"))
+ (unless parser-generator--eof-identifier
+ (error "Missing definition for EOF-identifier!"))
+ (unless parser-generator--table-non-terminal-p
+ (error "Table for non-terminals is undefined!"))
+ (unless parser-generator--table-terminal-p
+ (error "Table for terminals is undefined!"))
+ (unless parser-generator--table-translations
+ (error "Table for translations by production-number is undefined!"))
+ (unless parser-generator-lex-analyzer--get-function
+ (error "Missing lex-analyzer get function!"))
+ (unless parser-generator-lex-analyzer--function
+ (error "Missing lex-analyzer function!"))
+
+ (let ((code))
+ (with-temp-buffer
+ (goto-char (point-min))
+
+ ;; Header
+ (insert
+ (format
+ ";;; %s.el --- Exported Emacs Parser Generator -*- lexical-binding: t
-*-\n\n\n"
+ namespace))
+ (insert ";;; Commentary:\n\n\n;;; Code:\n\n\n")
+
+ (insert ";;; Constants:\n\n\n")
+
+ ;; Action-tables
+ (insert
+ (format
+ "(defconst\n %s--action-tables\n %s\n \"Generated
action-tables.\")\n\n"
+ namespace
+ parser-generator-lr--action-tables))
+
+ ;; Goto-tables
+ (insert
+ (format
+ "(defconst\n %s--goto-tables\n %s\n \"Generated goto-tables.\")\n\n"
+ namespace
+ parser-generator-lr--goto-tables))
+
+ ;; Table production-number
+ (insert
+ (format
+ "(defconst\n %s--table-productions-number-reverse\n %s\n
\"Hash-table indexed by production-number and value is production.\")\n\n"
+ namespace
+ parser-generator--table-productions-number-reverse))
+
+ ;; Table look-aheads
+ (insert
+ (format
+ "(defconst\n %s--table-look-aheads\n %s\n \"Hash-table of valid
look-aheads.\")\n\n"
+ namespace
+ parser-generator--table-look-aheads-p))
+
+ ;; Table terminals
+ (insert
+ (format
+ "(defconst\n %s--table-terminal-p\n %s\n \"Hash-table of valid
terminals.\")\n\n"
+ namespace
+ parser-generator--table-non-terminal-p))
+
+ ;; Table non-terminals
+ (insert
+ (format
+ "(defconst\n %s--table-non-terminal-p\n %s\n \"Hash-table of valid
non-terminals.\")\n\n"
+ namespace
+ parser-generator--table-non-terminal-p))
+
+ ;; Table translations
+ (insert
+ (format
+ "(defconst\n %s--table-translations\n %s\n \"Hash-table of
translations.\")\n\n"
+ namespace
+ parser-generator--table-translations))
+
+ ;; Lex-Analyzer Get Function
+ (insert
+ (format
+ "(defconst\n %s-lex-analyzer--get-function\n (lambda %s %s)\n
\"Lex-Analyzer Get Function.\")\n\n"
+ namespace
+ (nth 2 parser-generator-lex-analyzer--get-function)
+ (nth 3 parser-generator-lex-analyzer--get-function)))
+
+ ;; Lex-Analyzer Function
+ (insert
+ (format
+ "(defconst\n %s-lex-analyzer--function\n (lambda %s %s)\n
\"Lex-Analyzer Function.\")\n\n"
+ namespace
+ (nth 2 parser-generator-lex-analyzer--function)
+ (nth 3 parser-generator-lex-analyzer--function)))
+
+ ;; Lex-Analyzer Reset Function
+ (insert
+ (format
+ "(defconst\n %s-lex-analyzer--reset-function\n "
+ namespace))
+ (if parser-generator-lex-analyzer--reset-function
+ (insert
+ (format
+ "(lambda %s %s)\n"
+ (nth 2 parser-generator-lex-analyzer--reset-function)
+ (nth 3 parser-generator-lex-analyzer--reset-function)))
+ (insert "nil\n"))
+ (insert " \"Lex-Analyzer Reset Function.\")\n\n")
+
+ ;; E-identifier
+ (insert
+ (format
+ "(defconst\n %s--e-identifier\n '%s\n \"e-identifier\")\n\n"
+ namespace
+ parser-generator--e-identifier))
+
+ ;; EOF-identifier
+ (insert
+ (format
+ "(defconst\n %s--eof-identifier\n '%s\n \"EOF-identifier.\")\n\n"
+ namespace
+ parser-generator--eof-identifier))
+
+ ;; Look-ahead number
+ (insert
+ (format
+ "(defconst\n %s--look-ahead-number\n %s\n \"Look-ahead
number.\")\n\n"
+ namespace
+ parser-generator--look-ahead-number))
+
+ (insert "\n;;; Variables:\n\n\n")
+
+ ;; Lex-analyzer index
+ (insert
+ (format
+ "(defvar\n %s-lex-analyzer--index\n 0\n \"Current index of
lex-analyzer.\")\n\n"
+ namespace))
+
+ (insert "\n;;; Functions:\n\n\n")
+
+ (insert ";;; Lex-Analyzer:\n\n\n")
+
+ ;; Lex-Analyzer Get Function
+ (insert
+ (format
+ "(defun
+ %s-lex-analyzer--get-function (token)
+ \"Get information about TOKEN.\"
+ (unless
+ %s-lex-analyzer--get-function
+ (error \"Missing lex-analyzer get function!\"))
+ (let ((meta-information))
+ (condition-case
+ error
+ (progn
+ (setq
+ meta-information
+ (funcall
+ %s-lex-analyzer--get-function
+ token)))"
+ namespace
+ namespace
+ namespace))
+ (insert "
+ (error
+ (error
+ \"Lex-analyze failed to get token meta-data of %s, error: %s\"
+ token
+ (car (cdr error)))))
+ (unless meta-information
+ (error \"Could not find any token meta-information for: %s\" token))
+ meta-information))\n")
+
+ ;; Lex-Analyzer Reset Function
+ (insert
+ (format "
+(defun
+ %s-lex-analyzer--reset
+ ()
+ \"Reset Lex-Analyzer.\"
+ (setq
+ %s-lex-analyzer--index
+ 1)
+ (when
+ %s-lex-analyzer--reset-function
+ (funcall
+ %s-lex-analyzer--reset-function)))\n"
+ namespace
+ namespace
+ namespace
+ namespace))
+
+ ;; Lex-Analyzer Peek Next Look Ahead
+ (insert
+ (format "
+(defun
+ %s-lex-analyzer--peek-next-look-ahead
+ ()
+ \"Peek next look-ahead number of tokens via lex-analyzer.\"
+ (let ((look-ahead)
+ (look-ahead-length 0)
+ (index %s-lex-analyzer--index)
+ (k (max
+ 1
+ %s--look-ahead-number)))
+ (while (<
+ look-ahead-length
+ k)
+ (condition-case error
+ (progn
+ (let ((next-look-ahead
+ (funcall
+ %s-lex-analyzer--function
+ index)))
+ (if next-look-ahead
+ (progn
+ (unless (listp (car next-look-ahead))
+ (setq next-look-ahead (list next-look-ahead)))
+ (dolist (next-look-ahead-item next-look-ahead)
+ (when (<
+ look-ahead-length
+ k)
+ (push next-look-ahead-item look-ahead)
+ (setq look-ahead-length (1+ look-ahead-length))
+ (setq index (cdr (cdr next-look-ahead-item))))))
+ (push (list %s--eof-identifier) look-ahead)
+ (setq look-ahead-length (1+ look-ahead-length))
+ (setq index (1+ index)))))"
+ namespace
+ namespace
+ namespace
+ namespace
+ namespace))
+ (insert "
+ (error
+ (error
+ \"Lex-analyze failed to peek next look-ahead at %s, error: %s\"
+ index
+ (car (cdr error))))))
+ (nreverse look-ahead)))\n")
+
+ ;; Lex-Analyzer Pop Token
+ (insert
+ (format "
+(defun
+ %s-lex-analyzer--pop-token ()
+ \"Pop next token via lex-analyzer.\"
+ (let ((iteration 0)
+ (tokens))
+ (while (< iteration 1)
+ (condition-case error
+ (progn
+ (let ((token
+ (funcall
+ %s-lex-analyzer--function
+ %s-lex-analyzer--index)))
+ (when token
+ (unless (listp (car token))
+ (setq token (list token)))
+ (let ((first-token (car token)))
+ (setq
+ %s-lex-analyzer--index
+ (cdr (cdr first-token)))
+ (push first-token tokens)))))"
+ namespace
+ namespace
+ namespace
+ namespace))
+ (insert "
+ (error (error
+ \"Lex-analyze failed to pop token at %s, error: %s\"")
+ (insert (format "
+ %s-lex-analyzer--index
+ (car (cdr error)))))
+ (setq iteration (1+ iteration)))
+ (nreverse tokens)))\n"
+ namespace))
+
+ (insert "\n;;; Syntax-Analyzer / Parser:\n\n\n");
+
+ ;; Get grammar production by number
+ (insert
+ (format "
+(defun
+ %s--get-grammar-production-by-number
+ (production-number)
+ \"If PRODUCTION-NUMBER exist, return it's production.\"
+ (gethash
+ production-number
+ %s--table-productions-number-reverse))\n"
+ namespace
+ namespace))
+
+ ;; Valid symbol p
+ (insert
+ (format "
+(defun
+ %s--valid-symbol-p
+ (symbol)
+ \"Return whether SYMBOL is valid or not.\"
+ (let ((is-valid t))
+ (unless (or
+ (%s--valid-e-p symbol)
+ (%s--valid-eof-p symbol)
+ (%s--valid-non-terminal-p symbol)
+ (%s--valid-terminal-p symbol))
+ (setq is-valid nil))
+ is-valid))\n"
+ namespace
+ namespace
+ namespace
+ namespace
+ namespace))
+
+ ;; Valid e-p
+ (insert
+ (format "
+(defun
+ %s--valid-e-p
+ (symbol)
+ \"Return whether SYMBOL is the e identifier or not.\"
+ (eq
+ symbol
+ %s--e-identifier))\n"
+ namespace
+ namespace))
+
+ ;; Valid EOF-p
+ (insert
+ (format "
+(defun
+ %s--valid-eof-p
+ (symbol)
+ \"Return whether SYMBOL is the EOF identifier or not.\"
+ (eq
+ symbol
+ %s--eof-identifier))\n"
+ namespace
+ namespace))
+
+ ;; Valid non-terminal-p
+ (insert
+ (format "
+(defun %s--valid-non-terminal-p (symbol)
+ \"Return whether SYMBOL is a non-terminal in grammar or not.\"
+ (gethash
+ symbol
+ %s--table-non-terminal-p))\n"
+ namespace
+ namespace))
+
+ ;; Valid terminal-p
+ (insert
+ (format "
+(defun %s--valid-terminal-p (symbol)
+ \"Return whether SYMBOL is a terminal in grammar or not.\"
+ (gethash
+ symbol
+ %s--table-terminal-p))\n"
+ namespace
+ namespace))
+
+ ;; Get grammar translation by number
+ (insert
+ (format "
+(defun
+ %s--get-grammar-translation-by-number
+ (production-number)
+ \"If translation for PRODUCTION-NUMBER exist, return it.\"
+ (gethash
+ production-number
+ %s--table-translations))\n"
+ namespace
+ namespace))
+
+ ;; Parse / translate function
+ (insert
+ (format "
+(defun
+ %s--parse
+ (&optional
+ input-tape-index
+ pushdown-list
+ output
+ translation
+ translation-symbol-table
+ history)
+ \"Perform a LR-parse via lex-analyzer, optionally at INPUT-TAPE-INDEX with
PUSHDOWN-LIST, OUTPUT, TRANSLATION, TRANSLATION-SYMBOL-TABLE 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)
+ (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
+ namespace
+ namespace
+ namespace
+ namespace
+ namespace))
+ (insert "
+ (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)."
+ namespace))
+ (insert "
+ (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)))"
+ namespace
+ namespace
+ namespace))
+
+ (insert "
+ (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
+ 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
+ namespace
+ namespace
+ namespace
+ namespace
+ namespace
+ 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")
+
+ ;; Parse
+ (insert
+ (format "
+(defun %s-parse
+ (&optional
+ input-tape-index
+ pushdown-list
+ output
+ translation
+ history)
+ \"Perform a LR-parse via lex-analyzer, optionally at INPUT-TAPE-INDEX with
PUSHDOWN-LIST, OUTPUT, TRANSLATION and HISTORY.\"
+ (let ((result
+ (%s--parse
+ input-tape-index
+ pushdown-list
+ output
+ translation
+ history)))
+ (nth 0 result)))\n"
+ namespace
+ namespace))
+
+ ;; Translate
+ (insert
+ (format "
+(defun %s-translate
+ (&optional
+ input-tape-index
+ pushdown-list
+ output
+ translation
+ history)
+ \"Perform a LR-parse via lex-analyzer, optionally at INPUT-TAPE-INDEX with
PUSHDOWN-LIST, OUTPUT, TRANSLATION and HISTORY.\"
+ (let ((result
+ (%s--parse
+ input-tape-index
+ pushdown-list
+ output
+ translation
+ history)))
+ (nth 1 result)))\n"
+ namespace
+ namespace))
+
+ ;; Footer
+ (insert
+ (format
+ "\n(provide '%s)"
+ namespace))
+ (insert
+ (format
+ "\n\n;;; %s.el ends here"
+ namespace))
+
+ (setq
+ code
+ (buffer-substring-no-properties
+ (point-min)
+ (point-max))))
+ code))
+
+
+(provide 'parser-generator-lr-export)
+
+;;; parser-generator-lr-export.el ends here
diff --git a/parser-generator-lr.el b/parser-generator-lr.el
index ce22b64..8e23c9b 100644
--- a/parser-generator-lr.el
+++ b/parser-generator-lr.el
@@ -35,812 +35,6 @@
table-lr-items)
table-lr-items))
-(defun parser-generator-lr--export-parser (namespace)
- "Export parser with NAMESPACE."
-
- ;; Make sure all requisites are defined
- (unless parser-generator-lr--action-tables
- (error "Missing generated ACTION-tables!"))
- (unless parser-generator-lr--goto-tables
- (error "Missing generated GOTO-tables!"))
- (unless parser-generator--table-productions-number-reverse
- (error "Table for reverse production-numbers is undefined!"))
- (unless parser-generator--table-look-aheads-p
- (error "Table for valid look-aheads is undefined!"))
- (unless parser-generator--look-ahead-number
- (error "Missing a look-ahead number!"))
- (unless parser-generator--e-identifier
- (error "Missing definition for e-identifier!"))
- (unless parser-generator--eof-identifier
- (error "Missing definition for EOF-identifier!"))
- (unless parser-generator--table-non-terminal-p
- (error "Table for non-terminals is undefined!"))
- (unless parser-generator--table-terminal-p
- (error "Table for terminals is undefined!"))
- (unless parser-generator--table-translations
- (error "Table for translations by production-number is undefined!"))
- (unless parser-generator-lex-analyzer--get-function
- (error "Missing lex-analyzer get function!"))
- (unless parser-generator-lex-analyzer--function
- (error "Missing lex-analyzer function!"))
-
- (let ((code))
- (with-temp-buffer
- (goto-char (point-min))
-
- ;; Header
- (insert
- (format
- ";;; %s.el --- Exported Emacs Parser Generator -*- lexical-binding: t
-*-\n\n\n"
- namespace))
- (insert ";;; Commentary:\n\n\n;;; Code:\n\n\n")
-
- (insert ";;; Constants:\n\n\n")
-
- ;; Action-tables
- (insert
- (format
- "(defconst\n %s--action-tables\n %s\n \"Generated
action-tables.\")\n\n"
- namespace
- parser-generator-lr--action-tables))
-
- ;; Goto-tables
- (insert
- (format
- "(defconst\n %s--goto-tables\n %s\n \"Generated goto-tables.\")\n\n"
- namespace
- parser-generator-lr--goto-tables))
-
- ;; Table production-number
- (insert
- (format
- "(defconst\n %s--table-productions-number-reverse\n %s\n
\"Hash-table indexed by production-number and value is production.\")\n\n"
- namespace
- parser-generator--table-productions-number-reverse))
-
- ;; Table look-aheads
- (insert
- (format
- "(defconst\n %s--table-look-aheads\n %s\n \"Hash-table of valid
look-aheads.\")\n\n"
- namespace
- parser-generator--table-look-aheads-p))
-
- ;; Table terminals
- (insert
- (format
- "(defconst\n %s--table-terminal-p\n %s\n \"Hash-table of valid
terminals.\")\n\n"
- namespace
- parser-generator--table-non-terminal-p))
-
- ;; Table non-terminals
- (insert
- (format
- "(defconst\n %s--table-non-terminal-p\n %s\n \"Hash-table of valid
non-terminals.\")\n\n"
- namespace
- parser-generator--table-non-terminal-p))
-
- ;; Table translations
- (insert
- (format
- "(defconst\n %s--table-translations\n %s\n \"Hash-table of
translations.\")\n\n"
- namespace
- parser-generator--table-translations))
-
- ;; Lex-Analyzer Get Function
- (insert
- (format
- "(defconst\n %s-lex-analyzer--get-function\n (lambda %s %s)\n
\"Lex-Analyzer Get Function.\")\n\n"
- namespace
- (nth 2 parser-generator-lex-analyzer--get-function)
- (nth 3 parser-generator-lex-analyzer--get-function)))
-
- ;; Lex-Analyzer Function
- (insert
- (format
- "(defconst\n %s-lex-analyzer--function\n (lambda %s %s)\n
\"Lex-Analyzer Function.\")\n\n"
- namespace
- (nth 2 parser-generator-lex-analyzer--function)
- (nth 3 parser-generator-lex-analyzer--function)))
-
- ;; Lex-Analyzer Reset Function
- (insert
- (format
- "(defconst\n %s-lex-analyzer--reset-function\n "
- namespace))
- (if parser-generator-lex-analyzer--reset-function
- (insert
- (format
- "(lambda %s %s)\n"
- (nth 2 parser-generator-lex-analyzer--reset-function)
- (nth 3 parser-generator-lex-analyzer--reset-function)))
- (insert "nil\n"))
- (insert " \"Lex-Analyzer Reset Function.\")\n\n")
-
- ;; E-identifier
- (insert
- (format
- "(defconst\n %s--e-identifier\n '%s\n \"e-identifier\")\n\n"
- namespace
- parser-generator--e-identifier))
-
- ;; EOF-identifier
- (insert
- (format
- "(defconst\n %s--eof-identifier\n '%s\n \"EOF-identifier.\")\n\n"
- namespace
- parser-generator--eof-identifier))
-
- ;; Look-ahead number
- (insert
- (format
- "(defconst\n %s--look-ahead-number\n %s\n \"Look-ahead
number.\")\n\n"
- namespace
- parser-generator--look-ahead-number))
-
- (insert "\n;;; Variables:\n\n\n")
-
- ;; Lex-analyzer index
- (insert
- (format
- "(defvar\n %s-lex-analyzer--index\n 0\n \"Current index of
lex-analyzer.\")\n\n"
- namespace))
-
- (insert "\n;;; Functions:\n\n\n")
-
- (insert ";;; Lex-Analyzer:\n\n\n")
-
- ;; Lex-Analyzer Get Function
- (insert
- (format
- "(defun
- %s-lex-analyzer--get-function (token)
- \"Get information about TOKEN.\"
- (unless
- %s-lex-analyzer--get-function
- (error \"Missing lex-analyzer get function!\"))
- (let ((meta-information))
- (condition-case
- error
- (progn
- (setq
- meta-information
- (funcall
- %s-lex-analyzer--get-function
- token)))"
- namespace
- namespace
- namespace))
- (insert "
- (error
- (error
- \"Lex-analyze failed to get token meta-data of %s, error: %s\"
- token
- (car (cdr error)))))
- (unless meta-information
- (error \"Could not find any token meta-information for: %s\" token))
- meta-information))\n")
-
- ;; Lex-Analyzer Reset Function
- (insert
- (format "
-(defun
- %s-lex-analyzer--reset
- ()
- \"Reset Lex-Analyzer.\"
- (setq
- %s-lex-analyzer--index
- 1)
- (when
- %s-lex-analyzer--reset-function
- (funcall
- %s-lex-analyzer--reset-function)))\n"
- namespace
- namespace
- namespace
- namespace))
-
- ;; Lex-Analyzer Peek Next Look Ahead
- (insert
- (format "
-(defun
- %s-lex-analyzer--peek-next-look-ahead
- ()
- \"Peek next look-ahead number of tokens via lex-analyzer.\"
- (let ((look-ahead)
- (look-ahead-length 0)
- (index %s-lex-analyzer--index)
- (k (max
- 1
- %s--look-ahead-number)))
- (while (<
- look-ahead-length
- k)
- (condition-case error
- (progn
- (let ((next-look-ahead
- (funcall
- %s-lex-analyzer--function
- index)))
- (if next-look-ahead
- (progn
- (unless (listp (car next-look-ahead))
- (setq next-look-ahead (list next-look-ahead)))
- (dolist (next-look-ahead-item next-look-ahead)
- (when (<
- look-ahead-length
- k)
- (push next-look-ahead-item look-ahead)
- (setq look-ahead-length (1+ look-ahead-length))
- (setq index (cdr (cdr next-look-ahead-item))))))
- (push (list %s--eof-identifier) look-ahead)
- (setq look-ahead-length (1+ look-ahead-length))
- (setq index (1+ index)))))"
- namespace
- namespace
- namespace
- namespace
- namespace))
- (insert "
- (error
- (error
- \"Lex-analyze failed to peek next look-ahead at %s, error: %s\"
- index
- (car (cdr error))))))
- (nreverse look-ahead)))\n")
-
- ;; Lex-Analyzer Pop Token
- (insert
- (format "
-(defun
- %s-lex-analyzer--pop-token ()
- \"Pop next token via lex-analyzer.\"
- (let ((iteration 0)
- (tokens))
- (while (< iteration 1)
- (condition-case error
- (progn
- (let ((token
- (funcall
- %s-lex-analyzer--function
- %s-lex-analyzer--index)))
- (when token
- (unless (listp (car token))
- (setq token (list token)))
- (let ((first-token (car token)))
- (setq
- %s-lex-analyzer--index
- (cdr (cdr first-token)))
- (push first-token tokens)))))"
- namespace
- namespace
- namespace
- namespace))
- (insert "
- (error (error
- \"Lex-analyze failed to pop token at %s, error: %s\"")
- (insert (format "
- %s-lex-analyzer--index
- (car (cdr error)))))
- (setq iteration (1+ iteration)))
- (nreverse tokens)))\n"
- namespace))
-
- (insert "\n;;; Syntax-Analyzer / Parser:\n\n\n");
-
- ;; Get grammar production by number
- (insert
- (format "
-(defun
- %s--get-grammar-production-by-number
- (production-number)
- \"If PRODUCTION-NUMBER exist, return it's production.\"
- (gethash
- production-number
- %s--table-productions-number-reverse))\n"
- namespace
- namespace))
-
- ;; Valid symbol p
- (insert
- (format "
-(defun
- %s--valid-symbol-p
- (symbol)
- \"Return whether SYMBOL is valid or not.\"
- (let ((is-valid t))
- (unless (or
- (%s--valid-e-p symbol)
- (%s--valid-eof-p symbol)
- (%s--valid-non-terminal-p symbol)
- (%s--valid-terminal-p symbol))
- (setq is-valid nil))
- is-valid))\n"
- namespace
- namespace
- namespace
- namespace
- namespace))
-
- ;; Valid e-p
- (insert
- (format "
-(defun
- %s--valid-e-p
- (symbol)
- \"Return whether SYMBOL is the e identifier or not.\"
- (eq
- symbol
- %s--e-identifier))\n"
- namespace
- namespace))
-
- ;; Valid EOF-p
- (insert
- (format "
-(defun
- %s--valid-eof-p
- (symbol)
- \"Return whether SYMBOL is the EOF identifier or not.\"
- (eq
- symbol
- %s--eof-identifier))\n"
- namespace
- namespace))
-
- ;; Valid non-terminal-p
- (insert
- (format "
-(defun %s--valid-non-terminal-p (symbol)
- \"Return whether SYMBOL is a non-terminal in grammar or not.\"
- (gethash
- symbol
- %s--table-non-terminal-p))\n"
- namespace
- namespace))
-
- ;; Valid terminal-p
- (insert
- (format "
-(defun %s--valid-terminal-p (symbol)
- \"Return whether SYMBOL is a terminal in grammar or not.\"
- (gethash
- symbol
- %s--table-terminal-p))\n"
- namespace
- namespace))
-
- ;; Get grammar translation by number
- (insert
- (format "
-(defun
- %s--get-grammar-translation-by-number
- (production-number)
- \"If translation for PRODUCTION-NUMBER exist, return it.\"
- (gethash
- production-number
- %s--table-translations))\n"
- namespace
- namespace))
-
- ;; Parse / translate function
- (insert
- (format "
-(defun
- %s--parse
- (&optional
- input-tape-index
- pushdown-list
- output
- translation
- translation-symbol-table
- history)
- \"Perform a LR-parse via lex-analyzer, optionally at INPUT-TAPE-INDEX with
PUSHDOWN-LIST, OUTPUT, TRANSLATION, TRANSLATION-SYMBOL-TABLE 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)
- (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
- namespace
- namespace
- namespace
- namespace
- namespace))
- (insert "
- (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)."
- namespace))
- (insert "
- (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)))"
- namespace
- namespace
- namespace))
-
- (insert "
- (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
- 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
- namespace
- namespace
- namespace
- namespace
- namespace
- 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")
-
- ;; Parse
- (insert
- (format "
-(defun %s-parse
- (&optional
- input-tape-index
- pushdown-list
- output
- translation
- history)
- \"Perform a LR-parse via lex-analyzer, optionally at INPUT-TAPE-INDEX with
PUSHDOWN-LIST, OUTPUT, TRANSLATION and HISTORY.\"
- (let ((result
- (%s--parse
- input-tape-index
- pushdown-list
- output
- translation
- history)))
- (nth 0 result)))\n"
- namespace
- namespace))
-
- ;; Translate
- (insert
- (format "
-(defun %s-translate
- (&optional
- input-tape-index
- pushdown-list
- output
- translation
- history)
- \"Perform a LR-parse via lex-analyzer, optionally at INPUT-TAPE-INDEX with
PUSHDOWN-LIST, OUTPUT, TRANSLATION and HISTORY.\"
- (let ((result
- (%s--parse
- input-tape-index
- pushdown-list
- output
- translation
- history)))
- (nth 1 result)))\n"
- namespace
- namespace))
-
- ;; Footer
- (insert
- (format
- "\n(provide '%s)"
- namespace))
- (insert
- (format
- "\n\n;;; %s.el ends here"
- namespace))
-
- (setq
- code
- (buffer-substring-no-properties
- (point-min)
- (point-max))))
- code))
-
;; Algorithm 5.11, p. 393
(defun parser-generator-lr--generate-action-tables (table-lr-items)
"Generate action-tables for lr-grammar based on TABLE-LR-ITEMS."
diff --git a/test/parser-generator-lr-export-test.el
b/test/parser-generator-lr-export-test.el
new file mode 100644
index 0000000..f03b70c
--- /dev/null
+++ b/test/parser-generator-lr-export-test.el
@@ -0,0 +1,74 @@
+;;; parser-generator-lr-export-test.el --- Tests for LR(k) Parser Export -*-
lexical-binding: t -*-
+
+
+;;; Commentary:
+
+
+;;; Code:
+
+
+(require 'parser-generator-lr-export)
+(require 'ert)
+
+(defun parser-generator-lr-export-test-to-elisp ()
+ "Test `parser-generator-lr-export'."
+ (message "Started tests for (parser-generator-lr-export-to-elisp)")
+
+ ;; Generate parser
+ (parser-generator-set-grammar
+ '((Sp S) (a b) ((Sp S) (S (S a S b)) (S e)) Sp))
+ (parser-generator-set-look-ahead-number 1)
+ (parser-generator-process-grammar)
+ (parser-generator-lr-generate-parser-tables)
+ (setq
+ parser-generator-lex-analyzer--function
+ (lambda (index)
+ (let* ((string '((a 1 . 2) (a 2 . 3) (b 3 . 4) (b 4 . 5)))
+ (string-length (length string))
+ (max-index index)
+ (tokens))
+ (while (and
+ (< (1- index) string-length)
+ (< (1- index) max-index))
+ (push (nth (1- index) string) tokens)
+ (setq index (1+ index)))
+ (nreverse tokens))))
+ (setq
+ parser-generator-lex-analyzer--get-function
+ (lambda (token)
+ (car token)))
+
+ ;; Test parser
+ (should
+ (equal
+ '(2 2 2 1 1)
+ (parser-generator-lr-parse)))
+
+ ;; Export parser
+ (let ((export (parser-generator-lr-export-to-elisp "e--")))
+
+ (with-temp-buffer
+ (insert export)
+ (eval-buffer)
+ (should
+ (equal
+ t
+ (fboundp 'e---parse)))
+
+ (when (fboundp 'e---parse)
+ (should
+ (equal
+ '(2 2 2 1 1)
+ (e---parse))))
+ (message "Passed parse for exported parser")))
+
+ (message "Passed tests for (parser-generator-lr-export-to-elisp)"))
+
+(defun parser-generator-lr-export-test ()
+ "Run test."
+ (parser-generator-lr-export-test-to-elisp))
+
+
+(provide 'parser-generator-lr-export-test)
+
+;;; parser-generator-lr-export-test.el ends here
diff --git a/test/parser-generator-lr-test.el b/test/parser-generator-lr-test.el
index 0882a3f..49c4071 100644
--- a/test/parser-generator-lr-test.el
+++ b/test/parser-generator-lr-test.el
@@ -1152,55 +1152,6 @@
(message "Passed tests for (parser-generator-lr-translate)"))
-(defun parser-generator-lr-test-export-parser ()
- "Test `parser-generator-lr--export-parser'."
- (message "Started tests for (parser-generator-lr--export-parser)")
-
- (parser-generator-set-grammar
- '((Sp S) (a b) ((Sp S) (S (S a S b)) (S e)) Sp))
- (parser-generator-set-look-ahead-number 1)
- (parser-generator-process-grammar)
- (parser-generator-lr-generate-parser-tables)
- (setq
- parser-generator-lex-analyzer--function
- (lambda (index)
- (let* ((string '((a 1 . 2) (a 2 . 3) (b 3 . 4) (b 4 . 5)))
- (string-length (length string))
- (max-index index)
- (tokens))
- (while (and
- (< (1- index) string-length)
- (< (1- index) max-index))
- (push (nth (1- index) string) tokens)
- (setq index (1+ index)))
- (nreverse tokens))))
- (setq
- parser-generator-lex-analyzer--get-function
- (lambda (token)
- (car token)))
- (should
- (equal
- '(2 2 2 1 1)
- (parser-generator-lr-parse)))
- (let ((export (parser-generator-lr--export-parser "e--")))
-
- (with-temp-buffer
- (insert export)
- (eval-buffer)
- (should
- (equal
- t
- (fboundp 'e---parse)))
-
- (when (fboundp 'e---parse)
- (should
- (equal
- '(2 2 2 1 1)
- (e---parse))))
- (message "Passed parse for exported parser")))
-
- (message "Passed tests for (parser-generator-lr--export-parser)"))
-
(defun parser-generator-lr-test ()
"Run test."
;; (setq debug-on-error t)
@@ -1212,8 +1163,7 @@
(parser-generator-lr-test-parse)
(parser-generator-lr-test-translate)
(parser-generator-lr-test-parse-k-2)
- (parser-generator-lr-test-parse-k-0)
- (parser-generator-lr-test-export-parser))
+ (parser-generator-lr-test-parse-k-0))
(provide 'parser-generator-lr-test)
