HH-Parse / parser.lisp

(in-package :hh-parse)

;; ---------------------------------------------------------------------------------------------------------------------
;; LALR(1) parser construction

;; Classes + types

(defclass lalr1-parser ()
  ((grammar :initarg :grammar :accessor grammar)
   (lexer :initarg :lexer :accessor lexer)
   (stack :initform () :accessor stack)))

(defun expected-next-symbols (parser)
  "Given a parser's current state, return a list of valid symbols (terminal and non-terminal) that would advance the parse"
  (let ((state (caar (stack parser)))
	(actions (entries (actions (grammar parser))))
	(expected ()))
    (loop for (expected-state expected-symbol) being the hash-key of actions
	 if (= state expected-state ) 
	 do (push expected-symbol expected))

(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)))
    (destructuring-bind (token-symbol token-value) (if token token (list :eof nil))
      (declare (ignorable token-value))
      (loop with continue = t
	 with result = nil
	 while continue
	 do (destructuring-bind (stack-state stack-token) (car (stack parser))
	      (declare (ignorable stack-token))
	      (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))
			       (setf continue nil)
			       (setf result :continue)))

			    ((equal :reduce op)
			     ;; NOTE : if there is a semantic action, after the reduction is a good time to call it
			     (let ((production arg))
			       (loop for i from 1 to (length (slot-value production 'rhs))
				  do (pop (stack parser)))
			       (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))) 
					     (slot-value production 'rule-name))
				       (stack parser)))))

			    ((equal :accept op)
			     (setf continue nil)
			     (setf result :succeeded))

			    (t (setf continue nil)
			       (setf result :failed))))
		      (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))

(defun get-parse-result (parser)
  (when (stack parser)
    (destructuring-bind (stack-state stack-token) (car (stack parser))
      (declare (ignore stack-state))

(defun parse-input (parser)
  (let ((lexer (lexer parser)))
    (loop for result = (parse-token parser (next-token lexer))
       while (equal :continue result)
       finally (return (values result (get-parse-result parser))))))