Permalink
Browse files

Added support for optional pattern.

  • Loading branch information...
1 parent 480c666 commit 3331d9b18916d0bd8e6be54f9a6a1d7485c7883c Tomohiro Matsuyama committed Apr 8, 2011
Showing with 177 additions and 69 deletions.
  1. +5 −0 .gitignore
  2. +21 −7 README.markdown
  3. +3 −7 cl-pattern-test.asd
  4. +4 −3 cl-pattern.asd
  5. +1 −2 src/case.lisp
  6. +61 −18 src/compile.lisp
  7. +1 −2 src/condition.lisp
  8. +4 −5 src/match.lisp
  9. +10 −6 src/package.lisp
  10. +26 −17 src/pattern.lisp
  11. +41 −2 t/match.lisp
View
@@ -0,0 +1,5 @@
+*.fasl
+*.dx64fsl
+*.dx32fsl
+*.lx64fsl
+*.x86f
View
@@ -1,16 +1,24 @@
-cl-pattern
+CL-PATTERN
==========
-cl-pattern is a very fast ML-like pattern-matching library for Common Lisp.
+CL-PATTERN is a very fast ML-like pattern-matching library for Common
+Lisp.
Usage
-----
-### match
+### Macro: `match`
(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` 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.
+`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. `pattern` can have `&optional` patterns, which will be
+`nil` if patterns are not matched.
#### Examples
@@ -46,15 +54,21 @@ Usage
(t 'otherwise))
; => OTHERWISE
+ (match '(1)
+ ((1 &optional a) a))
+ ; => NIL
+
+ (match '(1 2)
+ ((1 &optional a) a))
+ ; => 2
+
(defun sum (lst)
(match lst
(() 0)
((x . xs) (+ x (sum xs)))))
(sum '(1 2 3))
; => 6
-License
--------
+----
Copyright (C) 2011 Tomohiro Matsuyama <<tomo@cx4a.org>>.
-Licensed under the LLGPL License.
View
@@ -1,14 +1,10 @@
(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")))))
+ :components ((:module "t"
+ :serial t
+ :components ((:file "match")))))
View
@@ -1,15 +1,16 @@
(in-package :cl-user)
-
(defpackage cl-pattern-asd
(:use :cl :asdf))
-
(in-package :cl-pattern-asd)
(defsystem cl-pattern
:version "0.1"
:author "Tomohiro Matsuyama"
:license "LLGPL"
- :depends-on (:cl-annot :alexandria)
+ :depends-on (:alexandria
+ :cl-annot
+ :cl-syntax
+ :cl-syntax-annot)
:components
((:module "src"
:serial t
View
@@ -1,6 +1,5 @@
(in-package :cl-pattern)
-
-(annot:enable-annot-syntax)
+(use-syntax annot-syntax)
@eval-always
(defun compile-case-clause (var clause else)
View
@@ -1,6 +1,5 @@
(in-package :cl-pattern)
-
-(annot:enable-annot-syntax)
+(use-syntax annot-syntax)
(defun partition-match-clauses (clauses)
(loop with groups
@@ -12,7 +11,8 @@
do
(or group-type (setf group-type head-pattern-type))
(if (eq head-pattern-type group-type)
- (push clause group-clauses)
+ (push clause
+ group-clauses)
(progn
(push (cons group-type (nreverse group-clauses)) groups)
(setf group-type head-pattern-type
@@ -23,15 +23,15 @@
(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))
+ `(%match
+ ,(cdr vars)
+ ,(loop for ((var . rest) . then) in clauses
+ if (string-equal var "_")
+ collect `(,rest ,@then)
+ else
+ collect `(,rest (let ((,var ,(car vars)))
+ ,@then)))
+ ,else))
(defun compile-match-constant (vars clauses else)
(loop with alist
@@ -60,13 +60,55 @@
(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))
+ (%match
+ ,`(,car ,cdr ,@(cdr vars))
+ ,(loop for (((par . pdr) . rest) . then) in clauses
+ collect `(,`(,par ,pdr ,@rest) ,@then))
+ ,else))
,else))))
+(defun compile-match-optional-null (restvars clauses else)
+ `(%match
+ ,`(,@restvars)
+ ,(loop for ((pattern . rest) . then) in clauses
+ for fv = (cdr pattern)
+ collect
+ (cons `(,@rest)
+ (if fv
+ `((let ,fv (declare (ignorable ,@fv)) ,@then))
+ then)))
+ ,else))
+
+(defun compile-match-optional-constructor (var restvars clauses else)
+ (with-gensyms (car cdr)
+ `(let ((,car (car ,var))
+ (,cdr (cdr ,var)))
+ (declare (ignorable ,car ,cdr))
+ (%match
+ ,`(,car ,cdr ,@restvars)
+ ,(loop for ((pattern . rest) . then) in clauses
+ append
+ (loop with pfv = (free-variables (cdr pattern))
+ for sub-pattern in (optional-patterns (cdr pattern))
+ for (par . pdr) = sub-pattern
+ for sfv = (free-variables sub-pattern)
+ for fv = (remove-if (lambda (v) (member v sfv)) pfv)
+ collect
+ (cons `(,par ,pdr ,@rest)
+ (if fv
+ `((let ,fv (declare (ignorable ,@fv)) ,@then))
+ then))))
+ ,else))))
+
+(defun compile-match-optional (vars clauses else)
+ (let ((var (car vars)))
+ `(cond
+ ((null ,var)
+ ,(compile-match-optional-null (cdr vars) clauses else))
+ ((consp ,var)
+ ,(compile-match-optional-constructor var (cdr vars) clauses else))
+ (t ,else))))
+
(defun compile-match-empty (clauses else)
(loop for (pattern . then) in clauses
if (null pattern)
@@ -81,7 +123,8 @@
(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)))
+ (:cons (compile-match-constructor vars (cdr group) else))
+ (:optional (compile-match-optional vars (cdr group) else)))
(compile-match-empty (cdr group) else)))
(defun compile-match-groups (vars groups else)
View
@@ -1,6 +1,5 @@
(in-package :cl-pattern)
-
-(annot:enable-annot-syntax)
+(use-syntax annot-syntax)
@export
(define-condition match-error (error) ())
View
@@ -1,6 +1,5 @@
(in-package :cl-pattern)
-
-(annot:enable-annot-syntax)
+(use-syntax annot-syntax)
(defmacro %match (vars clauses else)
(let ((groups (partition-match-clauses clauses)))
@@ -17,10 +16,10 @@
and collect `(,var ,arg) into bindings
finally
(return
- (let ((body `(%match ,vars ,clauses (%match-error))))
+ (let ((then `(%match ,vars ,clauses (%match-error))))
(if bindings
- `(let ,bindings ,body)
- body)))))
+ `(let ,bindings ,then)
+ then)))))
@export
(defmacro match (arg &body clauses)
View
@@ -1,7 +1,11 @@
-(in-package :cl-user)
-
(defpackage cl-pattern
- (:use :cl
- :alexandria
- :annot.eval-when)
- (:nicknames :pattern))
+ (:nicknames :pattern)
+ (:use :cl)
+ (:import-from :alexandria
+ :with-gensyms)
+ (:import-from :syntax
+ :use-syntax)
+ (:import-from :syntax-annot
+ :annot-syntax)
+ (:import-from :annot.eval-when
+ :eval-always))
View
@@ -1,27 +1,36 @@
(in-package :cl-pattern)
-
-(annot:enable-annot-syntax)
+(use-syntax annot-syntax)
(defmacro %equal (pattern value)
- (cond
- ((null pattern)
- `(null ,value))
- ((atom pattern)
- `(eq ,pattern ,value))
- ((consp pattern)
- ;; special case: quote form
- `(eq ',(cadr pattern) ,value))
- (t
- `(equal ,pattern ,value))))
+ (typecase pattern
+ (null `(null ,value))
+ (string `(equal ,pattern ,value))
+ (atom `(eq ,pattern ,value))
+ (cons `(eq ',(cadr pattern) ,value))
+ (t `(equal ,pattern ,value))))
(defun pattern-type (pattern)
(etypecase pattern
(null :const)
(keyword :const)
(symbol :var)
- (cons
- (if (eq (car pattern) 'quote)
- ;; special case: quote form
- :const
- :cons))
+ (cons (case (car pattern)
+ (quote :const)
+ (&optional :optional)
+ (t :cons)))
(atom :const)))
+
+(defun free-variables (pattern)
+ (case (pattern-type pattern)
+ (:var (list pattern))
+ (:cons (append (free-variables (car pattern))
+ (free-variables (cdr pattern))))))
+
+(defun optional-patterns (pattern)
+ (if (consp pattern)
+ (mapcar (lambda (sub-pattern)
+ (cons (car pattern)
+ sub-pattern))
+ (cons nil
+ (optional-patterns (cdr pattern))))
+ pattern))
View
@@ -1,10 +1,8 @@
(in-package :cl-user)
-
(defpackage cl-annot-test
(:use :cl
:cl-test-more
:cl-pattern))
-
(in-package :cl-annot-test)
(is (match 1
@@ -15,6 +13,10 @@
((x y) (+ x y)))
3
"match cons")
+(is (match '("a")
+ (("a") 1))
+ 1
+ "match string")
(is (match '(:bar 1)
((:foo _) "Foo!")
((:bar _) "Bar!"))
@@ -39,6 +41,43 @@
(_ 'otherwise))
'otherwise
"match otherwise")
+(is (match ()
+ ((&optional a) a))
+ nil
+ "match optional empty")
+(is (match '(1)
+ ((&optional a b) (list a b)))
+ '(1 nil)
+ "match optional lack")
+(is (match '(1 2)
+ ((&optional a b) (+ a b)))
+ 3
+ "match optional enough")
+(is (match '(1 2)
+ ((&optional a) a)
+ ((&optional a b) (+ a b)))
+ 3
+ "match optional multi")
+(is (match '(())
+ (((&optional a)) a))
+ nil
+ "match optional nest empty")
+(is (match '((1))
+ (((&optional a b)) (list a b)))
+ '(1 nil)
+ "match optional nest lack")
+(is (match '((1 2))
+ (((&optional a b)) (+ a b)))
+ 3
+ "match optional nest enough")
+(is (match '((()))
+ ((((&optional a))) a))
+ nil
+ "match optional nest 3")
+(is (match '((1) "a")
+ (((1 &optional a) "a" &optional b) (list a b)))
+ '(nil nil)
+ "match complex")
(defun sum (list)
(match list

0 comments on commit 3331d9b

Please sign in to comment.