/[cl-store]/cl-store/tests.lisp
ViewVC logotype

Contents of /cl-store/tests.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.33 - (show annotations)
Mon Sep 17 18:40:03 2007 UTC (6 years, 7 months ago) by sross
Branch: MAIN
CVS Tags: HEAD
Changes since 1.32: +8 -2 lines
faster (simple-array (unsigned-byte 8) (*)) storing. Thanks to Chris Dean
more lenient parsing of sbcl version. Thanks to Gustavo
1 ;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;; See the file LICENCE for licence information.
3 (defpackage :cl-store-tests
4 (:use :cl :regression-test :cl-store))
5
6 (in-package :cl-store-tests)
7
8 (rem-all-tests)
9 (defvar *test-file* "filetest.cls")
10
11 (defun restores (val)
12 (store val *test-file*)
13 (let ((restored (restore *test-file*)))
14 (or (and (numberp val) (= val restored))
15 (and (stringp val) (string= val restored))
16 (and (characterp val) (char= val restored))
17 (eql val restored)
18 (equal val restored)
19 (equalp val restored))))
20
21 (defmacro deftestit (name val)
22 `(deftest ,name (restores ,val) t))
23
24 ;; integers
25 (deftestit integer.1 1)
26 (deftestit integer.2 0)
27 (deftestit integer.3 23423333333333333333333333423102334)
28 (deftestit integer.4 -2322993)
29 (deftestit integer.5 most-positive-fixnum)
30 (deftestit integer.6 most-negative-fixnum)
31 (deftestit integer.7 #x100000000)
32
33 ;; ratios
34 (deftestit ratio.1 1/2)
35 (deftestit ratio.2 234232/23434)
36 (deftestit ratio.3 -12/2)
37 (deftestit ratio.4 -6/11)
38 (deftestit ratio.5 23222/13)
39
40 ;; complex numbers
41 (deftestit complex.1 #C(0 1))
42 (deftestit complex.2 #C(0.0 1.0))
43 (deftestit complex.3 #C(32 -23455))
44 (deftestit complex.4 #C(-222.32 2322.21))
45 (deftestit complex.5 #C(-111 -1123))
46 (deftestit complex.6 #C(-11.2 -34.5))
47
48
49 ;; short floats
50
51 ;; single-float
52 (deftestit single-float.1 3244.32)
53 (deftestit single-float.2 0.12)
54 (deftestit single-float.3 -233.001)
55 (deftestit single-float.4 most-positive-single-float)
56 (deftestit single-float.5 most-negative-single-float)
57
58 ;; double-float
59 (deftestit double-float.1 2343.3d0)
60 (deftestit double-float.2 -1211111.3343d0)
61 (deftestit double-float.3 99999999999123456789012345678222222222222290.0987654321d0)
62 (deftestit double-float.4 -99999999999123456789012345678222222222222290.0987654321d0)
63 (deftestit double-float.5 most-positive-double-float)
64 (deftestit double-float.6 most-negative-double-float)
65
66 ;; long floats
67
68 ;; infinite floats
69 #+(or sbcl cmu lispworks allegro)
70 (progn
71 #+sbcl (sb-int:set-floating-point-modes :traps nil)
72 #+cmu (ext:set-floating-point-modes :traps nil)
73 (deftestit infinite-float.1 (expt most-positive-single-float 3))
74 (deftestit infinite-float.2 (expt most-positive-double-float 3))
75 (deftestit infinite-float.3 (expt most-negative-single-float 3))
76 (deftestit infinite-float.4 (expt most-negative-double-float 3))
77 (deftestit infinite-float.5 (/ (expt most-positive-single-float 3)
78 (expt most-positive-single-float 3)))
79 (deftestit infinite-float.6 (/ (expt most-positive-double-float 3)
80 (expt most-positive-double-float 3))))
81
82
83 ;; characters
84 (deftestit char.1 #\Space)
85 (deftestit char.2 #\f )
86 (deftestit char.3 #\Rubout)
87 (deftestit char.4 (code-char 255))
88
89
90 ;; various strings
91 (deftestit string.1 "foobar")
92 (deftestit string.2 "how are you")
93 (deftestit string.3 "foo
94 bar")
95
96 (deftestit string.4
97 (make-array 10 :initial-element #\f :element-type 'character
98 :fill-pointer 3))
99
100 #+(or (and sbcl sb-unicode) lispworks clisp acl)
101 (progn
102 (deftestit unicode.1 (map #-lispworks 'string
103 #+lispworks 'lw:text-string
104 #'code-char (list #X20AC #X3BB)))
105 (deftestit unicode.2 (intern (map #-lispworks 'string
106 #+lispworks 'lw:text-string
107 #'code-char (list #X20AC #X3BB))
108 :cl-store-tests)))
109
110 ;; vectors
111 (deftestit vector.1 #(1 2 3 4))
112
113
114 (deftestit vector.2 (make-array 5 :element-type 'fixnum
115 :initial-contents (list 1 2 3 4 5)))
116
117 (deftestit vector.3
118 (make-array 5
119 :element-type 'fixnum
120 :fill-pointer 2
121 :initial-contents (list 1 2 3 4 5)))
122
123
124 (deftestit vector.4 #*101101101110)
125 (deftestit vector.5 #*)
126 (deftestit vector.6 #())
127
128
129 ;; (array octect (*))
130
131 (deftestit vector.octet.1 (make-array 10 :element-type '(unsigned-byte 8)))
132
133
134 ;; arrays
135 (deftestit array.1
136 (make-array '(2 2) :initial-contents '((1 2) (3 4))))
137
138 (deftestit array.2
139 (make-array '(2 2) :initial-contents '((1 1) (1 1))))
140
141 (deftestit array.3
142 (make-array '(2 2) :element-type '(mod 10) :initial-element 3))
143
144 (deftestit array.4
145 (make-array '(2 3 5)
146 :initial-contents
147 '(((1 2 #\f 5 12.0) (#\Space "fpp" 4 1 0) ('d "foo" #() 3 -1))
148 ((0 #\a #\b 4 #\q) (12.0d0 0 '(d) 4 1)
149 (#\Newline 1 7 #\4 #\0)))))
150
151 (deftestit array.5
152 (let* ((a1 (make-array 5))
153 (a2 (make-array 4 :displaced-to a1
154 :displaced-index-offset 1))
155 (a3 (make-array 2 :displaced-to a2
156 :displaced-index-offset 2)))
157 a3))
158
159
160
161
162 ;; symbols
163
164 (deftestit symbol.1 t)
165 (deftestit symbol.2 nil)
166 (deftestit symbol.3 :foo)
167 (deftestit symbol.4 'cl-store-tests::foo)
168 (deftestit symbol.5 'make-hash-table)
169 (deftestit symbol.6 '|foo bar|)
170 (deftestit symbol.7 'foo\ bar\ baz)
171
172 (deftest gensym.1 (progn
173 (store (gensym "Foobar") *test-file*)
174 (let ((new (restore *test-file*)))
175 (list (symbol-package new)
176 (mismatch "Foobar" (symbol-name new)))))
177 (nil 6))
178
179 ; This failed in cl-store < 0.5.5
180 (deftest gensym.2 (let ((x (gensym)))
181 (store (list x x) *test-file*)
182 (let ((new (restore *test-file*)))
183 (eql (car new) (cadr new))))
184 t)
185
186
187 ;; cons
188
189 (deftestit cons.1 '(1 2 3))
190 (deftestit cons.2 '((1 2 3)))
191 (deftestit cons.3 '(#\Space 1 1/2 1.3 #(1 2 3)))
192
193 (deftestit cons.4 '(1 . 2))
194 (deftestit cons.5 '(t . nil))
195 (deftestit cons.6 '(1 2 3 . 5))
196 (deftest cons.7 (let ((list (cons nil nil)))
197 (setf (car list) list)
198 (store list *test-file*)
199 (let ((ret (restore *test-file*)))
200 (eq ret (car ret))))
201 t)
202
203
204 ;; hash tables
205 ; for some reason (make-hash-table) is not equalp
206 ; to (make-hash-table) with ecl.
207
208 #-ecl
209 (deftestit hash.1 (make-hash-table))
210
211 #-ecl
212 (defvar *hash* (let ((in (make-hash-table :test #'equal
213 :rehash-threshold 0.4 :size 20
214 :rehash-size 40)))
215 (dotimes (x 1000) (setf (gethash (format nil "~R" x) in) x))
216 in))
217 #-ecl
218 (deftestit hash.2 *hash*)
219
220
221 ;; packages
222 (deftestit package.1 (find-package :cl-store))
223
224 (defpackage foo
225 (:nicknames foobar)
226 (:use :cl)
227 (:shadow cl:format)
228 (:export bar))
229
230 (defun package-restores ()
231 (let (( *nuke-existing-packages* t))
232 (store (find-package :foo) *test-file*)
233 (delete-package :foo)
234 (restore *test-file*)
235 (list (package-name (find-package :foo))
236 (mapcar #'package-name (package-use-list :foo))
237 (package-nicknames :foo)
238 (equalp (remove-duplicates (package-shadowing-symbols :foo))
239 (list (find-symbol "FORMAT" "FOO")))
240 (equalp (cl-store::external-symbols (find-package :foo))
241 (make-array 1 :initial-element (find-symbol "BAR" "FOO"))))))
242
243
244 ; unfortunately it's difficult to portably test the internal symbols
245 ; in a package so we just assume that it's OK.
246 (deftest package.2
247 (package-restores)
248 ("FOO" ("COMMON-LISP") ("FOOBAR") t t))
249
250 ;; objects
251 (defclass foo ()
252 ((x :accessor get-x :initarg :x)))
253
254 (defclass bar (foo)
255 ((y :accessor get-y :initform nil :initarg :y)))
256
257 (defclass quux ()
258 (a))
259
260 (defclass baz (quux)
261 ((z :accessor get-z :initarg :z :allocation :class)))
262
263
264
265 (deftest standard-object.1
266 (let ((val (store (make-instance 'foo :x 3) *test-file*)))
267 (= (get-x val) (get-x (restore *test-file*))))
268 t)
269
270 (deftest standard-object.2
271 (let ((val (store (make-instance 'bar
272 :x (list 1 "foo" 1.0)
273 :y (vector 1 2 3 4))
274 *test-file*)))
275 (let ((ret (restore *test-file*)))
276 (and (equalp (get-x val) (get-x ret))
277 (equalp (get-y val) (get-y ret)))))
278 t)
279
280 (deftest standard-object.3
281 (let ((*store-class-slots* nil)
282 (val (make-instance 'baz :z 9)))
283 (store val *test-file*)
284 (make-instance 'baz :z 2)
285 (= (get-z (restore *test-file*))
286 2))
287 t)
288
289 (deftest standard-object.4
290 (let ((*store-class-slots* t)
291 (val (make-instance 'baz :z 9)))
292 (store val *test-file*)
293 (make-instance 'baz :z 2)
294 (let ((ret (restore *test-file*)))
295 (= (get-z ret )
296 9)))
297 t)
298
299 ;; classes
300 (deftest standard-class.1 (progn (store (find-class 'foo) *test-file*)
301 (restore *test-file*)
302 t)
303 t)
304
305 (deftest standard-class.2 (progn (store (find-class 'bar) *test-file*)
306 (restore *test-file*)
307 t)
308 t)
309
310 (deftest standard-class.3 (progn (store (find-class 'baz) *test-file*)
311 (restore *test-file*)
312 t)
313 t)
314
315
316
317 ;; conditions
318 (deftest condition.1
319 (handler-case (/ 1 0)
320 (division-by-zero (c)
321 (store c *test-file*)
322 (typep (restore *test-file*) 'division-by-zero)))
323 t)
324
325 (deftest condition.2
326 (handler-case (car (read-from-string "3"))
327 ;; allegro pre 7.0 signalled a simple-error here
328 ((or type-error simple-error) (c)
329 (store c *test-file*)
330 (typep (restore *test-file*)
331 '(or type-error simple-error))))
332 t)
333
334 ;; structure-object
335
336 (defstruct a
337 a b c)
338
339 (defstruct (b (:include a))
340 d e f)
341
342 #+(or sbcl cmu lispworks openmcl)
343 (deftestit structure-object.1 (make-a :a 1 :b 2 :c 3))
344 #+(or sbcl cmu lispworks openmcl)
345 (deftestit structure-object.2 (make-b :a 1 :b 2 :c 3 :d 4 :e 5 :f 6))
346 #+(or sbcl cmu lispworks openmcl)
347 (deftestit structure-object.3 (make-b :a 1 :b (make-a :a 1 :b 3 :c 2)
348 :c #\Space :d #(1 2 3) :e (list 1 2 3)
349 :f (make-hash-table)))
350
351 ;; setf test
352 (deftestit setf.1 (setf (restore *test-file*) 0))
353 (deftestit setf.2 (incf (restore *test-file*)))
354 (deftestit setf.3 (decf (restore *test-file*) 2))
355
356 (deftestit pathname.1 #P"/home/foo")
357 (deftestit pathname.2 (make-pathname :name "foo"))
358 (deftestit pathname.3 (make-pathname :name "foo" :type "bar"))
359
360
361 ; built-in classes
362 (deftestit built-in.1 (find-class 'hash-table))
363 (deftestit built-in.2 (find-class 'integer))
364
365
366 ;; find-backend tests
367 (deftest find-backend.1
368 (and (find-backend 'cl-store) t)
369 t)
370
371 (deftest find-backend.2
372 (find-backend (gensym))
373 nil)
374
375 (deftest find-backend.3
376 (handler-case (find-backend (gensym) t)
377 (error (c) (and c t))
378 (:no-error (val) (and val nil)))
379 t)
380
381
382
383 ;; circular objects
384 (defvar circ1 (let ((x (list 1 2 3 4)))
385 (setf (cdr (last x)) x)))
386 (deftest circ.1 (progn (store circ1 *test-file*)
387 (let ((x (restore *test-file*)))
388 (eql (cddddr x) x)))
389 t)
390
391 (defvar circ2 (let ((x (list 2 3 4 4 5)))
392 (setf (second x) x)))
393 (deftest circ.2 (progn (store circ2 *test-file*)
394 (let ((x (restore *test-file*)))
395 (eql (second x) x)))
396 t)
397
398
399
400 (defvar circ3 (let ((x (list (list 1 2 3 4 )
401 (list 5 6 7 8)
402 9)))
403 (setf (second x) (car x))
404 (setf (cdr (last x)) x)
405 x))
406
407 (deftest circ.3 (progn (store circ3 *test-file*)
408 (let ((x (restore *test-file*)))
409 (and (eql (second x) (car x))
410 (eql (cdddr x) x))))
411 t)
412
413
414 (defvar circ4 (let ((x (make-hash-table)))
415 (setf (gethash 'first x) (make-hash-table))
416 (setf (gethash 'second x) (gethash 'first x))
417 (setf (gethash 'inner (gethash 'first x)) x)
418 x))
419
420 (deftest circ.4 (progn (store circ4 *test-file*)
421 (let ((x (restore *test-file*)))
422 (and (eql (gethash 'first x)
423 (gethash 'second x))
424 (eql x
425 (gethash 'inner
426 (gethash 'first x))))))
427 t)
428
429 (deftest circ.5 (let ((circ5 (make-instance 'bar)))
430 (setf (get-y circ5) circ5)
431 (store circ5 *test-file*)
432 (let ((x (restore *test-file*)))
433 (eql x (get-y x))))
434 t)
435
436
437 (defvar circ6 (let ((y (make-array '(2 2 2)
438 :initial-contents '((("foo" "bar")
439 ("me" "you"))
440 ((5 6) (7 8))))))
441 (setf (aref y 1 1 1) y)
442 (setf (aref y 0 0 0) (aref y 1 1 1))
443 y))
444
445
446 (deftest circ.6 (progn (store circ6 *test-file*)
447 (let ((x (restore *test-file*)))
448 (and (eql (aref x 1 1 1) x)
449 (eql (aref x 0 0 0) (aref x 1 1 1)))))
450 t)
451
452
453
454 (defvar circ7 (let ((x (make-a)))
455 (setf (a-a x) x)))
456
457 #+(or sbcl cmu lispworks)
458 (deftest circ.7 (progn (store circ7 *test-file*)
459 (let ((x (restore *test-file*)))
460 (eql (a-a x) x)))
461 t)
462
463 (defvar circ.8 (let ((x "foo"))
464 (make-pathname :name x :type x)))
465
466
467 ;; clisp apparently creates a copy of the strings in a pathname
468 ;; so a test for eqness is pointless.
469 #-clisp
470 (deftest circ.8 (progn (store circ.8 *test-file*)
471 (let ((x (restore *test-file*)))
472 (eql (pathname-name x)
473 (pathname-type x))))
474 t)
475
476
477 (deftest circ.9 (let ((val (vector "foo" "bar" "baz" 1 2)))
478 (setf (aref val 3) val)
479 (setf (aref val 4) (aref val 0))
480 (store val *test-file*)
481 (let ((rest (restore *test-file*)))
482 (and (eql rest (aref rest 3))
483 (eql (aref rest 4) (aref rest 0)))))
484 t)
485
486 (deftest circ.10 (let* ((a1 (make-array 5))
487 (a2 (make-array 4 :displaced-to a1
488 :displaced-index-offset 1))
489 (a3 (make-array 2 :displaced-to a2
490 :displaced-index-offset 2)))
491 (setf (aref a3 1) a3)
492 (store a3 *test-file*)
493 (let ((ret (restore *test-file*)))
494 (eql a3 (aref a3 1))))
495 t)
496
497 (defvar circ.11 (let ((x (make-hash-table)))
498 (setf (gethash x x) x)
499 x))
500
501 (deftest circ.11 (progn (store circ.11 *test-file*)
502 (let ((val (restore *test-file*)))
503 (eql val (gethash val val))))
504 t)
505
506 (deftest circ.12 (let ((x (vector 1 2 "foo" 4 5)))
507 (setf (aref x 0) x)
508 (setf (aref x 1) (aref x 2))
509 (store x *test-file*)
510 (let ((ret (restore *test-file*)))
511 (and (eql (aref ret 0) ret)
512 (eql (aref ret 1) (aref ret 2)))))
513 t)
514
515
516 (defclass foo.1 ()
517 ((a :accessor foo1-a)))
518
519 ;; a test from Robert Sedgwick which crashed in earlier
520 ;; versions (pre 0.2)
521 (deftest circ.13 (let ((foo (make-instance 'foo.1))
522 (bar (make-instance 'foo.1)))
523 (setf (foo1-a foo) bar)
524 (setf (foo1-a bar) foo)
525 (store (list foo) *test-file*)
526 (let ((ret (car (restore *test-file*))))
527 (and (eql ret (foo1-a (foo1-a ret)))
528 (eql (foo1-a ret)
529 (foo1-a (foo1-a (foo1-a ret)))))))
530 t)
531
532 #-abcl
533 (deftest circ.14 (let ((list '#1=(1 2 3 #1# . #1#)))
534 (store list *test-file*)
535 (let ((ret (restore *test-file*)))
536 (and (eq ret (cddddr ret))
537 (eq (fourth ret) ret))))
538 t)
539
540
541
542
543 #-abcl
544 (deftest circ.15 (let ((list '#1=(1 2 3 #2=(#2#) . #1#)))
545 (store list *test-file*)
546 (let ((ret (restore *test-file*)))
547 (and (eq ret (cddddr ret))
548 (eq (fourth ret)
549 (car (fourth ret))))))
550 t)
551
552
553
554 ;; this had me confused for a while since what was
555 ;; restored #1=(1 (#1#) #1#) looks nothing like this list,
556 ;; but it turns out that it is correct
557 #-abcl
558 (deftest circ.16 (let ((list '#1=(1 #2=(#1#) . #2#)))
559 (store list *test-file*)
560 (let ((ret (restore *test-file*)))
561 (and (eq ret (caadr ret))
562 (eq ret (third ret)))))
563 t)
564
565 ;; large circular lists
566 (deftest large.1 (let ((list (make-list 100000)))
567 (setf (cdr (last list)) list)
568 (store list *test-file*)
569 (let ((ret (restore *test-file*)))
570 (eq (nthcdr 100000 ret) ret)))
571 t)
572
573 ;; large dotted lists
574 (deftestit large.2 (let ((list (make-list 100000)))
575 (setf (cdr (last list)) 'foo)
576 list))
577
578
579
580 ;; custom storing
581 (defclass random-obj () ((size :accessor size :initarg :size)))
582
583 (defparameter *random-obj-code* (register-code 100 'random-obj))
584
585 (defstore-cl-store (obj random-obj buff)
586 (output-type-code *random-obj-code* buff)
587 (store-object (size obj) buff))
588
589 (defrestore-cl-store (random-obj buff)
590 (random (restore-object buff)))
591
592
593 (deftest custom.1
594 (progn (store (make-instance 'random-obj :size 5) *test-file* )
595 (typep (restore *test-file*) '(integer 0 4)))
596 t)
597
598
599
600 (deftestit function.1 #'restores)
601 (deftestit function.2 #'car)
602
603 (deftestit gfunction.1 #'cl-store:restore)
604 (deftestit gfunction.2 #'cl-store:store)
605 #-clisp
606 (deftestit gfunction.3 #'(setf get-y))
607
608
609 (deftest nocirc.1
610 (let* ((string "FOO")
611 (list `(,string . ,string))
612 (*check-for-circs* nil))
613 (store list *test-file*)
614 (let ((res (restore *test-file*)))
615 (and (not (eql (car res) (cdr res)))
616 (string= (car res) (cdr res)))))
617 t)
618
619
620 (defstruct st.bar x)
621 (defstruct (st.foo (:conc-name f-)
622 (:constructor fooo (z y x))
623 (:copier cp-foo)
624 (:include st.bar)
625 (:predicate is-foo)
626 (:print-function (lambda (obj st dep)
627 (declare (ignore dep))
628 (print-unreadable-object (obj st :type t)
629 (format st "~A" (f-x obj))))))
630 (y 0 :type integer) (z nil :type simple-string))
631
632
633 #+(or sbcl cmu)
634 (deftest struct-class.1
635 (let* ((obj (fooo "Z" 2 3))
636 (string (format nil "~A" obj)))
637 (let ((*nuke-existing-classes* t))
638 (store (find-class 'st.foo) *test-file*)
639 (fmakunbound 'cp-foo)
640 (fmakunbound 'is-foo)
641 (fmakunbound 'fooo)
642 (fmakunbound 'f-x)
643 (fmakunbound 'f-y)
644 (fmakunbound 'f-z)
645 (restore *test-file*)
646 (let* ((new-obj (cp-foo (fooo "Z" 2 3)))
647 (new-string (format nil "~A" new-obj)))
648 (list (is-foo new-obj) (equalp obj new-obj)
649 (string= new-string string)
650 (f-x new-obj) (f-y new-obj) (f-z new-obj)))))
651 (t t t 3 2 "Z"))
652
653 (deftest serialization-unit.1
654 (with-serialization-unit ()
655 (with-open-file (outs *test-file* :element-type '(unsigned-byte 8)
656 :if-exists :supersede :direction :output)
657 (dotimes (x 100)
658 (cl-store:store x outs)))
659 (with-open-file (outs *test-file* :element-type '(unsigned-byte 8)
660 :if-exists :supersede)
661 (loop :repeat 100 :collect (cl-store:restore outs))))
662 #.(loop :for x :below 100 :collect x))
663
664 (defun run-tests (backend)
665 (with-backend backend
666 (regression-test:do-tests))
667 (when (probe-file *test-file*)
668 (ignore-errors (delete-file *test-file*))))
669
670 (run-tests 'cl-store:cl-store)
671
672 ;; EOF
673

  ViewVC Help
Powered by ViewVC 1.1.5