1#| rep.test.data -- checks for rep.data module
2
3   $Id$
4
5   Copyright (C) 2001 John Harper <jsh@users.sourceforge.net>
6
7   This file is part of librep.
8
9   librep is free software; you can redistribute it and/or modify it
10   under the terms of the GNU General Public License as published by
11   the Free Software Foundation; either version 2, or (at your option)
12   any later version.
13
14   librep is distributed in the hope that it will be useful, but
15   WITHOUT ANY WARRANTY; without even the implied warranty of
16   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
17   GNU General Public License for more details.
18
19   You should have received a copy of the GNU General Public License
20   along with librep; see the file COPYING.  If not, write to
21   the Free Software Foundation, 51 Franklin Street, Fifth Floor,
22   Boston, MA 02110-1301 USA
23|#
24
25(define-structure rep.data.self-tests ()
26
27    (open rep
28	  rep.data.records
29	  rep.test.framework)
30
31;;; equality function tests
32
33  ;; adapted from guile's test.scm
34  (define (equality-self-test)
35    (define (gen-counter)
36      (let ((n 0))
37	(lambda () (setq n (1+ n)) n)))
38
39    (test (eql 'a 'a))
40    (test (not (eql 'a 'b)))
41    (test (eql 2 2))
42    (test (eql '() '()))
43    (test (eql '10000 '10000))
44    (test (not (eql (cons 1 2) (cons 1 2))))
45    (test (not (eql (lambda () 1) (lambda () 2))))
46
47    (let ((p (lambda (x) x)))
48      (test (eql p p)))
49    (let ((g (gen-counter)))
50      (test (eql g g)))
51    (test (not (eql (gen-counter) (gen-counter))))
52    (letrec ((f (lambda () (if (eql f g) 'f 'both)))
53	     (g (lambda () (if (eql f g) 'g 'both))))
54      (test (not (eql f g))))
55
56    (test (eq 'a 'a))
57    (test (not (eq (list 'a) (list 'a))))
58    (test (eq '() '()))
59    (test (eq car car))
60    (let ((x '(a)))
61      (test (eq x x)))
62    (let ((x '()))
63      (test (eq x x)))
64    (let ((x (lambda (x) x)))
65      (test (eq x x)))
66
67    (test (equal 'a 'a))
68    (test (equal '(a) '(a)))
69    (test (equal '(a (b) c) '(a (b) c)))
70    (test (equal "abc" "abc"))
71    (test (equal 2 2))
72    (test (equal (make-vector 5 'a) (make-vector 5 'a))))
73
74;;; cons and list tests
75
76  ;; adapted from guile's test.scm
77  (define (cons-self-test)
78    (test (consp '(a . b)))
79    (test (consp '(a . 1)))
80    (test (consp '(a b c)))
81    (test (not (consp '())))
82    (test (not (consp '#(a b))))
83
84    (test (equal '(a) (cons 'a '())))
85    (test (equal '((a) b c d) (cons '(a) '(b c d))))
86    (test (equal '("a" b c) (cons "a" '(b c))))
87    (test (equal '(a . 3) (cons 'a 3)))
88    (test (equal '((a b) . c) (cons '(a b) 'c)))
89
90    (test (equal 'a (car '(a b c))))
91    (test (equal '(a) (car '((a) b c d))))
92    (test (equal 1 (car '(1 . 2))))
93
94    (test (equal '(b c d) (cdr '((a) b c d))))
95    (test (equal 2 (cdr '(1 . 2))))
96
97    (test (equal '(a 7 c) (list 'a (+ 3 4) 'c)))
98    (test (equal '() (list)))
99
100    (test (= 3 (length '(a b c))))
101    (test (= 3 (length '(a (b) (c d e)))))
102    (test (= 0 (length '())))
103
104    (test (equal '(x y) (append '(x) '(y))))
105    (test (equal '(a b c d) (append '(a) '(b c d))))
106    (test (equal '(a (b) (c)) (append '(a (b)) '((c)))))
107    (test (equal '() (append)))
108    (test (equal '(a b c . d) (append '(a b) '(c . d))))
109    (test (equal 'a (append '() 'a)))
110
111    (test (equal '(c b a) (reverse '(a b c))))
112    (test (equal '((e (f)) d (b c) a) (reverse '(a (b c) d (e (f))))))
113
114    (test (equal 'c (nth 2 '(a b c d))))
115
116    (test (equal '(a b c) (memq 'a '(a b c))))
117    (test (equal '(b c) (memq 'b '(a b c))))
118    (test (null (memq 'a '(b c d))))
119    (test (null (memq (list 'a) '(b (a) c))))
120    (test (equal '((a) c) (member (list 'a) '(b (a) c))))
121    (test (equal '(101 102) (memql 101 '(100 101 102))))
122
123    (let ((e '((a 1) (b 2) (c 3))))
124      (test (equal '(a 1) (assq 'a e)))
125      (test (equal '(b 2) (assq 'b e)))
126      (test (null (assq 'd e))))
127    (test (null (assq (list 'a) '(((a)) ((b)) ((c))))))
128    (test (equal '((a)) (assoc (list 'a) '(((a)) ((b)) ((c))))))
129    (test (equal '(5 7) (assq 5 '((2 3) (5 7) (11 13))))))
130
131;;; tests for rep.data.records
132
133  (define-record-type :pare
134    (kons x y)
135    pare?
136    (x kar set-kar!)
137    (y kdr))
138
139  (define-record-discloser :pare
140    (lambda (x) (format nil "#<pare %s %s>" (kar x) (kdr x))))
141
142  (define (record-self-test)
143    (define pare (kons 1 2))
144    (test pare)
145    (test (pare? pare))
146    (test (eql (kar pare) 1))
147    (test (eql (kdr pare) 2))
148
149    (set-kar! pare 3)
150    (test (eql (kar pare) 3)))
151
152;;; string-util tests
153
154  (define (string-util-self-test)
155    (test (string-upper-case-p "FOO"))
156    (test (not (string-upper-case-p "Foo")))
157    (test (not (string-upper-case-p "foo")))
158    (test (not (string-upper-case-p "123")))
159
160    (test (string-lower-case-p "foo"))
161    (test (not (string-lower-case-p "Foo")))
162    (test (not (string-lower-case-p "FOO")))
163    (test (not (string-lower-case-p "123")))
164
165    (test (string-capitalized-p "Foo"))
166    (test (string-capitalized-p "FOO"))
167    (test (not (string-capitalized-p "foo")))
168
169    (test (string= (string-upcase "foo") "FOO"))
170    (test (string= (string-upcase "FOO") "FOO"))
171    (test (string= (string-upcase "Foo") "FOO"))
172    (test (string= (string-upcase "123") "123"))
173
174    (test (string= (string-downcase "FOO") "foo"))
175    (test (string= (string-downcase "foo") "foo"))
176    (test (string= (string-downcase "Foo") "foo"))
177    (test (string= (string-downcase "123") "123"))
178
179    (test (string= (capitalize-string "FOO") "FOO"))
180    (test (string= (capitalize-string "foo") "Foo"))
181    (test (string= (capitalize-string "Foo") "Foo"))
182    (test (string= (capitalize-string "123") "123"))
183
184    (test (string= (mapconcat identity '("foo" "bar" "baz") " ")
185		   "foo bar baz"))
186    (test (string= (mapconcat identity '("foo" "bar" "baz") #\space)
187		   "foo bar baz"))
188    (test (string= (mapconcat identity '() #\space) ""))
189    (test (string= (mapconcat string-upcase '("foo" "bar" "baz") " ")
190		   "FOO BAR BAZ")))
191
192  (define (self-test)
193    (equality-self-test)
194    (cons-self-test)
195    (record-self-test)
196    (string-util-self-test))
197
198  ;;###autoload
199  (define-self-test 'rep.data self-test))
200