source: branches/portable/test.lisp@ 31

Last change on this file since 31 was 30, checked in by wws, 10 years ago

Persistent CLOS instances work.
File size: 12.5 KB
Line 
1(in-package :wood-test)
2
3(defun reload ()
4 (funcall (find-symbol "QUICKLOAD" :ql) :wood-test :verbose t))
5
6(fiveam:def-suite wood-test-suite
7 :description "Test suite for WOOD.")
8
9(defvar *pheap* nil)
10(defvar *root-btree* nil)
11(defparameter *pheap-filename* "test.pheap")
12
13(defun run-all-tests (&optional recreate)
14 (when recreate
15 (let ((pheap *pheap*))
16 (when pheap
17 (setf *pheap* nil
18 *root-btree* nil)
19 (close-pheap pheap))))
20 (fiveam:run! 'wood-test-suite))
21
22(defun open-test-pheap (&key (if-exists :supersede))
23 (or *pheap*
24 (let* ((pheap (open-pheap *pheap-filename*
25 :if-exists if-exists
26 :if-does-not-exist :create))
27 (btree (or (root-object pheap)
28 (setf (root-object pheap)
29 (p-make-btree pheap)))))
30 (setf *pheap* pheap
31 *root-btree* btree))))
32
33(defun reopen-test-pheap ()
34 (let ((pheap *pheap*)
35 (if-exists :supersede))
36 (when pheap
37 (setf *pheap* nil
38 *root-btree* nil
39 if-exists :overwrite)
40 (close-pheap pheap))
41 (open-test-pheap :if-exists if-exists)))
42
43(defmacro with-wood-test-env ((root-btree) &body body)
44 (let ((thunk (gensym "THUNK")))
45 `(flet ((,thunk (,root-btree)
46 (declare (ignorable ,root-btree))
47 ,@body))
48 (call-with-wood-test-env #',thunk))))
49
50(defun call-with-wood-test-env (thunk)
51 (unwind-protect
52 (funcall thunk (reopen-test-pheap))
53 (close-pheap *pheap*)))
54
55(defmacro def-wood-test (name (root-btree) &body body)
56 (let ((test-name (intern (format nil "TEST-~a" name) :wood-test)))
57 `(progn
58 #+ccl
59 (ccl:record-source-file ',name 'def-wood-test)
60 (defun ,test-name ()
61 (with-wood-test-env (,root-btree)
62 ,@body))
63 (fiveam:def-test ,name (:suite wood-test-suite)
64 (,test-name)))))
65
66(def-wood-test check-btree (root)
67 (fiveam:is (floatp (wood::check-btree root))))
68
69(def-wood-test symbols (root)
70 (setf (p-btree-lookup root "symbols") 'symbols
71 (p-btree-lookup root "pheap") 'wood:pheap)
72 (setf root (reopen-test-pheap))
73 (fiveam:is (eq (p-load (p-btree-lookup root "symbols")) 'symbols))
74 (fiveam:is (eq (p-load (p-btree-lookup root "pheap")) 'wood:pheap)))
75
76(def-wood-test numbers (root)
77 (let ((integers '(123 -456 #.most-positive-fixnum #.most-negative-fixnum
78 #.(expt 3 100) #.(- (expt 7 60))))
79 (floats '(1.123 -4.567 0.0
80 #.most-positive-short-float #.most-negative-short-float
81 1.2345678d0 -9.01234567d0
82 #.most-positive-double-float #.most-negative-double-float))
83 (complexes '(#c(1 2) #c(-3 -4)
84 #c(1.2 3.4) #c(-5.6 -7.8)
85 #c(1.234d0 5.6789d0) #c(-2.34567d0 -8.9012345d0)))
86 (ratios '(1/2 -2/3 #.(/ (expt 3 100) 7) #.(/ -3 (expt 7 60)))))
87 (setf (p-btree-lookup root "integers") integers
88 (p-btree-lookup root "floats") floats
89 (p-btree-lookup root "complexes") complexes
90 (p-btree-lookup root "ratios") ratios)
91 (setf root (reopen-test-pheap))
92 (fiveam:is (equal integers (p-load (p-btree-lookup root "integers"))))
93 (fiveam:is (equal floats (p-load (p-btree-lookup root "floats"))))
94 (fiveam:is (equal complexes (p-load (p-btree-lookup root "complexes"))))
95 (fiveam:is (equal ratios (p-load (p-btree-lookup root "ratios"))))
96 ))
97
98(def-wood-test simple-vectors (root)
99 (let ((vecs '("The quick brown fox jumped over the lazy dog."
100 #(1 2 ("foo" "bar") #(a b)))))
101 (setf (p-btree-lookup root "simple-vectors") vecs)
102 (setf root (reopen-test-pheap))
103 (fiveam:is (equalp vecs (p-load (p-btree-lookup root "simple-vectors"))))))
104
105(def-wood-test typed-vectors (root)
106 (let ((vecs '(vector
107 (make-array 2
108 :element-type '(unsigned-byte 8)
109 :initial-contents '(1 2))
110 (make-array 3
111 :element-type '(unsigned-byte 16)
112 :initial-contents '(256 257 65535))
113 (make-array 4
114 :element-type 'double-float
115 :initial-contents '(0.0d0
116 1.0d0
117 #.most-positive-double-float
118 #.most-negative-double-float))
119 (make-array 5
120 :element-type '(signed-byte 32)
121 :initial-contents '(#x-80000000 #x-10001 0 #x1ffff #x7fffffff))
122 (make-array 4
123 :element-type '(unsigned-byte 32)
124 :initial-contents '(0 #x1ff #x1ffff #xffffffff))
125 (make-array 3
126 :element-type 'bit
127 :initial-contents '(1 1 0))
128 (make-array 4
129 :element-type '(signed-byte 8)
130 :initial-contents '(#x-80 #x-4f #xf0 #x7f))
131 (make-array 5
132 :element-type '(signed-byte 16)
133 :initial-contents '(#x-8000 #x-1ff 0 #x1ff #x7fff)))))
134 (setf (p-btree-lookup root "typed-vectors") vecs)
135 (setf root (reopen-test-pheap))
136 (let ((vs (p-load (p-btree-lookup root "typed-vectors"))))
137 (fiveam:is (equalp vecs vs))
138 (dotimes (i (length vecs))
139 (fiveam:is (typep (elt vs i) (type-of (elt vecs i))))))))
140
141#+(and ccl 64-bit-target)
142(def-wood-test generalized-typed-vectors (root)
143 (let ((vecs (vector
144 (make-array 3
145 :element-type '(complex double-float)
146 :initial-contents '(#c(#.most-positive-double-float
147 #.most-negative-double-float)
148 #c(1.234d0 5.6789d0)
149 #c(-2.34567d0 -8.9012345d0)))
150 (make-array 3
151 :element-type '(complex single-float)
152 :initial-contents '(#c(#.most-positive-single-float
153 #.most-negative-single-float)
154 #c(1.234 5.6789)
155 #c(-2.34567 -8.9012345)))
156 (make-array 5
157 :element-type 'fixnum
158 :initial-contents '(#.most-negative-fixnum
159 #.(1- (ash 1 28))
160 0
161 #.(- (ash 1 28))
162 #.most-positive-fixnum))
163 (make-array 5
164 :element-type '(signed-byte 64)
165 :initial-contents '(#.(- (ash 1 63))
166 #.(- (ash 1 28))
167 0
168 #.(1- (ash 1 28))
169 #.(1- (ash 1 63))))
170 (make-array 3
171 :element-type '(unsigned-byte 64)
172 :initial-contents '(0
173 #.(1- (ash 1 28))
174 #.(1- (ash 1 64))))
175 (make-array 4
176 :element-type 'single-float
177 :initial-contents '(0.0
178 1.0
179 #.most-positive-single-float
180 #.most-negative-single-float))
181 )))
182 (setf (p-btree-lookup root "generalized-typed-vectors") vecs)
183 (setf root (reopen-test-pheap))
184 (let ((vs (p-load (p-btree-lookup root "generalized-typed-vectors"))))
185 (fiveam:is (equalp vecs vs))
186 (dotimes (i (length vecs))
187 (fiveam:is (typep (elt vs i) 'simple-vector))))))
188
189(def-wood-test displaced-arrays (root)
190 (let* ((float-vec (make-array 8
191 :element-type 'double-float
192 :initial-contents
193 '(0.0d0 1.0d0 2.0d0 3.0d0 4.0d0 5.0d0 6.0d0 7.0d0)))
194 (vecs (vector
195 (make-array 6
196 :fill-pointer 1 :adjustable t
197 :element-type 'character
198 :initial-contents "foobar")
199 (make-array '(2 3)
200 :initial-contents
201 '((0.0d0 1.0d0 2.0d0) (3.0d0 4.0d0 5.0d0)))
202 (make-array '(2 3)
203 :displaced-to float-vec
204 :displaced-index-offset 1
205 :adjustable t)
206 (make-array '(3 2)
207 :displaced-to float-vec
208 :displaced-index-offset 2))))
209 (setf (p-btree-lookup root "displaced-arrays") vecs)
210 (setf root (reopen-test-pheap))
211 (let ((vs (p-load (p-btree-lookup root "displaced-arrays") )))
212 (fiveam:is (equalp vecs vs))
213 (loop :for vec :across vecs
214 :for v :across vs :do
215 (fiveam:is (eq (array-has-fill-pointer-p vec)
216 (array-has-fill-pointer-p v)))
217 (fiveam:is (eq (adjustable-array-p vec)
218 (adjustable-array-p v)))
219 (multiple-value-bind (vec-displaced-to vec-offset)
220 (array-displacement vec)
221 (multiple-value-bind (v-displaced-to v-offset)
222 (array-displacement v)
223 (fiveam:is (equalp vec-displaced-to v-displaced-to))
224 (if vec-displaced-to
225 (fiveam:is (and v-displaced-to
226 (equal (array-element-type vec-displaced-to)
227 (array-element-type v-displaced-to))))
228 (fiveam:is (null v-displaced-to)))
229 (fiveam:is (eql vec-offset v-offset))))))))
230
231(defstruct foo
232 x y z)
233
234(def-wood-test structs (root)
235 (let* ((foo-1 (make-foo :x 1 :y 2 :z 3))
236 (foo-2 (make-foo :x '(1 2 3)
237 :y #(1 2 3)
238 :z (make-array '(2 3)
239 :element-type 'double-float
240 :initial-contents
241 '((0.0d0 1.0d0 2.0d0) (3.0d0 4.0d0 5.0d0)))))
242 (foo-3 (make-foo :x foo-1 :y foo-2)))
243 (setf (foo-z foo-3) foo-3)
244 (setf (p-btree-lookup root "structs") (list foo-1 foo-2 foo-3))
245 (setf root (reopen-test-pheap))
246 (let ((structs (p-load (p-btree-lookup root "structs"))))
247 (fiveam:is (equalp foo-1 (elt structs 0)))
248 (fiveam:is (equalp foo-2 (elt structs 1)))
249 (let ((s3 (elt structs 2)))
250 (fiveam:is (and (equalp foo-1 (foo-x s3))
251 (equalp foo-2 (foo-y s3))
252 (eq s3 (foo-z s3))))))))
253
254(defclass bar ()
255 ((x :initarg :x :accessor bar-x)
256 (y :initarg :y :accessor bar-y)
257 (z :initarg :z :accessor bar-z)))
258
259(defun make-bar (&rest initargs)
260 (apply #'make-instance 'bar initargs))
261
262(defun bar-equalp (x y)
263 (cond ((typep x 'bar)
264 (and (typep y 'bar)
265 (bar-equalp (bar-x x) (bar-x y))
266 (bar-equalp (bar-y x) (bar-y y))
267 (bar-equalp (bar-z x) (bar-z y))))
268 (t (equalp x y))))
269
270(def-wood-test instances (root)
271 (let* ((bar-1 (make-bar :x 1 :y 2 :z 3))
272 (bar-2 (make-bar :x '(1 2 3)
273 :y #(1 2 3)
274 :z (make-array '(2 3)
275 :element-type 'double-float
276 :initial-contents
277 '((0.0d0 1.0d0 2.0d0) (3.0d0 4.0d0 5.0d0)))))
278 (bar-3 (make-bar :x bar-1 :y bar-2)))
279 (setf (bar-z bar-3) bar-3)
280 (setf (p-btree-lookup root "instances") (list bar-1 bar-2 bar-3))
281 (setf root (reopen-test-pheap))
282 (let* ((p (p-btree-lookup root "instances"))
283 (p0 (p-car p))
284 (p1 (p-cadr p))
285 (p2 (p-caddr p))
286 (instances (p-load p)))
287 (fiveam:is (bar-equalp bar-1 (elt instances 0)))
288 (fiveam:is (bar-equalp bar-2 (elt instances 1)))
289 (let ((s3 (elt instances 2)))
290 (fiveam:is (bar-equalp bar-1 (bar-x s3)))
291 (fiveam:is (bar-equalp bar-2 (bar-y s3)))
292 (fiveam:is (eq s3 (bar-z s3))))
293 (fiveam:is (eql 1 (p-slot-value p0 'x)))
294 (fiveam:is (eql 2 (p-slot-value p0 'y)))
295 (fiveam:is (eql 3 (p-slot-value p0 'z)))
296 (fiveam:is (pptr-equal p0 (p-slot-value p2 'x)))
297 (fiveam:is (pptr-equal p1 (p-slot-value p2 'y)))
298 (fiveam:is (pptr-equal p2 (p-slot-value p2 'z))))))
Note: See TracBrowser for help on using the repository browser.