Index: trunk/parse3.lisp
===================================================================
--- trunk/parse3.lisp	(revision trunk,7)
+++ trunk/parse3.lisp	(revision trunk,7)
@@ -0,0 +1,169 @@
+(defmacro while (cond &body body)
+  `(do ()
+    ((not ,cond))
+    ,@body))
+
+(defmacro if-matcher-parser (input parser (next match)
+				   &body (&optional (then t) else))
+  (declare (symbol parser next match))
+  (with-gensyms (ok)
+    `(multiple-value-bind (,ok ,next ,match) (,parser ,input)
+      (if ,ok ,then ,else))))
+
+(defmacro if-matches-char (input char (next match)
+				 &body (&optional (then t) else))
+  (declare (symbol next match)
+	   (character char))
+  `(if (and (string/= "" ,input) (char= ,char (char ,input 0)))
+    (let ((,next (substring ,input :start 1))
+	  (,match ,char))
+      ,then)
+    ,else))
+
+(defmacro if-matches-string (input string (next match)
+				   &body (&optional (then t) else))
+  (declare (symbol next match)
+	   (string string))
+  (let ((len (length string)))
+    `(if (string= ,string (substring ,input :length ,len))
+      (let ((,next (substring ,input :start ,len))
+	    (,match ,string))
+	,then)
+      ,else)))
+
+(defmacro if-matches-regex (input regex (next match)
+				  &body (&optional (then t) else))
+  (declare (string regex)
+	   (symbol next match))
+  (let ((regex `(:sequence (:flags) :start-anchor
+		 (:register (:regex ,regex)))))
+    (with-gensyms (start end)
+      `(multiple-value-bind (,start ,end) (scan ',regex ,input)
+	(if ,start
+	    (let ((,next (substring ,input :start ,end))
+		  (,match (substring ,input :end ,end)))
+	      ,then)
+	    ,else)))))
+
+(defmacro if-matches-choice (input alts (next match)
+				   &body (&optional (then t) else))
+  (declare (symbol next match)
+	   (list alts))
+  (if alts
+      `(if-matches ,input ,(first alts) (,next ,match)
+	,then
+	(if-matches-choice ,input ,(rest alts) (,next ,match)
+	  ,then
+	  ,else))
+      else))
+
+(defmacro if-matches-sequence (input seq (next match)
+				     &body (&optional (then t) else))
+  (destructuring-bind (head . tail) seq
+    (if tail
+	(with-gensyms (head-next head-match tail-match)
+	  `(if-matches ,input ,head (,head-next ,head-match)
+	    (if-matches-sequence ,head-next ,tail (,next ,tail-match)
+	     (let ((,match (cons ,head-match ,tail-match)))
+	       ,then)
+	     ,else)
+	    ,else))
+	(with-gensyms (head-match)
+	  `(if-matches ,input ,head (,next ,head-match)
+	    (let ((,match (cons ,head-match nil)))
+	      ,then)
+	    ,else)))))
+
+(defmacro if-matches-eqcount (input count rule (next match)
+				    &body (&optional (then t) else))
+  "WARNING: ELSE code executes in an anonymous block!"
+  (declare ((or null (integer 0)) count)
+	   (symbol next match))
+  (with-gensyms (r i next2 match2)
+    `(block ,r
+      (let ((,next ,input)
+	    (,match nil))
+	(dotimes (,i ,(if count count 0))
+	  (if-matches ,next ,rule (,next2 ,match2)
+	    (setf ,next ,next2
+		  ,match (nconc ,match (list ,match2)))
+	    (return-from ,r ,else)))
+	,then))))
+
+;;; This doesn't quite work yet.
+(defmacro if-matches-maxcount (input count rule (next match)
+				     &body (&optional (then t) else))
+  (declare ((or null (integer 0)) count)
+	   (symbol next match)
+	   (ignore else))
+  (with-gensyms (i next2 match2)
+    `(let ((,next ,input)
+	   (,match nil))
+      (let ((,i 0))
+	(while (and ,(if count `(< ,i ,count) t)
+		    (if-matches ,next ,rule (,next2 ,match2)
+		      (progn
+			(psetf ,next ,next2
+			       ,match (nconc ,match (list ,match2))
+			       ,i (1+ ,i))
+			t)))))
+      ,then)))
+
+(defmacro if-matches-count (input mincount maxcount rule (next match)
+				  &body (&optional (then t) else))
+  (with-gensyms (next2 match2)
+    `(if-matches-eqcount ,input ,mincount ,rule (,next2 ,match2)
+      (if-matches-maxcount ,next2 ,maxcount ,rule (,next ,match)
+	(let ((,match (nconc ,match2 ,match)))
+	  ,then)
+	,else)
+      ,else)))
+
+;;; The required and forbidden rules don't quite work right, as using
+;;; a rule like (#\a (& #\b)) will put an extaneous NIL on the end of
+;;; the match tree.
+
+(defmacro if-matches-required (input rule (next match)
+				     &body (&optional (then t) else))
+  `(if-matches ,input ,rule (,(gensym) ,(gensym))
+    (let ((,next ,input)
+	  (,match nil))
+      ,then)
+    ,else))
+
+(defmacro if-matches-forbidden (input rule (next match)
+				      &body (&optional (then t) else))
+  `(if-matches ,input ,rule (,(gensym) ,(gensym))
+    ,else
+    (let ((,next ,input)
+	  (,match nil))
+      ,then)))
+
+(defmacro if-matches (input rule (next match) &body (&optional (then t) else))
+  (etypecase rule
+    (symbol `(if-matcher-parser ,input ,rule (,next ,match) ,then ,else))
+    (character `(if-matches-char ,input ,rule (,next ,match) ,then ,else))
+    (string `(if-matches-string ,input ,rule (,next ,match) ,then ,else))
+    (list
+     (destructuring-bind (head . tail) rule
+       (case head
+	 (^ (destructuring-bind (regex) tail
+	      `(if-matches-regex ,input ,regex (,next ,match) ,then ,else)))
+	 (/ `(if-matches-choice ,input ,tail (,next ,match) ,then ,else))
+	 ({} (destructuring-bind (mincount maxcount subrule) tail
+	       `(if-matches-count ,input ,mincount ,maxcount ,subrule
+		 (,next ,match) ,then ,else)))
+	 (* (destructuring-bind (sub) tail
+	      `(if-matches-count ,input 0 nil ,sub (,next ,match)
+		,then ,else)))
+	 (? (destructuring-bind (sub) tail
+	      `(if-matches-count ,input 0 1 ,sub (,next ,match) ,then ,else)))
+	 (+ (destructuring-bind (sub) tail
+	      `(if-matches-count ,input 1 nil ,sub (,next ,match)
+		,then ,else)))
+	 (& (destructuring-bind (sub) tail
+	      `(if-matches-required ,input ,sub (,next ,match) ,then ,else)))
+	 (! (destructuring-bind (sub) tail
+	      `(if-matches-forbidden ,input ,sub (,next ,match) ,then ,else)))
+	 (t `(if-matches-sequence ,input ,rule (,next ,match)
+	      ,then ,else)))))))