;;; -*-lisp-*-
;;;
;;; Parser protocol implementation.
;;;
;;; (c) 2009 Straylight/Edgeware
;;;

;;;----- Licensing notice ---------------------------------------------------
;;;
;;; This file is part of the Sensible Object Design, an object system for C.
;;;
;;; SOD is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
;;;
;;; SOD is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with SOD; if not, write to the Free Software Foundation,
;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.

(cl:in-package #:sod-parser)

;;;--------------------------------------------------------------------------
;;; Hairy functions used by parser syntax expanders.

(declaim (inline %many))
(defun %many (update final parser &key (min 0) max)
  "Helper function for the `many' parser syntax.

   This deals with simple repetition, without separators.  See the parser
   syntax documentation for details."

  (let ((consumed-any-p nil))
    (do ((i 0 (1+ i)))
	((and max (>= i max)))
      (multiple-value-bind (value winp consumep) (funcall parser)
	(when consumep (setf consumed-any-p t))
	(cond (winp (funcall update value))
	      ((or consumep (< i min))
	       (return-from %many (values value nil consumed-any-p)))
	      (t (return)))))
    (values (funcall final) t consumed-any-p)))

(defun %many-sep (update final parser sep &key (min 1) max (commitp t))
  "Helper function for the `many' parser syntax.

   This deals with the hairy separator and commit stuff.  See the parser
   syntax documentation for details."

  (let ((consumed-any-p nil)
	(i 0))
    (block nil
      (flet ((sep ()
	       (multiple-value-bind (value winp consumep) (funcall sep)
		 (when consumep (setf consumed-any-p t))
		 (unless winp
		   (if (and (>= i min) (not consumep)) (return)
		       (return-from %many-sep
			 (values value nil consumed-any-p))))))

	     (main (mustp)
	       (multiple-value-bind (value winp consumep) (funcall parser)
		 (when consumep (setf consumed-any-p t))
		 (cond (winp (funcall update value))
		       ((or mustp consumep (< i min))
			(return-from %many-sep
			  (values value nil consumed-any-p)))
		       (t (return))))
	       (incf i)))

	(when (eql max 0) (return))

	(main nil)

	(if commitp
	    (loop (when (and max (>= i max)) (return)) (sep) (main t))
	    (loop (sep) (when (and max (>= i max)) (return)) (main nil)))))

    (values (funcall final) t consumed-any-p)))

;;;--------------------------------------------------------------------------
;;; Token parser implementation.

(defmethod parser-at-eof-p ((context token-parser-context))
  `(eq ,(parser-token-type context) :eof))

;;;--------------------------------------------------------------------------
;;; Simple list-based parser; useful for testing.

(export 'list-parser)
(defclass list-parser ()
  ((var :initarg :var :type symbol :reader parser-var)))

(defmethod parser-at-eof-p ((context list-parser))
  `(not ,(parser-var context)))

(defmethod parser-capture-place ((context list-parser))
  `,(parser-var context))

(defmethod parser-restore-place ((context list-parser) place)
  `(setf ,(parser-var context) ,place))

(defmethod expand-parser-spec ((context list-parser) parser)
  (if (atom parser)
      (expand-parser-form context 'quote (list parser))
      (call-next-method)))

(defparse quote (:context (context list-parser) object)
  `(if (and ,(parser-var context)
	    (eql (car ,(parser-var context)) ',object))
       (progn (pop ,(parser-var context)) (values ',object t t))
       (values (list ',object) nil nil)))

(defparse type (:context (context list-parser) type)
  `(if (and ,(parser-var context)
	    (typep (car ,(parser-var context)) ',type))
       (values (pop ,(parser-var context)) t t)
       (values (list ',type) nil nil)))

(defmethod parser-places-must-be-released-p ((context list-parser)) nil)

;;;--------------------------------------------------------------------------
;;; Simple string-based parser; useful for testing.

(export 'string-parser)
(defclass string-parser (character-parser-context)
  ((%string :initarg :string :reader parser-string)
   (index :initarg :index :initform 0 :reader parser-index)
   (%length :initform (gensym "LEN-") :reader parser-length)))

(defmethod wrap-parser ((context string-parser) form)
  (with-slots ((string %string) index (length %length)) context
    `(let* (,@(unless (symbolp string)
		(let ((s string))
		  (setf string (gensym "STRING-"))
		  `((,string ,s))))
	    ,@(unless (symbolp index)
		(let ((i index))
		  (setf index (gensym "INDEX-"))
		  `((,index ,i))))
	      (,length (length ,string)))
       ,form)))

(defmethod parser-at-eof-p ((context string-parser))
  `(>= ,(parser-index context) ,(parser-length context)))

(defmethod parser-current-char ((context string-parser))
  `(char ,(parser-string context) ,(parser-index context)))

(defmethod parser-step ((context string-parser))
  `(incf ,(parser-index context)))

(defmethod parser-capture-place ((context string-parser))
  `,(parser-index context))

(defmethod parser-restore-place ((context string-parser) place)
  `(setf ,(parser-index context) ,place))

(defmethod parser-places-must-be-released-p ((context string-parser)) nil)

;;;----- That's all, folks --------------------------------------------------