Index: trunk/parse.lisp
===================================================================
--- trunk/parse.lisp	(revision trunk,2)
+++ trunk/parse.lisp	(revision trunk,3)
@@ -8,55 +8,7 @@
 
 
-
 (defstruct token
   class
   string)
-
-#|
-(defmacro defparser (name &body body))
-
-(defparser blah
-/  (simple ident)			; matches token class
-/  (seq-ex (e1 e2))			; matches e1 followed by e2
-/  (choice-ex (/ e1 e2))			; matches e1, or else e2
-/  (not-ex (! e1 e2))			; matches if not e1, and if not e2
-/  (require-ex (& e1 e2))		; matches if e1, and if e2 (pointless)
-  (kleene-ex1 (* e1 e2))		; matches e1* e2*
-  (kleene-ex2 (* (e1 e2)))		; matches (e1 e2)*
-  (req-ex1 (+ e1 e2))			; matches e1+ e2+
-  (req-ex2 (+ (e1 e2)))			; (e1 e2)+
-  (match-only (: e1 e2))		; matches and consumes, but
-					; doesn't emit
-  (match-only (: (e1 e2))))
-
-(defparser minijava-parser
-  (program (main-class (* class-decl)))
-  (main-class
-   ((: class)
-    ident
-    (: lbrace public static void main lparen string lbracket rbracket ident
-       rparen lbrace)
-    statement
-    (: rbrace rbrace)))
-  (ident id)
-  (statement (/ block if while print assign array-assign))
-  (block ((: lbrace) (* statement) (: rbrace)))
-  (if ((: if lparen) exp (: rparen) statement (: else) statement))
-  (while ((: while lparen) exp (: rparen) statement))
-  (print ((: sop lparen) exp (: rparen semicolon)))
-  (exp (/ num)))
-
-(class (id "A") lbrace public static void main lparen string lbracket rbracket
-       (id "args") rparen lbrace sop lparen (num 0) rparen semicolon rbrace
-       rbrace)
-
-(program
- (main-class
-  (ident "A")
-  (statement
-   (print
-    (num 0)))))
-|#
-
 
 ;;;; A parser returns, as a list, all parts matched; and, the
@@ -91,4 +43,12 @@
 		  clauses)))))
 
+(defmacro specials ((&body decls) &body body)
+  "Like LET, but declares the bound variables to be special."
+  `(let ,decls
+    (declare (special ,@(mapcar #'first decls)))
+    ,@body))
+
+(defun as-list (item) (if (listp item) item (list item)))
+
 
 
@@ -153,6 +113,12 @@
 
 
+;; This needs to be changed to just use the function of the given
+;; symbol-name, so that any format of sequence may be supported.
 (defun make-token-parser (token-class)
-  (declare (special definition-names))
+  (declare (special definition-names
+		    *import*))
+  (unless (or (member token-class definition-names)
+	      (member token-class *import*))
+    (warn "Parser ~A is neither defined nor imported." token-class))
   (if (member token-class definition-names)
       `(function ,token-class)
@@ -173,5 +139,6 @@
 
 (defun make-regex-parser (regex)
-  (let ((regex `(:sequence (:flags :single-line-mode-p) :start-anchor
+  (declare (special *regex-flags*))
+  (let ((regex `(:sequence (:flags ,@*regex-flags*) :start-anchor
 		 (:register (:regex ,regex)))))
     (with-gensyms (str start end)
@@ -276,35 +243,50 @@
 
 (defun make-named-parser (name rule)
+  (declare (special *filter*))
   `(defun ,name (token-list)
     (let ((parser ,(make-parser rule)))
       (multiple-value-bind (matched rlist mtree) (funcall parser token-list)
 	(when matched
-	  (values t rlist (list (append (list (quote ,name)) mtree))))))))
+	  (values t
+		  rlist
+		  ,(if *filter*
+		       `(list (append (list (quote ,name)) (,*filter* mtree)))
+		       `(list (append (list (quote ,name)) mtree))
+)))))))
 
 (defun make-named-class (name rule)
+  (declare (special *filter*))
   `(defun ,name (token-list)
     (let ((parser ,(make-parser rule)))
-      (funcall parser token-list))))
-
-(defun make-named (class-names definition)
-  (let ((name (car definition))
-	(rule (cadr definition)))
-    (if (member name class-names)
-	(make-named-class name rule)
-	(make-named-parser name rule))))
-
-(defmacro defgrammar (classes &body definitions)
-  (let ((definition-names (mapcar #'first definitions)))
-    (declare (special definition-names))
-    (let ((rule-map (hash-names definition-names))
-	  (make (lambda (definition) (make-named classes definition))))
-      (declare (special rule-map))
+      ,(if *filter*
+	   `(multiple-value-bind (matched rlist mtree)
+	     (funcall parser token-list)
+	     (when matched
+	       (values t rlist (,*filter* mtree))))
+	   `(funcall parser token-list)))))
+
+(defun make-named (definition)
+  (declare (special *classes*))
+  (destructuring-bind (name rule &key filter) definition
+    (specials ((*filter* filter))
+      (if (member name *classes*)
+	  (make-named-class name rule)
+	  (make-named-parser name rule)))))
+
+(defmacro defgrammar ((&key classes import regex-flags skip)
+		      &body definitions)
+  (specials ((*classes* classes)
+	     (*import* import)		; used only for warnings
+	     (*regex-flags* (as-list regex-flags))
+	     (*skip* skip)		; unused
+	     (definition-names (mapcar #'first definitions)))
+    (let ((rule-map (hash-names definition-names)))
       `(progn
-	,@(mapcar make definitions)))))
+	,@(mapcar #'make-named definitions)))))
 
 #|
-dot-all
-single-line
-import section
-skip tokens
+dot-all dot recognizes line-breaks
+single-line matches extend across lines
+import section supress warnings
+skip tokens automatically allow these between all parts
 |#