ARNESI

A fare-like matchingfacility 

The code is written in CPS style, it's hard to understand at first but once you "get it" it's actually quite simple. Basically the idea is that at every point during a match one of two things can happen, the match can succedd or it can fail. What we do is we pass every match two functions (closures usually), one which specifies what to if it succedds and one which specifies what to do if it fails. These two closures can refer to the original matchs parameter and hence we can easily "backtrack" if we fail. Another important aspect is that we explcitly pass the target against which to match, if we didn't do this it would be impossible to really backtrack.

The matching and compiling environment 

(deflookup-table match-handler
  :documentation "Table mapping symbol names to the matching function")

(defstruct (match-state (:conc-name ||))
  target
  bindings
  matched)

Matching 

Matching forms 

(def-matcher :bind (spec var)
  "The :bind matcher attempts to match MATCHER and bind whatever
   MATCHER consumnd to VAR. group is equivalent to SPEC except the value
   of matched when spec has matched will be bound to var."
  (declare (special %bind-vars%))
  (push var %bind-vars%)
  (let ((spec-matcher (%make-matcher spec)))
    (lambda (s k q)
      (funcall spec-matcher s
	       (lambda (s. k. q.)
		 (declare (ignore k.))
		 ;; SPEC succeded, bind var
		 (funcall k (copy-state s. :bindings (cons (cons var (matched s.)) (bindings s.)))
			  k q.))
	       q))))

(def-matcher :ref (var &key (test #'eql))
  (lambda (s k q)
    (if (and (assoc var (bindings s))
	     (funcall test (target s) (cdr (assoc var (bindings s)))))
	(funcall k (copy-state s :matched (target s))
		 k q)
        (funcall q s k q))))

(def-matcher :alternation (a-spec b-spec)
  (let ((a (%make-matcher a-spec))
	(b (%make-matcher b-spec)))
    (lambda (s k q)
      ;; first try A
      (funcall a s k
	       ;; a failed, try B
	       (lambda (s. k. q.)
		 (declare (ignore s. k. q.))
		 (funcall b s k q))))))

(def-matcher-macro :alt (&rest possibilities)
  (case (length possibilities)
    (0 `(:fail))
    (1 (car possibilities))
    (t `(:alternation ,(car possibilities) (:alt ,@(cdr possibilities))))))

(def-matcher :fail ()
  (lambda (s k q)
    (funcall q s k q)))

(def-matcher :not (match)
  (let ((m (%make-matcher match)))
    (lambda (s k q)
      (funcall m s q k))))

(def-matcher :anything ()
  (lambda (s k q)
    (funcall k (copy-state s :matched (target s))
	     k q)))

Matching within a sequence 

(def-matcher :greedy-star (match)
  (make-greedy-star (%make-matcher match)))

The actual matching operators 

All of the above allow us to build matchers but non of them actually match anything.

(def-matcher :test (predicate)
  "Matches if the current matches satisfies PREDICATE."
  (lambda (s k q)
    (if (funcall predicate (target s))
	(funcall k (copy-state s :matched (target s))
		 k q)
        (funcall q s k q))))

(def-matcher-macro :test-not (predicate)
  `(:not (:test ,predicate)))

(def-matcher-macro :satisfies-p (predicate)
  `(:test ,(lambda (target) (funcall predicate target))))

(def-matcher-macro :eq (object)
  `(:test ,(lambda (target) (eq object target))))

(def-matcher-macro :eql (object)
  `(:test ,(lambda (target) (eql object target))))

(def-matcher-macro cl:quote (constant)
  `(:eql ,constant))

(def-matcher-macro :equal (object)
  `(:test ,(lambda (target) (equal object target))))

(def-matcher-macro :equalp (object)
  `(:test ,(lambda (target) (equalp object target))))

(def-matcher :cons (car-spec cdr-spec)
  (let ((car (%make-matcher car-spec))
	(cdr (%make-matcher cdr-spec)))
    (lambda (s k q)
      (if (consp (target s))
	  (funcall car (copy-state s :target (car (target s)))
		   (lambda (s. k. q.)
		     (declare (ignore k.))
		     ;; car matched, try cdr
		     (funcall cdr (copy-state s. :target (cdr (target s)))
			      (lambda (s.. k.. q..)
				(declare (ignore k.. q..))
				;; cdr matched, ok, we've matched!
				(funcall k (copy-state s.. :matched (target s))
					 k q))
			      q.))
		   q)
	  (funcall q s k q)))))

(def-matcher-macro :list (&rest items)
  `(:list* ,@items nil))

(def-matcher-macro :list* (&rest items)
  (case (length items)
    (1 (car items))
    (2 `(:cons ,(first items) ,(second items)))
    (t
     `(:cons ,(first items) (:list* ,@(cdr items))))))