Index: trunk/parse.lisp
===================================================================
--- trunk/parse.lisp	(revision trunk,1)
+++ trunk/parse.lisp	(revision trunk,1)
@@ -0,0 +1,204 @@
+(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
+;;;; remainder of the token-list.  Named parts appear as sub-trees.
+
+
+
+(defmacro with-gensyms (syms &body body)
+  `(let (,@(mapcar (lambda (sym) `(,sym (gensym ,(symbol-name sym)))) syms))
+    ,@body))
+
+
+
+;; This is the entry-point for now.
+
+(defun make-parser (rule)
+  (declare (ignore rule))
+  nil)
+
+
+
+(defun parse-sequence (rule-parsers token-list tree)
+  (if rule-parsers
+      (multiple-value-bind (matched rlist mtree)
+	  (funcall (first rule-parsers) token-list)
+	(when matched
+	  (parse-sequence (rest rule-parsers) rlist (append tree mtree))))
+      (values t token-list tree)))
+
+(defun parse-choice (rule-parsers token-list)
+  (if rule-parsers
+      (multiple-value-bind (matched rlist mtree)
+	  (funcall (first rule-parsers) token-list)
+	(if matched
+	    (values t rlist mtree)
+	    (parse-choice (rest rule-parsers) token-list)))
+      nil))
+
+(defun parse-anycount (rule-parser token-list tree)
+  (multiple-value-bind (matched rlist mtree) (funcall rule-parser token-list)
+    (if matched
+	(parse-anycount rule-parser rlist (append tree mtree))
+	(values t token-list tree))))
+
+(defun parse-eqcount (count rule-parser token-list tree)
+  (if (> count 0)
+      (multiple-value-bind (matched rlist mtree)
+	  (funcall rule-parser token-list)
+	(when matched
+	  (parse-eqcount (1- count) rule-parser rlist (append tree mtree))))
+      (values t token-list tree)))
+
+
+
+(defun make-token-parser (token-class)
+  (declare (special definition-names))
+  (if (member token-class definition-names)
+      `(function ,token-class)
+      (with-gensyms (token-list token)
+	`(lambda (,token-list)
+	  (let ((,token (first ,token-list)))
+	    (when (and ,token-list (eq (token-class ,token) ',token-class))
+	      (values t (rest ,token-list) (list ,token))))))))
+
+(defun make-sequence-parser (rules)
+  (with-gensyms (rule-parsers token-list)
+    `(let ((,rule-parsers (list ,@(mapcar #'make-parser rules))))
+      (lambda (,token-list) (parse-sequence ,rule-parsers ,token-list nil)))))
+
+(defun make-choice-parser (rules)
+  (with-gensyms (rule-parsers token-list)
+    `(let ((,rule-parsers (list ,@(mapcar #'make-parser rules))))
+      (lambda (,token-list) (parse-choice ,rule-parsers ,token-list)))))
+
+(defun make-anycount-parser (rule)
+  (with-gensyms (rule-parser token-list)
+    `(let ((,rule-parser ,(make-parser rule)))
+      (lambda (,token-list) (parse-anycount ,rule-parser ,token-list nil)))))
+
+(defun make-eqcount-parser (count rule)
+  (with-gensyms (rule-parser token-list)
+    `(let ((,rule-parser ,(make-parser rule)))
+      (lambda (,token-list)
+	(parse-eqcount ,count ,rule-parser ,token-list nil)))))
+
+(defun make-required-pred (rule)
+  (with-gensyms (rule-parser token-list)
+    `(let ((,rule-parser ,(make-parser rule)))
+      (lambda (,token-list)
+	(when (funcall ,rule-parser ,token-list)
+	  (values t ,token-list nil))))))
+
+(defun make-forbidden-pred (rule)
+  (with-gensyms (rule-parser token-list)
+    `(let ((,rule-parser ,(make-parser rule)))
+      (lambda (,token-list)
+	(unless (funcall ,rule-parser ,token-list)
+	  (values t ,token-list nil))))))
+
+(defun make-match-parser (rule)
+  (with-gensyms (rule-parser token-list matched rlist)
+    `(let ((,rule-parser ,(make-parser rule)))
+      (lambda (,token-list)
+	(multiple-value-bind (,matched ,rlist)
+	    (funcall ,rule-parser ,token-list)
+	  (when ,matched (values t ,rlist nil)))))))
+
+(setf (symbol-function 'make-parser) (lambda (rule)
+  (etypecase rule
+    (symbol (make-token-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)))))))
+
+
+
+
+(defun hash-names (names &optional (map (make-hash-table)))
+  (if names
+    (let ((name (first names)))
+      (setf (gethash name map) name)
+      (hash-names (rest names) map))
+    map))
+
+(defun make-named-parser (name rule)
+  `(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 (quote ,name) mtree)))))))
+
+(defun make-named-class (name rule)
+  `(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))
+      `(progn
+	,@(mapcar make definitions)))))