branch: externals/parser-generator commit 17c36f8b424e2c18efaed97fe1f56ed96cfe014b Author: Christian Johansson <christ...@cvj.se> Commit: Christian Johansson <christ...@cvj.se>
Added cache to lr-items for prefix function --- parser-generator-lr.el | 409 +++++++++++++++++++++++++++---------------------- 1 file changed, 225 insertions(+), 184 deletions(-) diff --git a/parser-generator-lr.el b/parser-generator-lr.el index 9a4168c..705e77b 100644 --- a/parser-generator-lr.el +++ b/parser-generator-lr.el @@ -26,12 +26,20 @@ nil "Goto-tables for grammar.") +(defvar + parser-generator-lr--table-lr-items-for-symbol + nil + "LR-items cache for symbol.") + ;; Main Algorithms (defun parser-generator-lr-generate-parser-tables () "Generate parsing tables for grammar." (message "\nStarting generation of parser-tables..\n") + (setq + parser-generator-lr--table-lr-items-for-symbol + (make-hash-table :test 'equal)) (let ((table-lr-items (parser-generator-lr--generate-goto-tables))) (parser-generator-lr--generate-action-tables @@ -368,8 +376,10 @@ (when (and (or - (parser-generator--valid-terminal-p next-symbol) - (parser-generator--valid-non-terminal-p next-symbol)) + (parser-generator--valid-terminal-p + next-symbol) + (parser-generator--valid-non-terminal-p + next-symbol)) (not (gethash temp-hash-key @@ -413,12 +423,12 @@ (parser-generator--debug (message - "GOTO(%s, %s) = %s" + "GOTO(%S, %S) = %S" lr-items symbol prefix-lr-items)) - ;; and is not already in S + ;; and set is not already in S (let ((goto (gethash prefix-lr-items-hash-key @@ -466,11 +476,10 @@ (sort goto-table-table 'parser-generator--sort-list)) - (when goto-table-table - (message - "GOTO-TABLE (%d): %S\n" - lr-item-set-index - goto-table-table)) + (message + "GOTO-TABLE (%d): %S\n" + lr-item-set-index + goto-table-table) (push `( ,lr-item-set-index @@ -501,18 +510,21 @@ (car (cdr (nth table-index goto-table))) parser-generator-lr--goto-tables) (setq table-index (1+ table-index)))) - (unless - (parser-generator-lr--items-valid-p - (parser-generator--hash-values-to-list - table-lr-items - t)) - (error "Inconsistent grammar!")) + (parser-generator-lr--items-valid-p + (parser-generator--hash-values-to-list + table-lr-items + t) + t) (message "\nCompleted generation of goto-tables.\n") table-lr-items)) ;; Algorithm 5.10, p. 391 -(defun parser-generator-lr--items-valid-p (lr-item-sets) - "Return whether the set collection LR-ITEM-SETS is valid or not." +(defun parser-generator-lr--items-valid-p + ( + lr-item-sets + &optional signal-on-false + ) + "Return whether the set collection LR-ITEM-SETS is valid or not, optionally SIGNAL-ON-FALSE." (parser-generator--debug (message "lr-item-sets: %s" lr-item-sets)) (let ((valid-p t) @@ -589,8 +601,16 @@ (dolist (b-suffix-follow-eff-item b-suffix-follow-eff) (when (equal a-follow b-suffix-follow-eff-item) - (parser-generator--debug - (message "Inconsistent grammar! %s conflicts with %s" a b)) + (when + signal-on-false + (signal + 'error + (format + "Inconsistent grammar! %s (index: %d) conflicts with %s (index: %d)" + a + a-index + b + b-index))) (setq valid-p nil)))) (setq b-index (1+ b-index)))) (setq a-index (1+ a-index))) @@ -795,185 +815,206 @@ (message "γ: %s" γ)) prefix-previous))))) -;; TODO Optimize this function 1. first and 2. sort (defun parser-generator-lr--items-for-goto (previous-lr-item x) "Calculate LR-items for GOTO(PREVIOUS-LR-ITEM, X)." - (let ((lr-new-item) - (lr-item-exists - (make-hash-table :test 'equal)) - (eof-list - (parser-generator--generate-list-of-symbol - parser-generator--look-ahead-number - parser-generator--eof-identifier))) - (parser-generator--debug (message "x: %s" x)) - - ;; TODO Use caches to optimize this loop - (dolist (lr-item previous-lr-item) - (let ((lr-item-lhs (nth 0 lr-item)) - (lr-item-prefix (nth 1 lr-item)) - (lr-item-suffix (nth 2 lr-item)) - (lr-item-look-ahead (nth 3 lr-item)) - (lr-item-suffix-first) - (lr-item-suffix-rest)) - (setq - lr-item-suffix-first - (car lr-item-suffix)) + (let ((lr-items-cache-key + (format + "%S-%S" + previous-lr-item + x))) + (unless + parser-generator-lr--table-lr-items-for-symbol (setq - lr-item-suffix-rest - (cdr lr-item-suffix)) - + parser-generator-lr--table-lr-items-for-symbol + (make-hash-table :test 'equal))) + (unless (gethash + lr-items-cache-key + parser-generator-lr--table-lr-items-for-symbol) + (let ((lr-new-item) + (lr-item-exists + (make-hash-table :test 'equal)) + (eof-list + (parser-generator--generate-list-of-symbol + parser-generator--look-ahead-number + parser-generator--eof-identifier))) (parser-generator--debug - (message "lr-item: %s" lr-item) - (message "lr-item-prefix: %s" lr-item-prefix) - (message "lr-item-suffix: %s" lr-item-suffix) - (message "lr-item-suffix-first: %s" lr-item-suffix-first) - (message "lr-item-suffix-rest: %s" lr-item-suffix-rest) - (message "lr-item-look-ahead: %s" lr-item-look-ahead)) - - ;; (a) If [A -> a . XiB, u] is in V(X1,...,Xi-1) - (when - (equal + (message "x: %s" x)) + + ;; TODO Use caches to optimize this loop + (dolist (lr-item previous-lr-item) + (let ((lr-item-lhs (nth 0 lr-item)) + (lr-item-prefix (nth 1 lr-item)) + (lr-item-suffix (nth 2 lr-item)) + (lr-item-look-ahead (nth 3 lr-item)) + (lr-item-suffix-first) + (lr-item-suffix-rest)) + (setq lr-item-suffix-first - x) - - ;; Add [A -> aXi . B, u] to V(X1,...,Xi) - (let ((combined-prefix - (append - lr-item-prefix - (list x)))) - (let ((lr-new-item-1)) - (if - (= - parser-generator--look-ahead-number - 0) - ;; Only k >= 1 needs dot look-ahead - (progn + (car lr-item-suffix)) + (setq + lr-item-suffix-rest + (cdr lr-item-suffix)) + + (parser-generator--debug + (message "lr-item: %s" lr-item) + (message "lr-item-prefix: %s" lr-item-prefix) + (message "lr-item-suffix: %s" lr-item-suffix) + (message "lr-item-suffix-first: %s" lr-item-suffix-first) + (message "lr-item-suffix-rest: %s" lr-item-suffix-rest) + (message "lr-item-look-ahead: %s" lr-item-look-ahead)) + + ;; (a) If [A -> a . XiB, u] is in V(X1,...,Xi-1) + (when + (equal + lr-item-suffix-first + x) + + ;; Add [A -> aXi . B, u] to V(X1,...,Xi) + (let ((combined-prefix + (append + lr-item-prefix + (list x)))) + (let ((lr-new-item-1)) + (if + (= + parser-generator--look-ahead-number + 0) + ;; Only k >= 1 needs dot look-ahead + (progn + (setq + lr-new-item-1 + `(,lr-item-lhs + ,combined-prefix + ,lr-item-suffix-rest))) (setq lr-new-item-1 `(,lr-item-lhs ,combined-prefix - ,lr-item-suffix-rest))) - (setq - lr-new-item-1 - `(,lr-item-lhs - ,combined-prefix - ,lr-item-suffix-rest - ,lr-item-look-ahead))) - (parser-generator--debug - (message - "lr-new-item-1: %s" - lr-new-item-1)) - (push - lr-new-item-1 - lr-new-item)))))) - - ;; (c) Repeat step (2b) until no more new items can be added to V(X1,...,Xi) - (when lr-new-item - (let ((added-new t)) - (while added-new - (setq added-new nil) - - ;; TODO Use caches to optimize this loop - (dolist (lr-item lr-new-item) - (let ((lr-item-suffix (nth 2 lr-item))) - (let ((lr-item-suffix-first - (car lr-item-suffix)) - (lr-item-suffix-rest - (append - (cdr lr-item-suffix) - (nth 3 lr-item)))) - (parser-generator--debug - (message - "lr-item-suffix-rest: %s from %s + %s" - lr-item-suffix-rest - (cdr lr-item-suffix) - (nth 3 lr-item))) - - ;; (b) If [A -> a . Bb, u] has been placed in V(X1,...,Xi) - ;; and B -> D is in P - (when - (parser-generator--valid-non-terminal-p - lr-item-suffix-first) - - (let ((lr-item-suffix-rest-first - (parser-generator--first - lr-item-suffix-rest - nil - t - t))) + ,lr-item-suffix-rest + ,lr-item-look-ahead))) + (parser-generator--debug + (message + "lr-new-item-1: %s" + lr-new-item-1)) + (push + lr-new-item-1 + lr-new-item)))))) + + ;; (c) Repeat step (2b) until no more new items can be added to V(X1,...,Xi) + (when lr-new-item + (let ((added-new t)) + (while added-new + (setq added-new nil) + + ;; TODO Use caches to optimize this loop + (dolist (lr-item lr-new-item) + (let ((lr-item-suffix (nth 2 lr-item))) + (let ((lr-item-suffix-first + (car lr-item-suffix)) + (lr-item-suffix-rest + (append + (cdr lr-item-suffix) + (nth 3 lr-item)))) (parser-generator--debug (message - "lr-item-suffix-rest-first (before): %s" - lr-item-suffix-rest-first)) + "lr-item-suffix-rest: %s from %s + %s" + lr-item-suffix-rest + (cdr lr-item-suffix) + (nth 3 lr-item))) - ;; EOF-markers are always a possible look-ahead - (unless lr-item-suffix-rest-first - (setq - lr-item-suffix-rest-first - (list eof-list))) + ;; (b) If [A -> a . Bb, u] has been placed in V(X1,...,Xi) + ;; and B -> D is in P + (when + (parser-generator--valid-non-terminal-p + lr-item-suffix-first) + + (let ((lr-item-suffix-rest-first + (parser-generator--first + lr-item-suffix-rest + nil + t + t))) + (parser-generator--debug + (message + "lr-item-suffix-rest-first (before): %s" + lr-item-suffix-rest-first)) - (parser-generator--debug - (message - "lr-item-suffix-rest-first (after): %s" - lr-item-suffix-rest-first)) - (let ((sub-production - (parser-generator--get-grammar-rhs - lr-item-suffix-first))) - - ;; For each production with B as LHS - (dolist (sub-rhs sub-production) - - ;; Transform e-productions into nil - (when (and - (= (length sub-rhs) 1) - (parser-generator--valid-e-p - (car sub-rhs))) - (setq sub-rhs nil)) - - ;; For each x in FIRST(αu) - (dolist (f lr-item-suffix-rest-first) - - ;; then add [B -> . D, x] to V(X1,...,Xi) for each x in FIRST(bu) - ;; provided it is not already there - (let ((lr-item-to-add - `(,(list lr-item-suffix-first) nil ,sub-rhs ,f))) - ;; Only k >= 1 needs dot a look-ahead - (when - (= - parser-generator--look-ahead-number - 0) - (setq - lr-item-to-add - `(,(list lr-item-suffix-first) nil ,sub-rhs))) - (let ((temp-hash-key - (format - "%S" - lr-item-to-add))) - (unless - (gethash - temp-hash-key - lr-item-exists) - (setq - added-new - t) - (parser-generator--debug - (message - "lr-item-to-add: %s" - lr-item-to-add)) - (puthash - temp-hash-key - t - lr-item-exists) - (push - lr-item-to-add - lr-new-item)))))))))))))) - (setq - lr-new-item - (sort - lr-new-item - 'parser-generator--sort-list))) ;; TODO Optimize this? + ;; EOF-markers are always a possible look-ahead + (unless lr-item-suffix-rest-first + (setq + lr-item-suffix-rest-first + (list eof-list))) - lr-new-item)) + (parser-generator--debug + (message + "lr-item-suffix-rest-first (after): %s" + lr-item-suffix-rest-first)) + (let ((sub-production + (parser-generator--get-grammar-rhs + lr-item-suffix-first))) + + ;; For each production with B as LHS + (dolist (sub-rhs sub-production) + + ;; Transform e-productions into nil + (when (and + (= (length sub-rhs) 1) + (parser-generator--valid-e-p + (car sub-rhs))) + (setq sub-rhs nil)) + + ;; For each x in FIRST(αu) + (dolist (f lr-item-suffix-rest-first) + + ;; then add [B -> . D, x] to V(X1,...,Xi) for each x in FIRST(bu) + ;; provided it is not already there + (let ((lr-item-to-add + `(,(list lr-item-suffix-first) nil ,sub-rhs ,f))) + ;; Only k >= 1 needs dot a look-ahead + (when + (= + parser-generator--look-ahead-number + 0) + (setq + lr-item-to-add + `(,(list lr-item-suffix-first) nil ,sub-rhs))) + (let ((temp-hash-key + (format + "%S" + lr-item-to-add))) + (unless + (gethash + temp-hash-key + lr-item-exists) + (setq + added-new + t) + (parser-generator--debug + (message + "lr-item-to-add: %s" + lr-item-to-add)) + (puthash + temp-hash-key + t + lr-item-exists) + (push + lr-item-to-add + lr-new-item)))))))))))))) + + ;; Sort result for a more deterministic result + (setq + lr-new-item + (sort + lr-new-item + 'parser-generator--sort-list))) ;; TODO Optimize this? + + (puthash + lr-items-cache-key + lr-new-item + parser-generator-lr--table-lr-items-for-symbol))) + (gethash + lr-items-cache-key + parser-generator-lr--table-lr-items-for-symbol))) (defun parser-generator-lr-parse (&optional