Phil Hargett  committed 5590460

Some cleanup to encapsulate parser contexts better

  • Participants
  • Parent commits 7c0db83
  • Branches default

Comments (0)

Files changed (1)

 (defun reduce-production (production symbol-values)
   (apply (reduction production) (rule-name production) symbol-values))
+;; parser context helpers
+(defun push-parser-context (parser state node)
+  "Because the parser is a table-driven LR parser, the parser uses a stack to manage
+   its progress through a parse.  The entries in this stack are contexts, each of which
+   is a 2-element list.  The 1st element in a context is the state (a number) associated
+   with the context: the state in the context on the top of the stack is the state
+   used by the LR parsing algorithm for table lookups.  The 2nd element is a node (see
+   current-parser-node for details)."
+  (push (list state node) (stack parser)))
+(defun current-parser-context (parser)
+  (car (stack parser)))
+(defun pop-parser-context (parser)
+  (pop (stack parser)))
+(defun pop-parser-node (parser)
+  (when (stack parser)
+    (destructuring-bind (state node) (pop-parser-context parser)
+      (declare (ignorable state))
+      node)))
+(defun current-parser-state (parser)
+  (when (stack parser)
+    (destructuring-bind (state node) (current-parser-context parser)
+      (declare (ignorable node))
+      state)))
+(defun current-parser-node (parser)
+  "Return the node in the context on the top of a parser's stack. The parser understands a node as a 2-element list,
+  where the first element is a symbol identifying the node type (and corresponding to a symbol in the underlying grammar),
+  and the second element is (usually) an AST node"
+  (when (stack parser)
+    (destructuring-bind (state node) (current-parser-context parser)
+      (declare (ignorable state))
+      node)))
+(defun get-parse-result (parser)
+  (current-parser-node parser))
+;; parsing
 (defun parse-token (parser token)
   "Advance the state of the parser by parsing a single token; does not assume token came from lexer"
   (let ((grammar (grammar parser)))
       (loop with continue = t
 	 with result = nil
 	 while continue
-	 do (destructuring-bind (stack-state stack-token) (car (stack parser))
-	      (declare (ignorable stack-token))
+	 do (let ((stack-state (current-parser-state parser)))
 	      (let ((action (gethash (list stack-state token-symbol) (entries (actions grammar)))))
 		(if action
 		    (destructuring-bind (op arg) action
 		      (cond ((equal :shift op)
 			     (let ((next-state arg))
-			       (push (list next-state token) (stack parser))
+			       (push-parser-context parser next-state token)
 			       (setf continue nil)
 			       (setf result :continue)))
 				    (reduced-term (reduce-production production 
 								     ;; we reverse the values, because they were on stack in reverse
 								     (reverse (loop for i from 1 to (length (slot-value production 'rhs))
-										 collect (destructuring-bind (stack-state stack-token) (pop (stack parser))
-											   (declare (ignorable stack-state))
-											   (destructuring-bind (token-name token-value) stack-token
-											     (declare (ignorable token-name))
-											     token-value)))))))
-			       (destructuring-bind (new-stack-state new-stack-token) (car (stack parser))
-				 (declare (ignorable new-stack-token))
-				 (push (list (gethash (list new-stack-state (slot-value production 'rule-name )) (entries (gotos grammar))) 
-					     (list (slot-value production 'rule-name) reduced-term))
-				       (stack parser)))))
+										 collect (let ((stack-node (pop-parser-node parser)))
+											   (destructuring-bind (node-type node-value) stack-node
+											     (declare (ignorable node-type))
+											     node-value)))))))
+			       (let ((new-stack-state (current-parser-state parser)))
+				 (push-parser-context parser 
+						      (gethash (list new-stack-state (slot-value production 'rule-name )) (entries (gotos grammar)))
+						      (list (slot-value production 'rule-name) reduced-term)))))
 			    ((equal :accept op)
 			     (setf continue nil)
 		      (setf continue nil)
 		      (setf result :failed)))))
-	 finally (return (values result (car (stack parser))))))))
-(defun make-parser (lexer grammar)
-  (let ((parser (make-instance 'lalr1-parser :lexer lexer :grammar grammar)))
-    (push (list 0 'start-rule) (stack parser))
-    parser))
-(defun get-parse-result (parser)
-  (when (stack parser)
-    (destructuring-bind (stack-state stack-token) (car (stack parser))
-      (declare (ignore stack-state))
-      stack-token)))
+	 finally (return (values result (current-parser-context parser)))))))
 (defun parse-input (parser &optional input)
   (let ((lexer (lexer parser)))
        while (equal :continue result)
        finally (return (values result (get-parse-result parser))))))
+(defun make-parser (lexer grammar)
+  (let ((parser (make-instance 'lalr1-parser :lexer lexer :grammar grammar)))
+    (push-parser-context parser 0 'start-rule)
+    parser))
 ;; ---------------------------------------------------------------------------------------------------------------------