Reimplementation pattern-matching algorithm.

README.markdown

@@ -1,7 +1,7 @@
 cl-pattern
-=======
+==========
 
-cl-pattern is a Common Lisp library that provides ML-like (OCaml, Haskell, etc) pattern matching facilities.
+cl-pattern is a very fast ML-like pattern-matching library for Common Lisp.
 
 Usage
 -----
@@ -10,7 +10,7 @@ Usage
 
     (match value &body clauses)
 
-`match` macro tries to match `value` with `clauses` and raise errors if no clauses matched. Clause have to be a form of `(pattern* form*)`, where `pattern` can be a symbol for binding values, a atom for matching values, and a composed form of them (with `destructuring-bind`). Binding to `_` will be ignored (i.e. `(declare (ignore _))`) automatically and its binding can't be used anywhere. If `pattern` is one of `t`, `otherwise`, and `_`, its clause will be matched with any value.
+`match` macro tries to match `value` with `clauses` and raise errors if no clauses matched. Clause have to be a form of `(pattern form*)`, where `pattern` is a symbol for binding values, an atom for matching values, and a composed form of them. Binding to `_` will be ignored (i.e. `(declare (ignore _))`) automatically and its binding can't be used anywhere. If `pattern` is `_`, its clause will be matched with any value.
 
 #### Examples
 
@@ -46,47 +46,13 @@ Usage
       (t 'otherwise))
     ; => OTHERWISE
 
-    (match '("a" :x 1)
-      ((a &key x)
-       (list a x)))
-    ; => ("a" 1)
-
     (defun sum (lst)
       (match lst
         (() 0)
         ((x . xs) (+ x (sum xs)))))
     (sum '(1 2 3))
     ; => 6
 
-### let+
-
-    (let+ bindings &body body)
-
-Unlike `let` macro, `let+` macro tries to bind variables with pattern using `match` macro. Binding have to be a form of `(pattern+ form)`, where `pattern` is of `match` macro. If multiple patterns are given, `let+` macro assumes that `form` returns multiple values and bind them with `multiple-value-bind`. Binding variables is not simultaneous but sequential like `let*` macro.
-
-#### Examples
-
-    (let+ ((x 1))
-      x)
-    ; => 1
-
-    (let+ (((x y) '(1 2)))
-      (+ x y))
-    ; => 3
-
-    (let+ (((x y) '(1)))
-      (+ x y))
-    ; => match error
-
-    (let+ ((a b c (values 1 2 3)))
-      (list a b c))
-    ; => (1 2 3)
-
-    (let+ ((a 1)
-           (b a))
-      b)
-    ; => 1
-
 License
 -------
 

cl-pattern-test.asd

@@ -0,0 +1,14 @@
+(in-package :cl-user)
+
+(defpackage cl-pattern-test-asd
+  (:use :cl :asdf))
+
+(in-package :cl-pattern-test-asd)
+
+(defsystem cl-pattern-test
+  :depends-on (:cl-test-more :cl-pattern)
+  :components
+  ((:module "t"
+    :serial t
+    :components
+    ((:file "match")))))

cl-pattern.asd

@@ -7,11 +7,15 @@
 
 (defsystem cl-pattern
   :version "0.1"
-  :depends-on (:alexandria)
-  :components ((:module "src"
-                        :serial t
-                        :components ((:file "package")
-                                     (:file "utils")
-                                     (:file "optimize")
-                                     (:file "let")
-                                     (:file "match")))))
+  :author "Tomohiro Matsuyama"
+  :license "LLGPL"
+  :depends-on (:cl-annot :alexandria)
+  :components
+  ((:module "src"
+    :serial t
+    :components ((:file "package")
+                 (:file "condition")
+                 (:file "pattern")
+                 (:file "case")
+                 (:file "compile")
+                 (:file "match")))))

src/case.lisp

@@ -0,0 +1,34 @@
+(in-package :cl-pattern)
+
+(annot:enable-annot-syntax)
+
+@eval-always
+(defun compile-case-clause (var clause else)
+  (destructuring-bind (pattern then)
+      clause
+    (ecase (pattern-type pattern)
+      (:const
+       `(if (%equal ,pattern ,var) ,then ,else))
+      (:var
+       `(let ((,pattern ,var)) ,then))
+      (:cons
+       `(if (consp ,var)
+            (let ((,(car pattern) (car ,var))
+                  (,(cdr pattern) (cdr ,var)))
+              (declare (ignorable ,(car pattern) ,(cdr pattern)))
+              ,then)
+            ,else)))))
+
+@eval-always
+(defun compile-case (var clauses else)
+  (reduce (lambda (clause else) (compile-case-clause var clause else))
+          clauses
+          :initial-value else
+          :from-end t))
+
+(defmacro %case (arg clauses else)
+  (if (atom arg)
+      (compile-case arg clauses else)
+      (with-gensyms (var)
+        `(let ((,var ,arg))
+           ,(compile-case var clauses else)))))

src/compile.lisp

@@ -0,0 +1,92 @@
+(in-package :cl-pattern)
+
+(annot:enable-annot-syntax)
+
+(defun partition-match-clauses (clauses)
+  (loop with groups
+        with group-type
+        with group-clauses
+        for clause in clauses
+        for head-pattern = (caar clause)
+        for head-pattern-type = (pattern-type head-pattern)
+        do
+     (or group-type (setf group-type head-pattern-type))
+     (if (eq head-pattern-type group-type)
+         (push clause group-clauses)
+         (progn
+           (push (cons group-type (nreverse group-clauses)) groups)
+           (setf group-type head-pattern-type
+                 group-clauses (list clause))))
+        finally
+     (if group-type
+         (push (cons group-type (nreverse group-clauses)) groups))
+     (return (nreverse groups))))
+
+(defun compile-match-variable (vars clauses else)
+  `(%match ,(cdr vars)
+     ,(loop for ((var . rest) . then) in clauses
+            if (string-equal var "_")
+              collect `(,rest ,@then)
+            else
+              collect `(,rest (let ((,var ,(car vars)))
+                                (declare (ignorable ,var))
+                                ,@then)))
+     ,else))
+
+(defun compile-match-constant (vars clauses else)
+  (loop with alist
+        for ((constant . rest) . then) in clauses
+        for sub-clause = (cons rest then)
+        for assoc = (assoc constant alist :test #'equal)
+        if assoc
+          do (setf (cdr assoc) (cons sub-clause (cdr assoc)))
+        else
+          do (push `(,constant ,sub-clause) alist)
+        finally
+     (return
+       `(%case ,(car vars)
+          ,(loop for pair in (nreverse alist)
+                 for constant = (car pair)
+                 for sub-clauses = (nreverse (cdr pair))
+                 collect
+                 `(,constant
+                    (%match ,(cdr vars) ,sub-clauses (%match-error))))
+          ,else))))
+
+(defun compile-match-constructor (vars clauses else)
+  (let ((var (car vars)))
+    (with-gensyms (car cdr)
+      `(if (consp ,var)
+           (let ((,car (car ,var))
+                 (,cdr (cdr ,var)))
+             (declare (ignorable ,car ,cdr))
+             (%match ,`(,car ,cdr ,@(cdr vars))
+               ,(loop for (((par . pdr) . rest) . then) in clauses
+                      collect
+                      `(,`(,par ,pdr ,@rest) ,@then))
+               ,else))
+           ,else))))
+
+(defun compile-match-empty (clauses else)
+  (loop for (pattern . then) in clauses
+        if (null pattern)
+          do (return
+               (if (> (length then) 1)
+                   `(progn ,@then)
+                   (car then)))
+        finally (return else)))
+
+(defun compile-match-group (vars group else)
+  (if vars
+      (ecase (car group)
+        (:var (compile-match-variable vars (cdr group) else))
+        (:const (compile-match-constant vars (cdr group) else))
+        (:cons (compile-match-constructor vars (cdr group) else)))
+      (compile-match-empty (cdr group) else)))
+
+(defun compile-match-groups (vars groups else)
+  (reduce (lambda (group else)
+            (compile-match-group vars group else))
+          groups
+          :initial-value else
+          :from-end t))

src/condition.lisp

@@ -0,0 +1,9 @@
+(in-package :cl-pattern)
+
+(annot:enable-annot-syntax)
+
+@export
+(define-condition match-error (error) ())
+
+(defun %match-error ()
+  (error (make-condition 'match-error)))

src/match.lisp

@@ -1,24 +1,29 @@
 (in-package :cl-pattern)
 
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (defun compile-match-clauses (value clauses)
-    (declare (type symbol value))
-    (if clauses
-        (let+ ((((pattern . body) . rest) clauses)
-               (body `(lambda () ,@body)))
-          (cond
-            ((otherwise-variable-p pattern) body)
-            ((variable-p pattern)
-             `(let+ ((,pattern ,value)) ,body))
-            ((consp pattern)
-             `(handler-case
-                  (let+ ((,pattern ,value)) ,body)
-                (error () ,(compile-match-clauses value rest))))
-            (t `(if (%equal ,value ,pattern)
-                    ,body
-                    ,(compile-match-clauses value rest)))))
-        '(error "match error"))))
+(annot:enable-annot-syntax)
 
-(defmacro match (value &body clauses)
-  (once-only (value)
-    `(funcall ,(compile-match-clauses value clauses))))
+(defmacro %match (vars clauses else)
+  (let ((groups (partition-match-clauses clauses)))
+    (compile-match-groups vars groups else)))
+
+@export
+(defmacro match* (args &body clauses)
+  (loop for arg in args
+        for var = (gensym "VAR")
+        if (atom arg)
+          collect arg into vars
+        else
+          collect var into vars
+          and collect `(,var ,arg) into bindings
+        finally
+     (return
+       (let ((body `(%match ,vars ,clauses (%match-error))))
+         (if bindings
+             `(let ,bindings ,body)
+             body)))))
+
+@export
+(defmacro match (arg &body clauses)
+  `(match* (,arg)
+     ,@(loop for (pattern . then) in clauses
+             collect `((,pattern) ,@then))))