Changeset trunk,2 for trunk

Timestamp:

06/01/2007 02:43:59 PM (19 years ago)

Author:

dsowen

revision id:

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

Message:

Packaged for ASDF.
Added character and regex support.
Added + and ? rules.

Location:

trunk

Files:

• parse.asd (added)
• parse.lisp (modified) (8 diffs)

trunk/parse.lisp

@@ +1 @@
+(defpackage #:parse
+  (:use #:cl #:cl-ppcre)
+  (:export #:defgrammar
+           #:token))
+
+(in-package #:parse)
+
+
+
+
 (defstruct token
   class
@@ -59 +69 @@
     ,@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 +132 @@
         (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 +163 @@
               (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 +206 @@
         (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 +242 @@
           (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 +279 @@
     (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 +302 @@
       `(progn
         ,@(mapcar make definitions)))))
+
+#|
+dot-all
+single-line
+import section
+skip tokens
+|#