Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 160 lines (147 sloc) 5.984 kb
1cba8fd @tonyg cl-match_0.1.8.tgz
tonyg authored
1 ;;; cl-match: extended--ML-style pattern matching
2 ;;; unit tests using pcl-test
3 ;;-------------------------------------------------------------------------
4 ;; This software is Copyright (c) 2008 Daniel S. Bensen.
5 ;; You are hereby granted permission to distribute and use this software
6 ;; as governed by the terms of the Lisp Lesser GNU Public License
7 ;; (http://opensource.franz.com/preamble.html),
8 ;; known as the LLGPL.
9 ;; This software is provided "as is" with no express or implied warranty.
10 ;;-------------------------------------------------------------------------
11
12 ;;(declaim (optimize (debug 3)))
13
14 (cl:defpackage :cl-match-test (:use :cl :pcl-unit-test :cl-match))
15 (cl:in-package :cl-match-test)
16
17 (defmacro patrn-errs (patrn)
18 `(let ((val (gensym "VAL"))) (errs (cl-match::patrn-vgt val ',patrn))))
19
20 (defmacro matches (patrn expr) `(ifmatch ,patrn ,expr t nil))
21 (defmacro not-matches (patrn expr) `(not (matches ,patrn ,expr)))
22
23 (defmacro pairs-match (pairs)
24 `(progn ,@(loop for pair in pairs
25 collect (cons 'matches pair))))
26
27 (defstruct foo bar gak)
28
29 (defpattern foo (&rest fields) `(struct foo- ,@fields))
30
31 (defclass urp () ((wuf :initarg :wuf :accessor wuf)
32 (eek :initarg :eek :accessor eek)))
33
34 (eval-when (:compile-toplevel :load-toplevel :execute)
35 (defun test-patrn (form)
36 (if (eq (car form) :quote)
37 (cadr form)
38 (let ((patrn (car form))
39 (expr (cadr form))
40 (matching (not (cddr form))))
41 (if (eq expr :errs)
42 `(patrn-errs ,patrn)
43 (if matching
44 `(matches ,patrn ,expr)
45 `(not-matches ,patrn ,expr)))))))
46
47 (defmacro def-test-match (&body tests)
48 `(deftest test-match ()
49 (test-forms
50 ,@(loop for test in tests collect (test-patrn test)))))
51
52 (def-test-match
53 (x 1)
54 (_ nil)
55 ;;list, list*, cons
56 ((list*) :errs)
57 ((cons) :errs)
58 ((cons x) :errs)
59 ((cons x y z) :errs)
60 ((list) nil)
61 ((list x) '(nil)) ;setf vs. setft
62 ((list* x _) '(nil))
63 ((list* x _) (list* nil 1))
64 ((list x y) '(a b))
65 ((:list x y) '(a b)) ;keyword default
66 (("LIST" x y) '(a b)) ;string default
67 ((list x y) (cons 1 2) :not)
68 ((list x) 1 :not) ;wrong type
69 ((list x y x) '(a b) :not) ; too short
70 ((list x y) '(a b c) :not) ; too long
71 ((list* car cdr) '(a b c))
72 ((cons car cdr) '(a b c))
73 ((list x (when x x)) :errs)
74 ;;as
75 ((as x) nil)
76 ((as _) nil)
77 ((as x _) nil)
78 ( (as) :errs)
79 ( (as x a b) :errs)
80 ((as lx2 (list x x)) '(1 1))
81 ((list x (as x _)) '(a a))
82 ((list (as x _) x) '(a a))
83 ((list x (list y z)) '(a (b c)))
84 ((:list x (list y z) x) '(a (b c) a))
85 ((:list x (list y z) x) '(a (b c) d) :not)
86 ((when (< x y) (:list x y)) '(1 2))
87 ((when (> x y) (:list x y)) '(1 2) :not)
88 ;; ((list* x y) '(a b c d))
89 ((list* x (list y z w)) '(a b c d))
90 ( (cons x y) '(a))
91 ( (cons x) :errs)
92 ((list x (as x _)) '(1 1))
93 ((list x (as x 1)) '(1 1))
94 ((list x (as x 2)) '(1 1) :not)
95 ;;array
96 ((array 1 ((x y) (z w))) :errs) ;ranks differ
97 ((array 2 ((x y) (z))) :errs) ;dims differ
b0b9601 @tonyg Speculative test-case-update to catch bug from previous commit
tonyg authored
98 ((array 1 (x)) (make-array '(1) :initial-contents '(1)))
1cba8fd @tonyg cl-match_0.1.8.tgz
tonyg authored
99 ((array 2 ((x y) (z w))) (make-array '(2 2) :initial-contents '((1 2) (3 4))))
100 ((array (2 string) ((x y) (z w))) (make-array '(2 2) :element-type 'integer
101 :initial-contents '((1 2) (3 4))) :not)
102 ((array (2 integer) ((x y) (z w))) (make-array '(2 2) :element-type 'integer
103 :initial-contents '((1 2) (3 4))))
104 ((array 2 ((x y) (y z))) (make-array '(2 2) :initial-contents '((1 2) (2 1))))
105 ((array 2 ((x y) (y z))) (make-array '(2 2) :initial-contents '((1 2) (3 4))) :not)
106 ;;vector
107 ((vec (x y z)) (make-array '(3) :initial-contents '(1 2 3)))
108 ((vec (x y)) (make-array '(3) :initial-contents '(1 2 3)) :not)
109 ((vec (x y) string) (make-array '(2) :element-type 'integer :initial-contents '(1 2)) :not)
110 ((vec (x y) integer) (make-array '(2) :element-type 'integer :initial-contents '(1 2)))
111 ;;or
112 ((or 2 3) 1 :not)
113 ((list x y (or x y)) '(a b a))
114 ((list x (or (when (< x 1) x) (when (> x 1) y)) y) '(0 0 2))
115 ((list x (or (when (< x 1) x) (when (> x 1) y)) y) '(2 1 1))
116 ((list x (or (when (< x 1) x) (when (> x 1) y))) :errs)
117 ;;when
118 ((list x (when (> x 0) x)) :errs) ;not top level
119 ( (when t) nil)
120 (:quote (let ((val 1)) (matches val (when (= val 1)))))
121 ((when (= x 1) x) 1)
122 ;;vals
123 ((list (vals x y)) :errs)
124 ( (vals x x) (values 1 1))
125 ((or (vals x 1) (vals 1 x)) (values 1 1))
126 ((or (vals x 2) (vals 2 x)) (values 1 1) :not)
127 ((or (vals 2 x) (when (> x 1) (vals 1 x))) (values 1 2))
128 ;;[(values 1 '(2 3)) (patrn-vgt '(or (vals x (list y z)) (vals (list x y) z)))]
129 ;;struct
130 ((struct) :errs)
131 ( (struct foo- (bar 1) (gak 2)) (make-foo :bar 1 :gak 2))
132 ((when (= x gak) (struct foo- (bar (list x y)) gak)) (make-foo :bar (list 1 2) :gak 1))
133 ((struct foo- (a b c)) :errs)
134 ((foo (bar 1) (gak 2)) (make-foo :bar 1 :gak 2))
135 ;;slots, accsrs
136 ((slots (a b c)) :errs)
137 ((slots (wuf) (eek)) (make-instance 'urp)) ;default patrn is _
138 ((slots wuf eek ) (make-instance 'urp) :not) ;slot-boundp prevents error
139 ((slots wuf eek) (make-instance 'urp :wuf 1 :eek 2))
140 ((acsrs (wuf) (eek)) (make-instance 'urp))
141 ;;type
142 ((type) :errs)
143 ((type string) "FOO")
144 ((type symbol) "FOO" :not)
145 ;;quote
146 ('a 'a)
147 ('b 'a :not)
148 ;; match
149 (:quote (match '(a b) ((list x x) nil) ((list x y z) nil) ((list x y) t) (_ nil)))
150 (:quote (match (values 1 2)
151 ((or (when (> x 1) (vals x 1)) (vals x x)) nil)
152 ((or (when (> x 1) (vals 1 x)) (vals 2 x)) t)
153 (_ nil)))
154 (:quote (not (match '(a b) ((list x x) t) ((list x y z) t))))
155 ;;not-or
156 ;;[1 (not [2 or 3])]
157 )
158
159 ;;(def tm () (test-match))
Something went wrong with that request. Please try again.