source: project/release/5/srfi-29/trunk/tests/srfi-29-test.scm @ 38077

Last change on this file since 38077 was 38077, checked in by Kon Lovett, 6 weeks ago

C5 port

File size: 8.4 KB
Line 
1;;;; srfi-29-test.scm
2
3;To use w/ TLS:
4;(cd .../srfi-29/trunk/tests; \
5;sudo csi -n -R posix -e '(setenv "SRFI29_TLS" "1")' -s run.scm)
6
7(import (scheme))
8(import test)
9
10(import (srfi 29))
11
12(import (chicken base))
13(import (chicken sort))
14(import (srfi 1))
15
16(define (allow-sysops?)
17  (import (chicken platform))
18  (import (chicken process-context posix))
19  (or
20    (eq? 'windows (software-type))
21    (zero? (current-effective-user-id))) )
22
23(define (->boolean x) (and x #t))
24
25(define (alist=? a b #!optional (=? equal?))
26  (every
27    (lambda (cell-a)
28      (=? cell-a (assoc (car cell-a) b =?)))
29    a) )
30
31(define (sort-by-length ls)
32  (sort ls (lambda (a b) (< (length a) (length b)))) )
33
34(test-begin "SRFI 29")
35
36(test-group "Basics"
37
38  (let (
39    (bal1 '((foo1 . 1) ("bar1" . 2) (baz1 . 3)))
40    (bal2 '((foo2 . 4) ("bar2" . 5) (baz2 . 6)))
41    (bal3 '((foo3 . 7) ("bar3" . 8) (baz3 . 9))) )
42
43    (test-group "Locale"
44
45      (test-assert "L1" (current-language))
46      (test-assert "L2" (current-country))
47      (test-assert "L3" (current-locale-details))
48
49      (test-assert "L4" (symbol? (current-language)))
50      (test-assert "L5" (symbol? (current-country)))
51      (test-assert "L6" (list? (current-locale-details)))
52
53      (test-assert "L7" (current-language 'foo))
54      (test-assert "L8" (current-country 'bar))
55      (test-assert "L9" (current-locale-details '(baz)))
56
57      (test "L10" 'foo (current-language))
58      (test "L11" 'bar (current-country))
59      (test "L12" '(baz) (current-locale-details))
60
61      (reset-locale-parameters)
62    )
63
64    (test-group "Bundles"
65
66      (test-assert "" (declare-bundle! '(srfi-29-test) bal1))
67      (test-assert "" (declare-bundle! '(srfi-29-test foo) bal2))
68      (test-assert "" (declare-bundle! '(srfi-29-test foo bar) bal3))
69
70      (test "declared-bundle-specifiers"
71          '((srfi-29-test) (srfi-29-test foo) (srfi-29-test foo bar))
72          (sort-by-length (declared-bundle-specifiers)))
73      (test-assert "declared-bundle-templates"
74        (alist=? bal1 (declared-bundle-templates '(srfi-29-test))))
75      (test-assert "declared-bundle-templates foo"
76        (alist=? bal2 (declared-bundle-templates '(srfi-29-test foo))))
77      (test-assert "declared-bundle-templates foo bar"
78        (alist=? bal3 (declared-bundle-templates '(srfi-29-test foo bar))))
79
80      (test "declared-bundle-templates foo1" 1 (localized-template 'srfi-29-test 'foo1))
81      (test "declared-bundle-templates bar1" 2 (localized-template 'srfi-29-test "bar1"))
82      (test "declared-bundle-templates baz1" 3 (localized-template 'srfi-29-test 'baz1))
83
84      (test-assert "undeclare-bundle!" (undeclare-bundle! '(srfi-29-test)))
85      (test-assert "undeclare-bundle! foo" (undeclare-bundle! '(srfi-29-test foo)))
86      (test-assert "undeclare-bundle! foo bar" (undeclare-bundle! '(srfi-29-test foo bar)))
87
88      (test-assert "undeclared foo1" (not (localized-template 'srfi-29-test 'foo1)))
89      (test-assert "undeclared bar1" (not (localized-template 'srfi-29-test "bar1")))
90      (test-assert "undeclared baz1" (not (localized-template 'srfi-29-test 'baz1)))
91    )
92
93    (test-group "Bundles Alternate Directory"
94
95      (define altdir ".")
96
97      (test-assert "B1" (declare-bundle! '(srfi-29-test) bal1))
98      (test-assert "B2" (declare-bundle! '(srfi-29-test foo) bal2))
99      (test-assert "B3" (declare-bundle! '(srfi-29-test foo bar) bal3))
100
101      (test-assert "B7" (store-bundle! '(srfi-29-test) altdir))
102      (test-assert "B8" (store-bundle! '(srfi-29-test foo) altdir))
103      (test-assert "B9" (store-bundle! '(srfi-29-test foo bar) altdir))
104
105      (test-assert "B10" (remove-bundle! '(srfi-29-test) altdir))
106      (test-assert "B11" (remove-bundle! '(srfi-29-test foo) altdir))
107      (test-assert "B12" (remove-bundle! '(srfi-29-test foo bar) altdir))
108
109      (test-assert "B13" (not (load-bundle! '(srfi-29-test) altdir)))
110      (test-assert "B14" (not (load-bundle! '(srfi-29-test foo) altdir)))
111      (test-assert "B15" (not (load-bundle! '(srfi-29-test foo bar) altdir)))
112
113      (test-assert "AltDir RmDir" (remove-bundle-directory! '(srfi-29-test foo bar) altdir))
114    )
115
116    (test-group "Installed Test Bundle"
117      (load-best-available-bundle! (most-specific-bundle-specifier 'srfi-29))
118      (test "SRFI 29" (localized-template/default 'srfi-29 'srfi-29))
119    )
120
121    (when (allow-sysops?)
122      (test-group "Bundles System Directory"
123
124        (test-assert "B16" (declare-bundle! '(srfi-29-test) bal1))
125        (test-assert "B17" (declare-bundle! '(srfi-29-test foo) bal2))
126        (test-assert "B18" (declare-bundle! '(srfi-29-test foo bar) bal3))
127
128        (test-assert "B19" (store-bundle! '(srfi-29-test)))
129        (test-assert "B20" (store-bundle! '(srfi-29-test foo)))
130        (test-assert "B21" (store-bundle! '(srfi-29-test foo bar)))
131
132        (test-assert "B22" (undeclare-bundle! '(srfi-29-test)))
133        (test-assert "B23" (undeclare-bundle! '(srfi-29-test foo)))
134        (test-assert "B24" (undeclare-bundle! '(srfi-29-test foo bar)))
135
136        (test-assert "B25.1" (not (localized-template 'srfi-29-test 'foo1)))
137        (test-assert "B26.1" (not (localized-template 'srfi-29-test "bar1")))
138        (test-assert "B27.1" (not (localized-template 'srfi-29-test 'baz1)))
139
140        (test-assert "B22.1" (load-bundle! '(srfi-29-test)))
141        (test-assert "B23.1" (load-bundle! '(srfi-29-test foo)))
142        (test-assert "B24.1" (load-bundle! '(srfi-29-test foo bar)))
143
144        (test "B25" 1 (localized-template 'srfi-29-test 'foo1))
145        (test "B26" 2 (localized-template 'srfi-29-test "bar1"))
146        (test "B27" 3 (localized-template 'srfi-29-test 'baz1))
147
148        (test "localized-templates" bal1 (localized-templates 'srfi-29-test))
149
150        (current-language 'foo)
151
152        (test "B28" 4 (localized-template 'srfi-29-test 'foo2))
153        (test "B29" 5 (localized-template 'srfi-29-test "bar2"))
154        (test "B30" 6 (localized-template 'srfi-29-test 'baz2))
155
156        (test "localized-templates language foo" bal2 (localized-templates 'srfi-29-test))
157
158        (current-country 'bar)
159
160        (test "B31" 7 (localized-template 'srfi-29-test 'foo3))
161        (test "B32" 8 (localized-template 'srfi-29-test "bar3"))
162        (test "B33" 9 (localized-template 'srfi-29-test 'baz3))
163
164        (test "localized-templates language foo, country bar"
165          bal3 (localized-templates 'srfi-29-test))
166
167        (test-assert "B37.1" (localized-template-set! 'srfi-29-test 'baz3 'foobar))
168        (test "B37.2" 'foobar (localized-template 'srfi-29-test 'baz3))
169        (test-assert "B37.3" (not (localized-template-set! 'foobar 'baz3 #t)))
170        (test-assert "B37.4" (localized-template-set! 'srfi-29-test 'barf 16))
171        (test "B37.5" 16 (localized-template 'srfi-29-test 'barf))
172
173        (test-assert "B34" (remove-bundle! '(srfi-29-test)))
174        (test-assert "B35" (remove-bundle! '(srfi-29-test foo)))
175        (test-assert "B36" (remove-bundle! '(srfi-29-test foo bar)))
176
177        (test-assert "SysDir RmDir" (remove-bundle-directory! '(srfi-29-test foo bar)))
178
179        (reset-locale-parameters)
180      )
181    )
182  )
183
184  #;(test-assert "B22.2" (load-best-available-bundle! (most-specific-bundle-specifier 'srfi-19)))
185  #;(test "B22.3 English" "August" (localized-template 'srfi-19 'august))
186  #;(test "B22.4 English" "December" (localized-template 'srfi-19 'december))
187)
188
189(import srfi-29-logic)
190
191(import (chicken process))
192
193(test-group "Logic (extension)"
194
195  ;for compile & load so extension assumed
196  (define test-logic-filename "test-logic")
197
198  ;compile logic
199  (system (string-append "csc -s " test-logic-filename))
200
201  ;declare logic pkg
202  (declare-bundle! '(srfi-29-test)
203    `((library . ,test-logic-filename)          ;pathname of compiled logic (for load)
204      (proc* . (srfi-29-test . test-star))      ;module ident
205      (proc0 . srfi-29-test-0)                  ;0 arg proc
206      (proc1 . srfi-29-test-1)                  ;1 arg proc
207      (procN . srfi-29-test-N)))                ;N arg proc
208
209  (define item@ (make-required-localized-template 'srfi-29-test))
210  (test-assert (procedure? item@))
211
212  ;load logic
213  (load-localized-compiled-code
214    (item@ 'library)
215    'srfi-29-test
216    '(proc0 proc1 procN proc*))
217
218  ;test logic
219  (test-assert (procedure? (item@ 'proc0)))
220  (test-assert (procedure? (item@ 'proc1)))
221  (test-assert (procedure? (item@ 'procN)))
222  (test-assert (procedure? (item@ 'proc*)))
223
224  (test 0 ((item@ 'proc0)))
225  (test -56 ((item@ 'proc1) 56))
226  (test '(1 2 3 4 5 6) ((item@ 'procN) 1 2 3 4 5 6))
227  (test '(* hello) ((item@ 'proc*) 'hello))
228)
229
230(test-end "SRFI 29")
231
232(test-exit)
Note: See TracBrowser for help on using the repository browser.