[elpa] externals/parser-generator de7c45c511 78/82: Started with LL-export functions

[Christian Johansson]

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

    Started with LL-export functions
---
 parser-generator-ll-export.el | 779 ++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 779 insertions(+)

diff --git a/parser-generator-ll-export.el b/parser-generator-ll-export.el
new file mode 100644
index 0000000000..8fff6ed74c
--- /dev/null
+++ b/parser-generator-ll-export.el
@@ -0,0 +1,779 @@
+;;; parser-generator-ll-export.el --- Export LL(k) Parser -*- lexical-binding: 
t -*-
+
+;; Copyright (C) 2020-2022  Free Software Foundation, Inc.
+
+
+;;; Commentary:
+
+
+;;; Code:
+
+
+(require 'parser-generator-ll)
+
+(defun parser-generator-ll-export-to-elisp (namespace &optional header 
copyright)
+  "Export parser with NAMESPACE and a optional HEADER and COPYRIGHT."
+  (message "\n;; Starting generation of elips..\n")
+
+  ;; Make sure all requisites are defined
+  (unless parser-generator-ll--table
+    (error "Missing generated table!"))
+  (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"
+        namespace))
+
+      ;; Optional copyright
+      (when copyright
+        (insert copyright))
+
+      (insert ";;; Commentary:\n\n\n;;; Code:\n\n")
+
+      ;; Optional header
+      (when header
+        (insert header))
+
+      (insert "\n;;; Variables:\n\n\n")
+
+      ;; Action-tables
+      (insert
+       (format
+        "(defvar\n  %s--table\n  %S\n  \"The generated table.\")\n\n"
+        namespace
+        parser-generator-ll--table))
+
+      ;; Table production-number
+      (insert
+       (format
+        "(defvar\n  %s--table-productions-number-reverse\n  %S\n  \"The 
hash-table indexed by production-number and value is production.\")\n\n"
+        namespace
+        parser-generator--table-productions-number-reverse))
+
+      ;; Table terminals
+      (insert
+       (format
+        "(defvar\n  %s--table-terminal-p\n  %S\n  \"The hash-table of valid 
terminals.\")\n\n"
+        namespace
+        parser-generator--table-terminal-p))
+
+      ;; Table non-terminals
+      (insert
+       (format
+        "(defvar\n  %s--table-non-terminal-p\n  %S\n  \"The hash-table of 
valid non-terminals.\")\n\n"
+        namespace
+        parser-generator--table-non-terminal-p))
+
+      ;; Table translations
+      (insert
+       (format
+        "(defvar\n  %s--table-translations\n  %S\n  \"The hash-table of 
translations.\")\n\n"
+        namespace
+        parser-generator--table-translations))
+
+      ;; E-identifier
+      (insert
+       (format
+        "(defvar\n  %s--e-identifier\n  '%S\n  \"The e-identifier.\")\n\n"
+        namespace
+        parser-generator--e-identifier))
+
+      ;; EOF-identifier
+      (insert
+       (format
+        "(defvar\n  %s--eof-identifier\n  '%S\n  \"The 
end-of-file-identifier.\")\n\n"
+        namespace
+        parser-generator--eof-identifier))
+
+      ;; Look-ahead number
+      (insert
+       (format
+        "(defvar\n  %s--look-ahead-number\n  %S\n  \"The look-ahead 
number.\")\n\n"
+        namespace
+        parser-generator--look-ahead-number))
+
+      (insert "\n;;; Local Variables:\n\n")
+
+      ;; Index
+      (insert
+       (format
+        "(defvar-local\n  %s-lex-analyzer--index\n  0\n  \"The current index 
of the lex-analyzer.\")\n\n"
+        namespace))
+
+      ;; Move to index flag
+      (insert
+       (format
+        "(defvar-local\n  %s-lex-analyzer--move-to-index-flag\n  nil\n  
\"Non-nil means move index to value.\")\n\n"
+        namespace))
+
+      (insert "\n;;; Variable Functions:\n\n")
+
+      ;; Lex-Analyzer Get Function
+      (insert
+       (format
+        "(defvar\n  %s-lex-analyzer--get-function\n  (lambda %S %S)\n  \"The 
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
+        "(defvar\n  %s-lex-analyzer--function\n  (lambda %S %S)\n  \"The 
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
+        "(defvar\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 "  \"The lex-analyzer reset function.\")\n\n")
+
+      (insert "\n;;; Functions:\n\n")
+
+      (insert "\n;;; Functions for Lex-Analyzer:\n\n")
+
+      ;; Lex-Analyzer Get Function
+      (insert
+       (format
+        "(defun
+  %s-lex-analyzer--get-function (token)
+  \"Get information about TOKEN.\"
+  (let ((meta-information))
+    (condition-case
+      error
+      (progn
+        (setq
+          meta-information
+          (funcall
+            %s-lex-analyzer--get-function
+            token)))"
+        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
+            (setq-local
+              %s-lex-analyzer--move-to-index-flag
+              nil)
+            (let ((next-look-ahead
+                   (funcall
+                    %s-lex-analyzer--function
+                    index)))
+                  (if %s-lex-analyzer--move-to-index-flag
+                    (setq
+                     index
+                     %s-lex-analyzer--move-to-index-flag)
+              (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
+               namespace
+               namespace
+               namespace))
+      (insert "
+        (error
+         (error
+          \"Lex-analyze failed to peek next look-ahead at %s, error: %s\"
+          index
+          error))))
+    (nreverse look-ahead)))\n")
+
+      ;; Lex-Analyzer Pop Token
+      (insert
+       (format "
+(defun
+  %s-lex-analyzer--pop-token ()
+  \"Pop next token via lex-analyzer.\"
+  (let ((continue t)
+        (tokens))
+    (while continue
+      (condition-case error
+          (progn
+            (setq-local
+              %s-lex-analyzer--move-to-index-flag
+              nil)
+            (let ((token
+                   (funcall
+                    %s-lex-analyzer--function
+                    %s-lex-analyzer--index)))
+              (if %s-lex-analyzer--move-to-index-flag
+                  (progn
+                    (setq-local
+                     %s-lex-analyzer--index
+                     %s-lex-analyzer--move-to-index-flag))
+              (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)))
+                (setq
+                 continue
+                 nil))))"
+               namespace
+               namespace
+               namespace
+               namespace
+               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))))))
+    (nreverse tokens)))\n"
+                      namespace))
+
+      (insert "\n\n;;; Functions for Syntax-Analyzer / Parser:\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 translate-p)
+  \"Parse input via lex-analyzer and return parse trail.\"
+  (let ((accept)
+        (stack
+         (if (> %s--look-ahead-number 1)
+             (list
+              (list
+               (list
+                (%s--get-grammar-start))
+               (%s--generate-list-of-symbol
+                %s--look-ahead-number
+                %s--eof-identifier))
+              %s--eof-identifier)
+           (list
+            (%s--get-grammar-start)
+            %s--eof-identifier)))
+        (output)
+        (eof-look-ahead
+         (%s--generate-list-of-symbol
+          %s--look-ahead-number
+          %s--eof-identifier))
+        (e-reduction
+         (list %s--e-identifier))
+        (translation)
+        (translation-stack)
+        (translation-symbol-table
+         (make-hash-table :test 'equal))
+        (terminal-stack '()))
+    (%s-lex-analyzer--reset)
+    (while (not accept)
+      (let* ((state (car stack))
+             (state-action-table
+              (gethash
+               (format \"%%S\" state)
+               %s--table))
+             (look-ahead-list
+              (%s-lex-analyzer--peek-next-look-ahead))
+             (look-ahead))
+
+        (unless state-action-table
+          (signal
+           'error
+           (list
+            (format
+             \"State action table lacks actions for state: '%%S'!\"
+             state)
+            state)))
+
+        (if look-ahead-list
+            (progn
+              (dolist (look-ahead-list-item look-ahead-list)
+                (push (car look-ahead-list-item) look-ahead))
+              (setq look-ahead (reverse look-ahead)))
+          (setq
+           look-ahead
+           eof-look-ahead))
+
+        (unless (gethash
+                 (format \"%%S\" look-ahead)
+                 state-action-table)
+          (let ((possible-look-aheads))
+            (maphash
+             (lambda (k _v) (push k possible-look-aheads))
+             state-action-table)
+            (signal
+             'error
+             (list
+              (format
+               \"Invalid look-ahead '%%S' in state: '%%S', valid look-aheads: 
'%%S'\"
+               look-ahead
+               state
+               possible-look-aheads)
+              look-ahead
+              state
+              possible-look-aheads))))
+
+        (let* ((action
+                (gethash
+                 (format \"%%S\" look-ahead)
+                 state-action-table))
+               (action-type action))
+          (when (listp action)
+            (setq action-type (car action)))
+          (cond
+
+           ((equal action-type 'pop)
+            (let ((popped-tokens
+                   (parser-generator-lex-analyzer--pop-token)))
+
+              ;; Is it time for SDT?
+              (when (and
+                     translate-p
+                     translation-stack
+                     (string=
+                      (car (car translation-stack))
+                      (format \"%%S\" stack)))
+                (let* ((translation-item (pop translation-stack))
+                       (partial-translation
+                        (%s--perform-translation
+                         (nth 1 translation-item)
+                         translation-symbol-table
+                         (reverse (pop terminal-stack)))))
+                  (setq
+                   translation
+                   partial-translation)))
+
+              (pop stack)
+
+              (when translate-p
+                (let ((token-data)
+                      (old-terminal-stack (car terminal-stack)))
+                  (dolist (popped-token popped-tokens)
+                    (push
+                     popped-token
+                     token-data))
+                  (push
+                   token-data
+                   old-terminal-stack)
+                  (setf
+                   (car terminal-stack)
+                   old-terminal-stack)))
+
+              ;; Is it time for SDT?
+              (when (and
+                     translate-p
+                     translation-stack
+                     (string=
+                      (car (car translation-stack))
+                      (format \"%%S\" stack)))
+                (let* ((translation-item (pop translation-stack))
+                       (partial-translation
+                        (%s--perform-translation
+                         (nth 1 translation-item)
+                         translation-symbol-table
+                         (reverse (pop terminal-stack)))))
+                  (setq
+                   translation
+                   partial-translation)))
+
+              ))
+
+           ((equal action-type 'reduce)
+
+            ;; Is it time for SDT?
+            (when (and
+                   translate-p
+                   translation-stack
+                   (string=
+                    (car (car translation-stack))
+                    (format \"%%S\" stack)))
+              (let* ((translation-item (pop translation-stack))
+                     (partial-translation
+                      (%s--perform-translation
+                       (nth 1 translation-item)
+                       translation-symbol-table
+                       (reverse (pop terminal-stack)))))
+                (setq
+                 translation
+                 partial-translation)))
+
+            (pop stack)
+
+            ;; Is it time for SDT?
+            (when (and
+                   translate-p
+                   translation-stack
+                   (string=
+                    (car (car translation-stack))
+                    (format  \"%%S\" stack)))
+              (let* ((translation-item (pop translation-stack))
+                     (partial-translation
+                      (%s--perform-translation
+                       (nth 1 translation-item)
+                       translation-symbol-table
+                       (reverse (pop terminal-stack)))))
+                (setq
+                 translation
+                 partial-translation)))
+
+            (when translate-p
+              (push
+               (list
+                (format \"%%S\" stack)
+                (nth 2 action))
+               translation-stack)
+              (push
+               '()
+               terminal-stack))
+
+            (unless (equal (nth 1 action) e-reduction)
+              (dolist (reduce-item (reverse (nth 1 action)))
+                (push reduce-item stack)))
+            (push
+             (nth 2 action)
+             output))
+
+           ((equal action-type 'accept)
+            (setq accept t))))))
+    (list
+     (reverse output)
+     translation)))
+
+(defun %s-parse ()
+  (let ((parse (%s--parse)))
+    (car parse)))
+
+(defun %s-translate ()
+  (let ((parse (%s--parse t)))
+    (car (cdr parse))))
+
+(defun %s--perform-translation (production-number symbol-table terminals)
+  \"Perform translation by PRODUCTION-NUMBER, with SYMBOL-TABLE and 
TERMINALS.\"
+  (let* ((production
+          (%s--get-grammar-production-by-number
+           production-number))
+         (production-lhs
+          (car (nth 0 production)))
+         (production-rhs
+          (nth 1 production))
+         (translation)
+         (args-1)
+         (args-2))
+
+    ;; Collect arguments for translation
+    (let ((terminal-index 0))
+      (dolist (rhs-item production-rhs)
+        (cond
+
+         ((parser-generator--valid-non-terminal-p
+           rhs-item)
+          (let* ((non-terminal-value-list
+                  (gethash rhs-item symbol-table))
+                 (non-terminal-value
+                  (pop non-terminal-value-list)))
+            (push
+             (car non-terminal-value)
+             args-1)
+            (push
+             (car (cdr non-terminal-value))
+             args-2)
+            (puthash
+             rhs-item
+             non-terminal-value-list
+             symbol-table)))
+
+         ((parser-generator--valid-terminal-p
+           rhs-item)
+          (push
+           (parser-generator-lex-analyzer--get-function
+            (nth terminal-index terminals))
+           args-1)
+          (push
+           (nth terminal-index terminals)
+           args-2)
+          (setq
+           terminal-index
+           (1+ terminal-index))))))
+    (setq
+     args-1
+     (reverse args-1))
+    (setq
+     args-2
+     (reverse args-2))
+
+    (parser-generator--debug
+     (message
+      "Perform translation %d: %S -> %S via args-1: %S and args-2: %S"
+      production-number
+      production-lhs
+      production-rhs
+      args-1
+      args-2))
+
+    (if (parser-generator--get-grammar-translation-by-number
+         production-number)
+        (let ((partial-translation
+               (funcall
+                (parser-generator--get-grammar-translation-by-number
+                 production-number)
+                args-1
+                args-2))
+              (old-symbol-value
+               (gethash production-lhs symbol-table)))
+          (parser-generator--debug
+           (message
+            "\ntranslation-symbol-table: %S = %S (processed)\n"
+            production-lhs
+            partial-translation))
+          (push
+           (list
+            partial-translation
+            args-2)
+           old-symbol-value)
+          (puthash
+           production-lhs
+           old-symbol-value
+           symbol-table)
+          (setq
+           translation
+           partial-translation))
+
+      ;; When no translation is specified just use popped contents as 
translation
+      (let ((partial-translation
+             (list
+              args-1
+              args-2))
+            (old-symbol-value
+             (gethash production-lhs symbol-table)))
+        (parser-generator--debug
+         (message
+          "\ntranslation-symbol-table: %S = %S (generic)\n"
+          production-lhs
+          partial-translation))
+        (push
+         partial-translation
+         old-symbol-value)
+        (puthash
+         production-lhs
+         old-symbol-value
+         symbol-table)
+        (setq
+         translation
+         (car partial-translation))))
+
+    translation))
+
+")
+
+      ;; 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))))
+    (message "\n;; Completed generation of elips.\n")
+    code))
+
+
+(provide 'parser-generator-lr-export)
+
+;;; parser-generator-lr-export.el ends here