;;; Recursive descent parser generator
;;;
;;; (C) 2008 Gergő ÉRDI
;;; http://cactus.rulez.org/

(in-package :common-lisp-user)
(defpackage :cactus.parser-recdesc
  (:use :common-lisp :cactus.parser-readahead)
  (:export :defparser))

(in-package :cactus.parser-recdesc)

(defmacro defparser (name startrule &body rules)
  (let* ((startrule^ (gensym))
	 (eof-terminal (gensym))
	 (rules (cons `(,startrule^ (,startrule ,eof-terminal)) rules)))

    (with-readahead-functions rules
      (loop for (rulename . substs) in rules
	    for rulename-readaheads = (list)
	    do (loop for subst in substs
		     for subst-readahead = (readahead-terminals subst)		 
		     do (progn (if (some #'(lambda (readahead) (member readahead rulename-readaheads :test #'equal)) subst-readahead)
				   (error 'readahead-ambiguity-error :rulename rulename))
			       (setf rulename-readaheads (append subst-readahead rulename-readaheads)))))
      
      (labels ((descend-subst (rulename substnum subst)
		 `(progn
		   (list '(,rulename . ,substnum)
		    ,@(loop for sym in subst
			    collecting (if (rulename-p sym)
					   `(rule ',sym)
					   `(accept ',sym))))))
	       
	       (descender (rulename numbered-substs)
		 (if (cdr numbered-substs)
		     (let ((epsilon-substnum (first (find-if #'(lambda (numbered-subst) (epsilon-subst-p (second numbered-subst))) numbered-substs))))
		       `(cond
			 ,@(append (if epsilon-substnum
				       `(((or
					   ,@(let ((skip-terminals (skip-terminals rulename)))
						  (append `(,(if (member eof-terminal skip-terminals) '(not readahead)))
							  (loop for follow in skip-terminals
								when (not (eq follow eof-terminal))
								collecting `(terminal-matches-p readahead ',follow)))))
					  (list '(,rulename . ,epsilon-substnum)))))
				   (loop for (substnum subst) in numbered-substs
					 when (not (epsilon-subst-p subst))
					 collecting `((or ,@(loop for first in (readahead-terminals subst)
								  collecting `(terminal-matches-p readahead ',first)))
						      ,(descend-subst rulename substnum subst)))
				   '((t (error 'unexpected-token-error :found readahead))))))
		     (descend-subst rulename 1 (second (first numbered-substs))))))
	
	  `(defun ,name (tokens &optional (terminal-matcher #'eq))
	    (let ((input tokens))
	      (labels ((terminal-matches-p (terminal token)
			 (funcall terminal-matcher terminal token))
		       
		       (accept (token)
			 (let ((terminal (car input)))
			   (if (terminal-matches-p terminal token)
			       (setf input (cdr input))
			       (error 'unexpected-token-error :found terminal :expected token))
			   terminal))
		       
		       (rule (rulename)
			 (let ((readahead (car input)))
			   (ecase rulename
			     ,@ (let ((numbered-rules (loop for (rulename . substs) in rules
							    collecting (cons rulename (loop for subst in substs
											    for substnum from 1
											    collecting (list substnum subst))))))
				  
				  (loop for (rulename . numbered-substs) in numbered-rules
					when (not (eq rulename startrule^))
					collecting `((,rulename) ,(descender rulename numbered-substs))))))))
		(rule ',startrule))))))))