tests.lisp

Revision 2554, 21.4 kB (checked in by ksprotte, 11 months ago)
added cl-store
Property svn:executable set to ``*

Line
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	#-abcl
567	(deftest large.1 (let ((list (make-list 100000)))
568	(setf (cdr (last list)) list)
569	(store list test-file)
570	(let ((ret (restore test-file)))
571	(eq (nthcdr 100000 ret) ret)))
572	t)
573
574	;; large dotted lists
575	#-abcl
576	(deftestit large.2 (let ((list (make-list 100000)))
577	(setf (cdr (last list)) 'foo)
578	list))
579
580
581
582	;; custom storing
583	(defclass random-obj () ((size :accessor size :initarg :size)))
584
585	(defparameter random-obj-code (register-code 100 'random-obj))
586
587	(defstore-cl-store (obj random-obj buff)
588	(output-type-code random-obj-code buff)
589	(store-object (size obj) buff))
590
591	(defrestore-cl-store (random-obj buff)
592	(random (restore-object buff)))
593
594
595	(deftest custom.1
596	(progn (store (make-instance 'random-obj :size 5) test-file )
597	(typep (restore test-file) '(integer 0 4)))
598	t)
599
600
601	;; These tests are quite incorrect as there is no universal method
602	;; test for function equality when they are not eq.
603	;; While this will work for functions restored based on name
604	;; it will most definitely not work for closures.
605	;; So we just do limited tests on behaviour
606	(deftestit function.1 #'car)
607
608
609	(deftest function.2
610	(progn (store #'cl-store::mkstr test-file)
611	(let ((fn (restore test-file)))
612	(every (lambda (args)
613	(string= (apply fn args) (apply #'cl-store::mkstr args)))
614	'(("foobar" "baz")
615	("a" "b" "c")
616	("1 2" "ab " "f oO")))))
617	t)
618
619	;; Closures are clisp only.
620	#+clisp
621	(deftest function.3
622	(progn (store (list #'(lambda (x y) (funcall x (1+ y)))
623	#'(lambda (x) (expt x 3)))
624	test-file)
625	(destructuring-bind (fn-a fn-b) (restore test-file)
626	(funcall fn-a fn-b 3)))
627	64)
628
629	(let ((x 1))
630	(defun foo ()
631	(incf x))
632	(defun bar ()
633	(decf x)))
634
635	;; While this works on all Lisps only CLISP is actually creating
636	;; a fresh function on the restore.
637	#+clisp
638	(deftest function.4
639	(progn (store (list #'foo #'bar) test-file)
640	(destructuring-bind (fn-a fn-b) (restore test-file)
641	(values (funcall fn-a)
642	(funcall fn-a)
643	(funcall fn-b))))
644	2 3 2)
645
646	(deftestit gfunction.1 #'cl-store:restore)
647	(deftestit gfunction.2 #'cl-store:store)
648	#-clisp
649	(deftestit gfunction.3 #'(setf get-y))
650
651
652	(deftest nocirc.1
653	(let* ((string "FOO")
654	(list `(,string . ,string))
655	(check-for-circs nil))
656	(store list test-file)
657	(let ((res (restore test-file)))
658	(and (not (eql (car res) (cdr res)))
659	(string= (car res) (cdr res)))))
660	t)
661
662
663	(defstruct st.bar x)
664	(defstruct (st.foo (:conc-name f-)
665	(:constructor fooo (z y x))
666	(:copier cp-foo)
667	(:include st.bar)
668	(:predicate is-foo)
669	(:print-function (lambda (obj st dep)
670	(declare (ignore dep))
671	(print-unreadable-object (obj st :type t)
672	(format st "~A" (f-x obj))))))
673	(y 0 :type integer) (z nil :type simple-string))
674
675
676	#+(or sbcl cmu)
677	(deftest struct-class.1
678	(let* ((obj (fooo "Z" 2 3))
679	(string (format nil "~A" obj)))
680	(let ((nuke-existing-classes t))
681	(store (find-class 'st.foo) test-file)
682	(fmakunbound 'cp-foo)
683	(fmakunbound 'is-foo)
684	(fmakunbound 'fooo)
685	(fmakunbound 'f-x)
686	(fmakunbound 'f-y)
687	(fmakunbound 'f-z)
688	(restore test-file)
689	(let* ((new-obj (cp-foo (fooo "Z" 2 3)))
690	(new-string (format nil "~A" new-obj)))
691	(list (is-foo new-obj) (equalp obj new-obj)
692	(string= new-string string)
693	(f-x new-obj) (f-y new-obj) (f-z new-obj)))))
694	(t t t 3 2 "Z"))
695
696	(deftest serialization-unit.1
697	(with-serialization-unit ()
698	(with-open-file (outs test-file :element-type '(unsigned-byte 8)
699	:if-exists :supersede :direction :output)
700	(dotimes (x 100)
701	(cl-store:store x outs)))
702	(with-open-file (outs test-file :element-type '(unsigned-byte 8)
703	:if-exists :supersede)
704	(loop :repeat 100 :collect (cl-store:restore outs))))
705	#.(loop :for x :below 100 :collect x))
706
707	(defun run-tests (backend)
708	(with-backend backend
709	(regression-test:do-tests))
710	(when (probe-file test-file)
711	(ignore-errors (delete-file test-file))))
712
713
714	(do-tests)
715	;; EOF
716

Note: See TracBrowser for help on using the browser.

Download in other formats:

Original Format