MATCH macro for Common Lisp

match.lisp

;; MATCH -- A CASE-like construct with pattern matching.

;; Syntax:
;;
;; (match expr
;;   (pattern1 . body1)
;;   (pattern2 . body2)
;;   ...
;;   (patternN . bodyN))
;;

;; Semantics:
;;
;; First, EXPR is evaluated. The value is then matched against the patterns
;; in the order they are listed. At the first successful match, the variables
;; are bound according to the pattern and the belonging body is evaluated with
;; the newly bound variables in the environment.
;;   The last pattern is allowed to be a single symbol, which then behaves just
;; like an ordinary LET and will always lead to a successful match. If there are
;; subsequent clauses after a clause with a single symbol pattern, a warning is
;; issued and the remaining clauses are ignored.
;;   If the value of EXPR could not be successfully matched with any pattern, an
;; error is raised.
;;   The value of MATCH is the value of the body evaluated.
;;

;; Explanation:
;;
;; A clause (pattern . body) is in general expanded into
;;
;;   (ignore-errors
;;     (destructuring-bind PATTERN #:VALUE
;;       (lambda () . BODY)))
;;
;; Where #:VALUE is an internally used GENSYM that is bound to the value of EXPR.
;;   The body is enclosed in a LAMBDA which is then immediately passed to an
;; outer FUNCALL. This is done so that the body is not affected by IGNORE-ERRORS.
;; This would have otherwise caused any errors in the body to be ignored! The
;; sole purpose of IGNORE-ERRORS here is to jump out of a failed pattern match.
;;

(defmacro match (expr &body clauses)
  (let ((value-symbol (gensym "VALUE")))
    `(let ((,value-symbol ,expr))
       (funcall
	(or ,@(loop
		 for ((pattern . body) . subsequent-clauses) on clauses
		 if (symbolp pattern) collect
		   `(let ((,pattern ,value-symbol))
		      (lambda () ,@body))
		 and do
		   (when subsequent-clauses
		     (warn "Single symbol pattern used in the middle of a MATCH statement. Subsequent clauses ignored.")
		     (loop-finish))
		 else collect
		   `(ignore-errors
		      (destructuring-bind ,pattern ,value-symbol
			(lambda () ,@body)))
		 and unless subsequent-clauses collect
		   `(lambda ()
		      (error "Failed to match ~a." ,value-symbol)) ) ))) ))