Index: trunk/parse2.lisp
===================================================================
--- trunk/parse2.lisp	(revision trunk,4)
+++ trunk/parse2.lisp	(revision trunk,4)
@@ -0,0 +1,156 @@
+(require '#:parse)
+
+(use-package '#:parse)
+(import '(parse::with-gensyms parse::substring))
+
+(defvar *follow* t)
+
+(defmacro follow (fmt &rest args)
+  (when *follow*
+    `(format t ,fmt ,@args)))
+
+(defmacro with-character-parser ((name char) &body body)
+  (declare (symbol name)
+	   (character char))
+  (follow "with-character-parser~%")
+  (with-gensyms (input)
+    `(flet ((,name (,input)
+	     ,(format nil "Character parser for ~S." char)
+	     (declare (string ,input))
+	     (when (and (> (length ,input) 0) (char= (char ,input 0) ,char))
+	       (values t (substring ,input :start 1) '(,char)))))
+      ,@body)))
+
+(defmacro with-sequence-parser% ((name seq) &body body)
+  (declare (symbol name)
+	   (list seq))
+  (follow "with-sequence-parser%~%")
+  (with-gensyms (input tree head tail matched left found)
+    (if seq
+	`(with-sequence-parser% (,tail ,(rest seq))
+	  (with-parser (,head ,(first seq))
+	    (flet ((,name (,input ,tree)
+		     ,(format nil "Sequence parser for ~S." seq)
+		     (declare (list ,tree))
+		     (multiple-value-bind (,matched ,left ,found)
+			 (,head ,input)
+		       (when ,matched (,tail ,left (append ,tree ,found))))))
+	      ,@body)))
+	`(flet ((,name (,input ,tree)
+		 "Sequence parser base case."
+		 (declare (list ,tree))
+		 (values t ,input ,tree)))
+	  ,@body))))
+
+(defmacro with-sequence-parser ((name seq) &body body)
+  (declare (symbol name)
+	   (list seq))
+  (follow "with-sequence-parser~%")
+  (with-gensyms (subname input matched left found)
+    `(with-sequence-parser% (,subname ,seq)
+      (flet ((,name (,input)
+	       ,(format nil "Sequence parser head for ~S." seq)
+	       (multiple-value-bind (,matched ,left ,found)
+		   (,subname ,input nil)
+		 (when ,matched (values t ,left (list ,found))))))
+	,@body))))
+
+(defmacro with-choice-parser ((name alts) &body body)
+  (declare (symbol name)
+	   (list alts))
+  (follow "with-choice-parser~%")
+  (with-gensyms (head tail input matched left found)
+    (if alts
+	`(with-choice-parser (,tail ,(rest alts))
+	  (with-parser (,head ,(first alts))
+	    (flet ((,name (,input)
+		     ,(format nil "Choice parser for ~S." alts)
+		     (multiple-value-bind (,matched ,left ,found)
+			 (,head ,input)
+		       (if ,matched
+			   (values t ,left ,found)
+			   (,tail ,input)))))
+	      ,@body)))
+	`(flet ((,name (,input)
+		 "Choice parser for base case."
+		 (declare (ignore ,input))))
+	  ,@body))))
+
+(defmacro with-required-parser ((name rule) &body body)
+  (declare (symbol name))
+  (follow "with-required-parser~%")
+  (with-gensyms (sub input)
+    `(with-parser (,sub ,rule)
+      (flet ((,name (,input)
+	       ,(format nil "Required parser for ~S." rule)
+	       (when (,sub ,input) (values t ,input nil))))
+	,@body))))
+
+(defmacro with-forbidden-parser ((name rule) &body body)
+  (declare (symbol name))
+  (follow "with-forbidden-parser~%")
+  (with-gensyms (sub input)
+    `(with-parser (,sub ,rule)
+      (flet ((,name (,input)
+	       ,(format nil "Forbidden parser for ~S." rule)
+	       (unless (,sub ,input) (values t ,input nil))))
+	,@body))))
+
+(defmacro with-range-parser ((name mincount maxcount rule) &body body)
+  (declare (symbol name)
+	   ((or null (integer 0)) mincount)
+	   ((or null (integer 1)) maxcount))
+  (assert (or (not maxcount) (not mincount) (>= maxcount mincount)))
+  (follow "with-range-parser~%")
+  (with-gensyms (sub subname input min max tree matched left found)
+    `(with-parser (,sub ,rule)
+      (labels ((,subname (,min ,max ,input ,tree)
+		 (declare ((or null (integer 0)) ,min)
+			  ((or null (integer 0)) ,max))
+		 ,(format nil "Range parser {~S, ~S} for ~S."
+			  mincount maxcount rule)
+		 (cond
+		   ((and ,min (> ,min 0))
+		    (multiple-value-bind (,matched ,left ,found) (,sub ,input)
+		      (when ,matched
+			(,subname (1- ,min) (when ,max (1- ,max))
+				  ,left (append ,tree ,found)))))
+		   ((and ,max (> ,max 0))
+		    (multiple-value-bind (,matched ,left ,found) (,sub ,input)
+		      (if ,matched
+			  (,subname nil (1- ,max)
+				    ,left (append ,tree ,found))
+			  (values t ,input ,tree))))
+		   ((and ,max (= ,max 0)) (values t ,input ,tree))
+		   (t (multiple-value-bind (,matched ,left ,found)
+			  (,sub ,input)
+			(if ,matched
+			    (,subname nil nil ,left (append ,tree ,found))
+			    (values t ,input ,tree)))))))
+	(flet ((,name (,input) (,subname ,mincount ,maxcount ,input nil)))
+	  ,@body)))))
+
+(defmacro with-parser ((name rule) &body body)
+  (declare (symbol name))
+  (follow "with-parser~%")
+  (etypecase rule
+    (character
+     `(with-character-parser (,name ,rule) ,@body))
+    (list
+     (destructuring-bind (head . tail) rule
+       (case head
+	 (/ `(with-choice-parser (,name ,tail) ,@body))
+	 (& (destructuring-bind (subrule) tail
+	      `(with-required-parser (,name ,subrule) ,@body)))
+	 (! (destructuring-bind (subrule) tail
+	      `(with-forbidden-parser (,name ,subrule) ,@body)))
+	 ({} (destructuring-bind (mincount maxcount subrule) tail
+	       `(with-range-parser (,name ,mincount ,maxcount ,subrule)
+		 ,@body)))
+	 (* (destructuring-bind (subrule) tail
+	      `(with-range-parser (,name nil nil ,subrule) ,@body)))
+	 (+ (destructuring-bind (subrule) tail
+	      `(with-range-parser (,name 1 nil ,subrule) ,@body)))
+	 (? (destructuring-bind (subrule) tail
+	      `(with-range-parser (,name 0 1 ,subrule) ,@body)))
+	 (t `(with-sequence-parser (,name ,rule) ,@body)))))))