Source

HH-Parse / parser.lisp

(in-package :hh-parse)

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

;; Source code helper
(defmethod source-text ((parser lalr1-parser))
  (source-text (lexer parser)))

(defmethod (setf source-text) (text (parser lalr1-parser) )
  ;; Drop existing lines
  (setf (source-text (lexer parser)) text))

(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))
    expected))

(defun reduce-production (production symbol-values)
  (apply (reduction production) (rule-name production) symbol-values))

(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)
			     (let* ((production arg)
				    (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))
											   stack-token))))))
			       (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)))))

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

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

(defun parse-input (parser &optional input)
  (let ((lexer (lexer parser)))
    (when input (setf (source-text lexer) input))
    (loop for result = (parse-token parser (next-token lexer))
       while (equal :continue result)
       finally (return (values result (get-parse-result parser))))))

;; ---------------------------------------------------------------------------------------------------------------------
;;

(defmacro defparser (name &key grammar lexer)
  (let ((parser-factory (intern (format nil "MAKE-~a-PARSER" name) (symbol-package name)))
	(grammar-name (intern (format nil "~a-GRAMMAR" name) (symbol-package name)))
	(lexer-name (intern (format nil "~a-LEXER" name) (symbol-package name))))
    `(progn 

       (defgrammar ,grammar-name
	   ,@grammar)

       (deflexer ,lexer-name
	   ,@lexer)

       (defun ,parser-factory ()
	 (let ((grammar (,grammar-name))
	       (lexer (make-instance ',lexer-name)))
	   (make-parser lexer grammar))))))
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.