Initial commit

fivepm.asd

@@ -0,0 +1,16 @@
+(asdf:defsystem :fivepm
+  :description "Very Fast Pattern Matching Library"
+  :version "0.1"
+  :author "Tomohiro Matsuyama"
+  :license "LLGPL"
+  :depends-on (:alexandria
+               :anaphora
+               :closer-mop)
+  :components ((:module "src"
+                :serial t
+                :components ((:file "package")
+                             (:file "util")
+                             (:file "equal")
+                             (:file "pattern")
+                             (:file "compiler")
+                             (:file "match")))))

src/compiler.lisp

@@ -0,0 +1,164 @@
+(in-package :fivepm)
+
+(defmacro with-match-fail (form else)
+  (flet ((literalp (value)
+           (typep value '(or symbol number character string))))
+    (cond
+      ((literalp else)
+       `(macrolet ((match-fail () ',else))
+          ,form))
+      ((equal else '(match-fail))
+       form)
+      (t
+       (let ((block (gensym "MATCH"))
+             (tag (gensym "MATCH-FAIL")))
+         `(block ,block
+            (tagbody
+               (return-from ,block
+                 (macrolet ((match-fail () '(go ,tag)))
+                   ,form))
+               ,tag
+               (return-from ,block ,else))))))))
+
+(defun compile-clause-body (body)
+  (cond ((null body)
+         nil)
+        ((and (consp (first body))
+              (eq (car (first body)) 'declare))
+         `(locally . ,body))
+        ((= (length body) 1)
+         (first body))
+        (t
+         `(progn . ,body))))
+
+(defun compile-match-variable-group (vars clauses else)
+  `(%match ,(cdr vars)
+           ,(loop for ((pattern . rest) . then) in clauses
+                  for name = (variable-pattern-name pattern)
+                  collect
+                  (if name
+                      `(,rest (let ((,name ,(car vars))) . ,then))
+                      `(,rest . ,then)))
+           ,else))
+
+(defun compile-match-constant-group (vars clauses else)
+  `(with-match-fail
+       (if ,(with-slots (value) (caaar clauses)
+              `(equals ,(car vars) ,value))
+           (%match ,(cdr vars)
+                   ,(loop for ((nil . rest) . then) in clauses
+                          collect `(,rest . ,then))
+                   (match-fail))
+           (match-fail))
+     ,else))
+
+(defun compile-match-constructor-group (vars clauses else)
+  (with-slots (arity arguments predicate accessor) (caaar clauses)
+    (let* ((var (car vars))
+           (test-form (funcall predicate var))
+           (new-vars (make-gensym-list arity)))
+      `(with-match-fail
+           (if ,test-form
+               (let ,(loop for i from 0
+                           for new-var in new-vars
+                           for access = (funcall accessor var i)
+                           collect `(,new-var ,access))
+                 (declare (ignorable ,@new-vars))
+                 (%match (,@new-vars . ,(cdr vars))
+                         ,(loop for ((pattern . rest) . then) in clauses
+                                for args = (constructor-pattern-arguments pattern)
+                                collect `((,@args . ,rest) . ,then))
+                         (match-fail)))
+               (match-fail))
+         ,else))))
+
+(defun compile-match-guard (vars clause else)
+  (destructuring-bind ((pattern . rest) . then) clause
+    (with-slots (pattern test-form) pattern
+      `(with-match-fail
+           (%match (,(car vars))
+                   (((,pattern)
+                     (if ,test-form
+                         (%match ,(cdr vars)
+                                 ((,rest . ,then))
+                                 (match-fail))
+                         (match-fail))))
+                   (match-fail))
+         ,else))))
+
+(defun compile-match-guard-group (vars clauses else)
+  (reduce (lambda (clause else) (compile-match-guard vars clause else))
+          clauses
+          :initial-value else
+          :from-end t))
+
+(defun compile-match-empty-group (clauses else)
+  (loop for (pattern . then) in clauses
+        if (null pattern)
+          do (return (compile-clause-body then))
+        finally (return else)))
+
+(defun compile-match-group (vars group else)
+  (if vars
+      (etypecase (caaar group)
+        (variable-pattern
+         (compile-match-variable-group vars group else))
+        (constant-pattern
+         (compile-match-constant-group vars group else))
+        (constructor-pattern
+         (compile-match-constructor-group vars group else))
+        (guard-pattern
+         (compile-match-guard-group vars group else)))
+      (compile-match-empty-group 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))
+
+(defgeneric same-group-p (pattern1 pattern2)
+  (:method (pattern1 pattern2) t))
+
+(defmethod same-group-p ((pattern1 constant-pattern) (pattern2 constant-pattern))
+  (%equal (constant-pattern-value pattern1)
+          (constant-pattern-value pattern2)))
+
+(defmethod same-group-p ((pattern1 constructor-pattern) (pattern2 constructor-pattern))
+  (and (eq (constructor-pattern-name pattern1)
+           (constructor-pattern-name pattern2))
+       (= (constructor-pattern-arity pattern1)
+          (constructor-pattern-arity pattern2))))
+
+(defun group-match-clauses (clauses)
+  (group clauses :test #'same-group-p :key #'caar))
+
+(defun desugar-match-clause (clause)
+  (if (car clause)
+      (destructuring-bind ((pattern . rest) . then) clause
+        (if (and (>= (length then) 2)
+                 (eq (first then) 'when))
+            (let* ((test (second then))
+                   (then (cddr then)))
+              `(((guard ,pattern ,test) . ,rest) . ,then))
+            `((,pattern . ,rest) . ,then)))
+      clause))
+
+(defun parse-match-clause (clause)
+  (if (car clause)
+      (destructuring-bind ((pattern . rest) . then)
+          (desugar-match-clause clause)
+        (let ((pattern (parse-pattern pattern)))
+          `((,pattern . ,rest) . ,then)))
+      clause))
+
+(defmacro %match (vars clauses else)
+  (let* ((clauses (mapcar #'parse-match-clause clauses))
+         (groups (group-match-clauses clauses)))
+    (compile-match-groups vars groups else)))
+
+(defmacro %match-1 (var clauses else)
+  `(%match (,var)
+           ,(loop for (pattern . then) in clauses
+                  collect `((,pattern) . ,then))
+           ,else))

src/equal.lisp

@@ -0,0 +1,20 @@
+(in-package :fivepm)
+
+(defun %equal (a b)
+  (declare (optimize (speed 3) (safety 0) (space 0)))
+  (or (equal a b)
+      (cond ((and (numberp a) (numberp b))
+             (= a b))
+            ((and (characterp a) (characterp b))
+             (char= a b))
+            ((and (stringp a) (stringp b))
+             (string= a b))
+            ((and (consp a) (consp b))
+             (and (%equal (car a) (car b))
+                  (%equal (cdr a) (cdr b)))))))
+
+(defmacro equals (var value)
+  (cond ((null value) `(null ,var))
+        ((symbolp value) `(eq ,var ',value))
+        ((consp value) `(%equal ,var ',value))
+        (t `(%equal ,var ,value))))

src/match.lisp

@@ -0,0 +1,38 @@
+(in-package :fivepm)
+
+(define-condition match-error (error)
+  ((argument :initarg :argument
+             :initform nil
+             :reader match-argument)
+   (patterns :initarg :patterns
+             :initform nil
+             :reader match-patterns))
+  (:report (lambda (condition stream)
+             (format stream "Can't match ~A with ~{~S~^ or ~}."
+                     (match-argument condition)
+                     (match-patterns condition)))))
+
+(defmacro match (arg &body clauses)
+  (once-only (arg)
+    `(%match-1 ,arg ,clauses nil)))
+
+(defun %ematch-else (&optional arg patterns)
+  (error 'match-error
+         :argument arg
+         :patterns patterns))
+
+(defmacro ematch (arg &body clauses)
+  (once-only (arg)
+    (let ((else `(%ematch-else ,arg ',(mapcar #'car clauses))))
+      `(%match-1 ,arg ,clauses ,else))))
+
+(defun %cmatch-else (&optional arg patterns)
+  (cerror "Continue."
+         'match-error
+         :argument arg
+         :patterns patterns))
+
+(defmacro cmatch (arg &body clauses)
+  (once-only (arg)
+    (let ((else `(%cmatch-else ,arg ',(mapcar #'car clauses))))
+      `(%match-1 ,arg ,clauses ,else))))

src/package.lisp

@@ -0,0 +1,25 @@
+(defpackage :fivepm
+  (:use :cl)
+  (:nicknames :5pm)
+  (:import-from :alexandria
+                #:ensure-car
+                #:ensure-list
+                #:mappend
+                #:symbolicate
+                #:make-keyword
+                #:make-gensym-list
+                #:required-argument
+                #:with-gensyms
+                #:once-only
+                #:when-let)
+  (:import-from :anaphora
+                #:aif
+                #:awhen
+                #:it)
+  (:import-from :closer-mop
+                #:slot-definition-name
+                #:class-slots)
+  (:export #:defpattern
+           #:match
+           #:ematch
+           #:cmatch))