Index: trunk/parse.lisp
===================================================================
--- trunk/parse.lisp	(revision trunk,1)
+++ trunk/parse.lisp	(revision trunk,2)
@@ -1,2 +1,12 @@
+(defpackage #:parse
+  (:use #:cl #:cl-ppcre)
+  (:export #:defgrammar
+	   #:token))
+
+(in-package #:parse)
+
+
+
+
 (defstruct token
   class
@@ -59,4 +69,28 @@
     ,@body))
 
+(defun substring (string &key (start 0) end length)
+  (when (and end length) (error "Specify only one of END or LENGTH."))
+  (when end (setf length (- end start)))
+  (unless length (setf length (- (length string) start)))
+  (make-array length
+	      :element-type 'character
+	      :displaced-to string
+	      :displaced-index-offset start))
+
+(defmacro scase (sym &body clauses)
+  (with-gensyms (sym-name)
+    `(let ((,sym-name (symbol-name ,sym)))
+      (cond
+	,@(mapcar #'(lambda (clause)
+		      (if (eq t (first clause))
+			  clause
+			  (let ((clause-sym-name (symbol-name (first clause)))
+				(clause-body (rest clause)))
+			    `((string= ,sym-name ,clause-sym-name)
+			      ,@clause-body))))
+		  clauses)))))
+
+
+
 
 
@@ -98,4 +132,21 @@
 	(when matched
 	  (parse-eqcount (1- count) rule-parser rlist (append tree mtree))))
+      (values t token-list tree)))
+
+(defun parse-mincount (count rule-parser token-list tree)
+  (if (> count 0)
+      (multiple-value-bind (matched rlist mtree)
+	  (funcall rule-parser token-list)
+	(when matched
+	  (parse-mincount (1- count) rule-parser rlist (append tree mtree))))
+      (parse-anycount rule-parser token-list tree)))
+
+(defun parse-maxcount (count rule-parser token-list tree)
+  (if (> count 0)
+      (multiple-value-bind (matched rlist mtree)
+	  (funcall rule-parser token-list)
+	(if matched
+	    (parse-maxcount (1- count) rule-parser rlist (append tree mtree))
+	    (values t token-list tree)))
       (values t token-list tree)))
 
@@ -112,4 +163,26 @@
 	      (values t (rest ,token-list) (list ,token))))))))
 
+(defun make-character-parser (ch)
+  (with-gensyms (str)
+    `(lambda (,str)
+      (when (and (> (length ,str) 0) (char= (char ,str 0) ,ch))
+	(values
+	 t
+	 (substring ,str :start 1)
+	 (list ,ch))))))
+
+(defun make-regex-parser (regex)
+  (let ((regex `(:sequence (:flags :single-line-mode-p) :start-anchor
+		 (:register (:regex ,regex)))))
+    (with-gensyms (str start end)
+      `(lambda (,str)
+	(multiple-value-bind (,start ,end) (scan (quote ,regex) ,str)
+	  (when ,start
+	    (values
+	     t
+	     (substring ,str :start ,end)
+	     (list (substring ,str :end ,end)))))))))
+
+
 (defun make-sequence-parser (rules)
   (with-gensyms (rule-parsers token-list)
@@ -133,4 +206,18 @@
 	(parse-eqcount ,count ,rule-parser ,token-list nil)))))
 
+(defun make-maxcount-parser (count rule)
+  (with-gensyms (rule-parser token-list)
+    `(let ((,rule-parser ,(make-parser rule)))
+      (lambda (,token-list)
+	(parse-maxcount ,count ,rule-parser ,token-list nil)))))
+
+(defun make-0or1-parser (rule) (make-maxcount-parser 1 rule))
+
+(defun make-+-parser (rule)
+  (with-gensyms (rule-parser token-list)
+    `(let ((,rule-parser ,(make-parser rule)))
+      (lambda (,token-list)
+	(parse-mincount 1 ,rule-parser ,token-list nil)))))
+
 (defun make-required-pred (rule)
   (with-gensyms (rule-parser token-list)
@@ -155,15 +242,26 @@
 	  (when ,matched (values t ,rlist nil)))))))
 
+(defmacro dispatch (sym fun)
+  `(progn
+    (when (cddr rule) (error ,(format nil "~A takes one argument" sym)))
+    (,fun (second rule))))
+
 (setf (symbol-function 'make-parser) (lambda (rule)
   (etypecase rule
     (symbol (make-token-parser rule))
+    (character (make-character-parser rule))
+    (string (make-regex-parser rule))
     (list
-     (case (first rule)
-       (& (make-required-pred (second rule)))
-       (! (make-forbidden-pred (second rule)))
-       (* (make-anycount-parser (cdr rule)))
-       (= (make-match-parser (cdr rule)))
-       (/ (make-choice-parser (cdr rule)))
-       (t (make-sequence-parser rule)))))))
+     (if (symbolp (first rule))
+	 (scase (first rule)
+	   (& (dispatch & make-required-pred))
+	   (! (dispatch ! make-forbidden-pred))
+	   (* (dispatch * make-anycount-parser))
+	   (? (dispatch ? make-0or1-parser))
+	   (+ (dispatch + make-+-parser))
+	   (= (make-match-parser (cdr rule)))
+	   (/ (make-choice-parser (cdr rule)))
+	   (t (make-sequence-parser rule)))
+	 (make-sequence-parser rule))))))
 
 
@@ -181,5 +279,6 @@
     (let ((parser ,(make-parser rule)))
       (multiple-value-bind (matched rlist mtree) (funcall parser token-list)
-	(when matched (values t rlist (list (quote ,name) mtree)))))))
+	(when matched
+	  (values t rlist (list (append (list (quote ,name)) mtree))))))))
 
 (defun make-named-class (name rule)
@@ -203,2 +302,9 @@
       `(progn
 	,@(mapcar make definitions)))))
+
+#|
+dot-all
+single-line
+import section
+skip tokens
+|#