Changeset trunk,3 for trunk/parse.lisp

Timestamp:

06/07/2007 10:11:03 PM (19 years ago)

Author:

dsowen

revision id:

svn-v3-trunk0:2948df59-2b31-0410-8e06-c40c0b09d5b6:trunk:3

Message:

Parser now fairly usable.

File:

• trunk/parse.lisp (modified) (5 diffs)

trunk/parse.lisp

@@ -8 +8 @@
 
 
-
 (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 +43 @@
                   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 +113 @@
 
 
+;; 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 +139 @@
 
 (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 +243 @@
 
 (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
 |#