Anonymous committed be83af7

Optimized grammar construction a bit by using a vector to hold states, and pre-computing the exits from each state (e.g., for a given symbol that transitions out of the state, the index of the state to transition to)

  • Participants
  • Parent commits fc6ad8b
  • Branches parsing

Comments (0)

Files changed (1)

File grammar.lisp

    (lookahead :initarg :lookahead)
    (production :initarg :production)))
+(defclass lr1-state ()
+  ((items :initarg :items :accessor items)
+   (exits :initform (make-hash-table) :accessor exits
+	  :documentation "Contains a mapping between symbols and integers representing the next state 
+                          after encountering the symbol")))
 (defclass lr-parse-table ()
   ((number-of-states :initarg :states :accessor number-of-states)
    (entries :initform (make-hash-table :test #'equal) :accessor entries))) 
   (make-instance 'lr1-item :position 0 :production production :lookahead lookahead))
 (defun initial-lr1-state-for-grammar (specification start-rule-name)
-  (loop for rule in specification
-     if (eql (car rule) start-rule-name)
-     return (loop for production in (rule-productions rule)
-	       collect (initial-lr1-item-for-production production :eof))))
+  (make-instance 'lr1-state
+		 :items (closure-of-lr1-items specification 
+					      (loop for rule in specification
+						 if (eql (car rule) start-rule-name)
+						 return (loop for production in (rule-productions rule)
+							   collect (initial-lr1-item-for-production production :eof))))))
 (defun rule-productions-in-grammar (specification rule-name)
   (loop for rule in specification
 		       collect (increment-lr1-item-position item))))
 (defun lr1-states-for-grammar (specification start-rule-name)
-  (let ((states (list (closure-of-lr1-items specification (initial-lr1-state-for-grammar specification start-rule-name))))
+  (let ((states (make-array 0
+			    :element-type 'lr1-state 
+			    :adjustable t
+			    :fill-pointer t))
 	(symbols (symbols-in-grammar specification)))
+    (vector-push-extend (initial-lr1-state-for-grammar specification start-rule-name) states)
     (loop for done = t
-       do (loop for state in states
+       do (loop for state across states
 	     do (loop for symbol in symbols
-		   do (let ((goto (lr1-goto-for-symbol specification state symbol)))
-			(when (and goto (not (member goto states :test #'equal-items)))
-			  (setf done nil)
-			  (push goto states)))))
+		   do (let ((goto (lr1-goto-for-symbol specification (items state) symbol)))
+			(when goto
+			  (let ((goto-index (position goto states :test #'(lambda (goto state) 
+									   (equal-items goto (items state))))))
+			    (if goto-index
+				;; existing state
+				(setf (gethash symbol (exits state)) goto-index)
+				;; new state
+				(progn (setf done nil)
+				       ;; index will be the index of the new last one--so length
+				       ;; is a shortcut way of finding it
+				       (setf (gethash symbol (exits state)) (length states))
+				       (vector-push-extend (make-instance 'lr1-state :items goto) states))))))))
        until done
-       finally (return (reverse states)))))
+       finally (return  states))))
 (defun make-grammar (specification start-rule-name)
   (let* ((states (lr1-states-for-grammar specification start-rule-name))
 		     (length (length rhs)))
 		 (< (slot-value item 'position) length)))
-	     (index-of-goto (goto)
-	       (position goto states :test #'equal-items))
 	     (record-shift (statei next-symbol)
 	       (setf (gethash (list statei next-symbol) (entries action-table))
-		     (list :shift (index-of-goto (lr1-goto-for-symbol specification (elt states statei) next-symbol)))))
+		     (let ((state (elt states statei)))
+		       (list :shift (gethash next-symbol (exits state))))))
 	     (record-reduce (statei next-symbol production)
 	       (setf (gethash (list statei next-symbol) (entries action-table))
 	       (setf (gethash (list statei next-symbol) (entries action-table)) :accept))
 	     (record-goto (statei non-terminal)
-	       (let ((goto (index-of-goto (lr1-goto-for-symbol specification (elt states statei) non-terminal))))
+	       (let* ((state (elt states statei)) 
+		     (goto (gethash non-terminal (exits state))))
 		 (when goto
 		   (setf (gethash (list statei non-terminal) (entries goto-table)) goto)))))
       (loop for i from 0 below (length states)
       	 for state = (elt states i)
-      	 do (loop for item in state
+      	 do (loop for item in (items state)
       	       ;; action table
       	       do (let ((next-symbol (next-term-for-item item)))
       		    ;; we record nothing for errors, so a nil