pattern: WIP implement matching for :zero-or-more

src/pattern.lisp

@@ -167,25 +167,18 @@
   ;; TODO Check length of "rest"
   (ref (second pattern)))
 
-;; Helper function for compound patterns that can take an arbitrary
-;; number of subpatterns.
-(defun rest-or-second (list)
-  (if (cddr list) (rest list) (second list)))
-;; (rest-or-second '(a b c)) => '(b c)
-;; (rest-or-second '(a b)) => 'b
-
 ;; Compile (:maybe ...)
 (defmethod compile-compound-pattern ((token (eql :maybe)) pattern)
   ;; TODO check the length of "pattern"
   (maybe (compile-pattern (second pattern)) (third pattern)))
 
 ;; Compile (:zero-or-more ...)
 (defmethod compile-compound-pattern ((token (eql :zero-or-more)) pattern)
-  (zero-or-more (compile-pattern (rest-or-second pattern))))
+  (zero-or-more (compile-pattern (rest pattern))))
 
 ;; Compile (:alternation ...)
 (defmethod compile-compound-pattern ((token (eql :alternation)) patterns)
-  (alternation (compile-pattern (rest-or-second patterns))))
+  (alternation (compile-pattern (rest patterns))))
 
 
 
@@ -254,10 +247,11 @@ a new iterator."
         (iterator-maybe-pop parent))
       iterator))
 
-(defun iterate (vector)
+(defun iterate (vector &key (step 1))
   "Create a new iterator."
   (check-type vector vector)
-  (iterator-maybe-push (make-iterator :vector vector)))
+  (iterator-maybe-push
+   (make-iterator :vector vector :step step)))
 
 (defun iterator-next (iterator)
   "Advance the iterator. Might return a whole new iterator."
@@ -316,6 +310,44 @@ a new iterator."
   (some (lambda (pat) (match pat input))
         (alternation-pattern pattern)))
 
+(defmethod match ((pattern zero-or-more) (input null))
+  t)
+
+(defmethod match ((pattern zero-or-more) input)
+  (match (zero-or-more-pattern pattern) input))
+
+;; TODO This is a mess
+(defmethod match ((pattern zero-or-more) (input vector))
+  (or (loop
+        ;; TODO  (make-empty-bindings)
+        :with bindings = t
+        :with pat = (zero-or-more-pattern pattern)
+        :for guard :below 100 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+                              ;; Iterate over the input
+        :for input-iterator := (iterate input)
+          :then (iterator-next input-iterator)
+        :until (iterator-done-p input-iterator)
+        ;; save the input iterator's position
+        ;; :for input-iterator-position = (iterator-position input-iterator)
+        ;; recurse+
+        :for new-bindings = (match pat input-iterator)
+        :if new-bindings
+          ;; collect all the bindings
+          :do (setf bindings (merge-bindings bindings new-bindings))
+        :else
+          ;; failed to match
+          :do
+             ;; rewind the input iterator
+             ;; (setf (iterator-position input-iterator) input-iterator-position)
+             ;; bail out of the whole function
+             (return-from match nil)
+        :finally (return-from match (if (iterator-done-p input-iterator)
+                                        nil
+                                        bindings)))
+      ;; if we get there, it means the pattern matched successfully,
+      ;; but there were no new bindings.
+      t))
+
 ;; Match a string literal
 (defmethod match ((pattern string) (input string))
   (string= pattern input))
@@ -360,7 +392,9 @@ a new iterator."
         :else
           ;; failed to match, bail out of the whole function
           :do (return-from match nil)
-        :finally (return bindings))
+        :finally (return-from match (if (iterator-done-p input-iterator)
+                                        nil
+                                        bindings)))
       ;; if we get there, it means the pattern matched successfully,
       ;; but there were no new bindings.
       t))

tests/pattern.lisp

@@ -170,9 +170,9 @@
   (is pattern= (maybe :x) (compile-pattern '(:maybe :x)))
   (is pattern= (maybe :x :?y) (compile-pattern '(:maybe :x :?y)))
   (is pattern= (maybe #(:x :y)) (compile-pattern '(:maybe (:x :y))))
-  (is pattern= (zero-or-more :x) (compile-pattern '(:zero-or-more :x)))
+  (is pattern= (zero-or-more #(:x)) (compile-pattern '(:zero-or-more :x)))
   (is pattern= (zero-or-more #(:x :y)) (compile-pattern '(:zero-or-more :x :y)))
-  (is pattern= (alternation :x) (compile-pattern '(:alternation :x)))
+  (is pattern= (alternation #(:x)) (compile-pattern '(:alternation :x)))
   (is pattern= (alternation #(:x :y)) (compile-pattern '(:alternation :x :y))))
 
 
@@ -335,6 +335,10 @@
   (false (match 'x 'y))
   (true (match #(a) '(a)))
   ;; TODO add vectors (but not arrays)
+  (false (match #(a b) #(a)))
+  (true (match #(a b) #(a b)))
+  ;; TODO this test fails
+  (false (match #(a b) #(a b a)))
   )
 
 ;;; TODO check the actual return values
@@ -383,6 +387,15 @@
     (is eq t (test-match pat 'b))
     (false (test-match pat 'c))))
 
+;; TODO This is a mess
+(define-test+run "match zero-or-more"
+  (true (test-match '(:zero-or-more a) nil))
+  (false (test-match '(:zero-or-more a b) '(a)))
+  (is eq t (test-match '(:zero-or-more a b) '(a b)))
+  ;; TODO (false (test-match '(:zero-or-more a b) '(a b a)))
+  (is eq t (test-match '(:zero-or-more a b) '(a b a b)))
+  (false (test-match '(:zero-or-more a b) 'a)))
+
 
 ;;; Testing patterns with references in them
 

workbench.lisp

@@ -187,4 +187,6 @@
 
 (trace merge-bindings)
 
+(trace match)
+
 (untrace)