~ubuntu-branches/ubuntu/maverick/uim/maverick
» Revision
3.1.18
: sigscheme/test/test-srfi1-another.scm
« back to all changes in this revision
Viewing changes to sigscheme/test/test-srfi1-another.scm
- browse files at revision 3.1.18
- compare with another revision
- download diff
- download tarball
- view history from revision 3.1.18
- Committer: Bazaar Package Importer
- Author(s): Masahito Omote
- Date: 2008-05-18 22:18:10 UTC
- mfrom: (1.1.8 upstream)
- mto: This revision was merged to the branch mainline in revision 5.
- Revision ID: james.westby@ubuntu.com-20080518221810-4d2rd0ca18xnu8kc
Tags: 1:1.5.1-1
* New upstream release
* uim-qt3: Add uim inputcontext plugin for Qt3. And due to uim-*-qt are
not supported in Qt4 for now officially, uim-*-qt are contained in
this package.
* uim-qt: Depends uim-qt3 because of described above.
* libuim6: New package for syncing with upstream upgrade soversion.
* 05_qmake_bug_workaround.dpatch: patch for the workaround that qmake does
not add link option against other libraries(e.g. -lX11) by default.
* uim-qt3: Add uim inputcontext plugin for Qt3. And due to uim-*-qt are
not supported in Qt4 for now officially, uim-*-qt are contained in
this package.
* uim-qt: Depends uim-qt3 because of described above.
* libuim6: New package for syncing with upstream upgrade soversion.
* 05_qmake_bug_workaround.dpatch: patch for the workaround that qmake does
not add link option against other libraries(e.g. -lX11) by default.
- files added:
- debian/libuim6.install
- notify
- qt4
- qt4/edittest
- qt4/immodule
- files removed:
- debian/libuim5.install
- files modified:
- AUTHORS
added
removed
sigscheme/test/test-srfi1-another.scm
1
#! /usr/bin/env sscm -C UTF-8
2
3
;; Filename : test-srfi1-another.scm
4
;; About : unit test for SRFI-1 (another version)
5
;;
6
;; Copyright (c) 2007-2008 SigScheme Project <uim-en AT googlegroups.com>
7
;;
8
;; All rights reserved.
9
;;
10
;; Redistribution and use in source and binary forms, with or without
11
;; modification, are permitted provided that the following conditions
12
;; are met:
13
;;
14
;; 1. Redistributions of source code must retain the above copyright
15
;; notice, this list of conditions and the following disclaimer.
16
;; 2. Redistributions in binary form must reproduce the above copyright
17
;; notice, this list of conditions and the following disclaimer in the
18
;; documentation and/or other materials provided with the distribution.
19
;; 3. Neither the name of authors nor the names of its contributors
20
;; may be used to endorse or promote products derived from this software
21
;; without specific prior written permission.
22
;;
23
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS
24
;; IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
25
;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
26
;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
27
;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
28
;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
29
;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
30
;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
31
;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
32
;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
33
;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
34
35
(require-extension (unittest))
36
37
(require-extension (srfi 1 6 23 38))
38
39
(if (not (provided? "srfi-1"))
40
(test-skip "SRFI-1 is not enabled"))
41
42
(define tn test-name)
43
44
;;(define drop list-tail)
45
46
;; To prevent being affected from possible bug of the C implementation of
47
;; list-tail, tests in this file use this R5RS definition of list-tail.
48
(define my-list-tail
49
(lambda (x k)
50
(if (zero? k)
51
x
52
(my-list-tail (cdr x) (- k 1)))))
53
54
;; unique objects
55
(define elm0 (list 0))
56
(define elm1 (list 1))
57
(define elm2 (list 2))
58
(define elm3 (list 3))
59
(define elm4 (list 4))
60
(define elm5 (list 5))
61
(define elm6 (list 6))
62
(define elm7 (list 7))
63
(define elm8 (list 8))
64
(define elm9 (list 9))
65
;; sublists
66
(define cdr9 (cons elm9 '()))
67
(define cdr8 (cons elm8 cdr9))
68
(define cdr7 (cons elm7 cdr8))
69
(define cdr6 (cons elm6 cdr7))
70
(define cdr5 (cons elm5 cdr6))
71
(define cdr4 (cons elm4 cdr5))
72
(define cdr3 (cons elm3 cdr4))
73
(define cdr2 (cons elm2 cdr3))
74
(define cdr1 (cons elm1 cdr2))
75
(define cdr0 (cons elm0 cdr1))
76
(define lst cdr0)
77
;; circular lists
78
(define clst1 (list 1))
79
(set-cdr! clst1 clst1)
80
(define clst2 (list 1 2))
81
(set-cdr! (my-list-tail clst2 1) clst2)
82
(define clst3 (list 1 2 3))
83
(set-cdr! (my-list-tail clst3 2) clst3)
84
(define clst4 (list 1 2 3 4))
85
(set-cdr! (my-list-tail clst4 3) clst4)
86
87
88
;;
89
;; Constructors
90
;;
91
92
(tn "xcons")
93
(assert-equal? (tn) (cons elm1 elm0) (xcons elm0 elm1))
94
(assert-eq? (tn) elm1 (car (xcons elm0 elm1)))
95
(assert-eq? (tn) elm0 (cdr (xcons elm0 elm1)))
96
97
(tn "cons* invalid forms")
98
(assert-error (tn) (lambda () (cons*)))
99
(tn "cons*")
100
(assert-eq? (tn) elm0 (cons* elm0))
101
(assert-equal? (tn) (cons elm0 elm1) (cons* elm0 elm1))
102
(assert-equal? (tn) (cons elm0 (cons elm1 elm2)) (cons* elm0 elm1 elm2))
103
(assert-equal? (tn) lst (cons* elm0 elm1 elm2 cdr3))
104
(assert-false (tn) (eq? lst (cons* elm0 elm1 elm2 cdr3)))
105
(assert-false (tn) (eq? cdr2 (my-list-tail (cons* elm0 elm1 elm2 cdr3) 2)))
106
(assert-true (tn) (eq? cdr3 (my-list-tail (cons* elm0 elm1 elm2 cdr3) 3)))
107
(assert-equal? (tn) '(1 2 3 4 5 6) (cons* 1 2 3 '(4 5 6)))
108
(tn "cons* SRFI-1 examples")
109
(assert-equal? (tn) '(1 2 3 . 4) (cons* 1 2 3 4))
110
(assert-equal? (tn) 1 (cons* 1))
111
112
(tn "make-list invalid forms")
113
(assert-error (tn) (lambda () (make-list #t)))
114
(assert-error (tn) (lambda () (make-list -1)))
115
(assert-error (tn) (lambda () (make-list 0 #t #t)))
116
(tn "make-list")
117
(define fill (if sigscheme?
118
(undef)
119
(error "filler value of make-list is unknown")))
120
(assert-equal? (tn) '() (make-list 0))
121
(assert-equal? (tn) (list fill) (make-list 1))
122
(assert-equal? (tn) (list fill fill) (make-list 2))
123
(assert-equal? (tn) (list fill fill fill) (make-list 3))
124
(assert-equal? (tn) (list fill fill fill fill) (make-list 4))
125
(assert-equal? (tn) '() (make-list 0 elm0))
126
(assert-equal? (tn) (list elm0) (make-list 1 elm0))
127
(assert-equal? (tn) (list elm0 elm0) (make-list 2 elm0))
128
(assert-equal? (tn) (list elm0 elm0 elm0) (make-list 3 elm0))
129
(assert-equal? (tn) (list elm0 elm0 elm0 elm0) (make-list 4 elm0))
130
131
(tn "list-tabulate invalid forms")
132
(assert-error (tn) (lambda () (list-tabulate 0)))
133
(assert-error (tn) (lambda () (list-tabulate 0 number->string #t)))
134
(assert-error (tn) (lambda () (list-tabulate 0 #t #t)))
135
(assert-error (tn) (lambda () (list-tabulate 1 string->number)))
136
(tn "list-tabulate")
137
(assert-equal? (tn) '() (list-tabulate 0 number->string))
138
(assert-equal? (tn) '("0") (list-tabulate 1 number->string))
139
(assert-equal? (tn) '("0" "1") (list-tabulate 2 number->string))
140
(assert-equal? (tn) '("0" "1" "2") (list-tabulate 3 number->string))
141
(assert-equal? (tn) '("0" "1" "2" "3") (list-tabulate 4 number->string))
142
(tn "list-tabulate SRFI-1 examples")
143
(assert-equal? (tn) '(0 1 2 3) (list-tabulate 4 values))
144
145
(tn "list-copy invalid forms")
146
(assert-error (tn) (lambda () (list-copy)))
147
(tn "list-copy")
148
(assert-equal? (tn) lst (list-copy lst))
149
(assert-false (tn) (eq? lst (list-copy lst)))
150
(assert-false (tn) (eq? (my-list-tail lst 1)
151
(my-list-tail (list-copy lst) 1)))
152
(assert-false (tn) (eq? (my-list-tail lst 2)
153
(my-list-tail (list-copy lst) 2)))
154
(assert-false (tn) (eq? (my-list-tail lst 9)
155
(my-list-tail (list-copy lst) 9)))
156
;; null terminator
157
(assert-true (tn) (eq? (my-list-tail lst 10)
158
(my-list-tail (list-copy lst) 10)))
159
160
(tn "circular-list invalid forms")
161
(assert-error (tn) (lambda () (circular-list)))
162
(tn "circular-list length 1")
163
(assert-eq? (tn) elm0 (car (my-list-tail (circular-list elm0) 0)))
164
(assert-eq? (tn) elm0 (car (my-list-tail (circular-list elm0) 1)))
165
(assert-eq? (tn) elm0 (car (my-list-tail (circular-list elm0) 2)))
166
(assert-eq? (tn) elm0 (car (my-list-tail (circular-list elm0) 3)))
167
(assert-eq? (tn) elm0 (car (my-list-tail (circular-list elm0) 4)))
168
(assert-eq? (tn) elm0 (car (my-list-tail (circular-list elm0) 5)))
169
(tn "circular-list length 2")
170
(assert-eq? (tn) elm0 (car (my-list-tail (circular-list elm0 elm1) 0)))
171
(assert-eq? (tn) elm1 (car (my-list-tail (circular-list elm0 elm1) 1)))
172
(assert-eq? (tn) elm0 (car (my-list-tail (circular-list elm0 elm1) 2)))
173
(assert-eq? (tn) elm1 (car (my-list-tail (circular-list elm0 elm1) 3)))
174
(assert-eq? (tn) elm0 (car (my-list-tail (circular-list elm0 elm1) 4)))
175
(assert-eq? (tn) elm1 (car (my-list-tail (circular-list elm0 elm1) 5)))
176
(tn "circular-list length 3")
177
(assert-eq? (tn) elm0 (car (my-list-tail (circular-list elm0 elm1 elm2) 0)))
178
(assert-eq? (tn) elm1 (car (my-list-tail (circular-list elm0 elm1 elm2) 1)))
179
(assert-eq? (tn) elm2 (car (my-list-tail (circular-list elm0 elm1 elm2) 2)))
180
(assert-eq? (tn) elm0 (car (my-list-tail (circular-list elm0 elm1 elm2) 3)))
181
(assert-eq? (tn) elm1 (car (my-list-tail (circular-list elm0 elm1 elm2) 4)))
182
(assert-eq? (tn) elm2 (car (my-list-tail (circular-list elm0 elm1 elm2) 5)))
183
(assert-eq? (tn) elm0 (car (my-list-tail (circular-list elm0 elm1 elm2) 6)))
184
185
(tn "iota invalid forms")
186
(assert-error (tn) (lambda () (iota)))
187
(assert-error (tn) (lambda () (iota -1)))
188
(assert-error (tn) (lambda () (iota -1 0 1)))
189
(assert-error (tn) (lambda () (iota -1 0 1)))
190
(assert-error (tn) (lambda () (iota 0 0 0 0)))
191
(assert-error (tn) (lambda () (iota 1 0 0 0)))
192
(tn "iota count only")
193
(assert-equal? (tn) '() (iota 0))
194
(assert-equal? (tn) '(0) (iota 1))
195
(assert-equal? (tn) '(0 1) (iota 2))
196
(assert-equal? (tn) '(0 1 2) (iota 3))
197
(assert-equal? (tn) '(0 1 2 3) (iota 4))
198
(tn "iota count and start")
199
(assert-equal? (tn) '() (iota 0 2))
200
(assert-equal? (tn) '(2) (iota 1 2))
201
(assert-equal? (tn) '(2 3) (iota 2 2))
202
(assert-equal? (tn) '(2 3 4) (iota 3 2))
203
(assert-equal? (tn) '(2 3 4 5) (iota 4 2))
204
;; nagative start
205
(assert-equal? (tn) '() (iota 0 -2))
206
(assert-equal? (tn) '(-2) (iota 1 -2))
207
(assert-equal? (tn) '(-2 -1) (iota 2 -2))
208
(assert-equal? (tn) '(-2 -1 0) (iota 3 -2))
209
(assert-equal? (tn) '(-2 -1 0 1) (iota 4 -2))
210
(tn "iota count, start and step")
211
(assert-equal? (tn) '() (iota 0 2 3))
212
(assert-equal? (tn) '(2) (iota 1 2 3))
213
(assert-equal? (tn) '(2 5) (iota 2 2 3))
214
(assert-equal? (tn) '(2 5 8) (iota 3 2 3))
215
(assert-equal? (tn) '(2 5 8 11) (iota 4 2 3))
216
;; negative step
217
(assert-equal? (tn) '() (iota 0 2 -3))
218
(assert-equal? (tn) '(2) (iota 1 2 -3))
219
(assert-equal? (tn) '(2 -1) (iota 2 2 -3))
220
(assert-equal? (tn) '(2 -1 -4) (iota 3 2 -3))
221
(assert-equal? (tn) '(2 -1 -4 -7) (iota 4 2 -3))
222
;; zero step
223
(assert-equal? (tn) '() (iota 0 2 0))
224
(assert-equal? (tn) '(2) (iota 1 2 0))
225
(assert-equal? (tn) '(2 2) (iota 2 2 0))
226
(assert-equal? (tn) '(2 2 2) (iota 3 2 0))
227
(assert-equal? (tn) '(2 2 2 2) (iota 4 2 0))
228
229
;;
230
;; Predicates
231
;;
232
233
;; proper-list?
234
(tn "proper-list? proper list")
235
(assert-eq? (tn) #t (proper-list? '()))
236
(assert-eq? (tn) #t (proper-list? '(1)))
237
(assert-eq? (tn) #t (proper-list? '(1 2)))
238
(assert-eq? (tn) #t (proper-list? '(1 2 3)))
239
(assert-eq? (tn) #t (proper-list? '(1 2 3 4)))
240
(tn "proper-list? dotted list")
241
(assert-eq? (tn) #f (proper-list? 1))
242
(assert-eq? (tn) #f (proper-list? '(1 . 2)))
243
(assert-eq? (tn) #f (proper-list? '(1 2 . 3)))
244
(assert-eq? (tn) #f (proper-list? '(1 2 3 . 4)))
245
(assert-eq? (tn) #f (proper-list? '(1 2 3 4 . 5)))
246
(tn "proper-list? circular list")
247
(assert-eq? (tn) #f (proper-list? clst1))
248
(assert-eq? (tn) #f (proper-list? clst2))
249
(assert-eq? (tn) #f (proper-list? clst3))
250
(assert-eq? (tn) #f (proper-list? clst4))
251
(tn "proper-list? all kind of Scheme objects")
252
(if (and sigscheme?
253
(provided? "siod-bugs"))
254
(assert-eq? (tn) #t (proper-list? #f))
255
(assert-eq? (tn) #f (proper-list? #f)))
256
(assert-eq? (tn) #f (proper-list? #t))
257
(assert-eq? (tn) #t (proper-list? '()))
258
(if sigscheme?
259
(begin
260
(assert-eq? (tn) #f (proper-list? (eof)))
261
(assert-eq? (tn) #f (proper-list? (undef)))))
262
(assert-eq? (tn) #f (proper-list? 0))
263
(assert-eq? (tn) #f (proper-list? 1))
264
(assert-eq? (tn) #f (proper-list? 3))
265
(assert-eq? (tn) #f (proper-list? -1))
266
(assert-eq? (tn) #f (proper-list? -3))
267
(assert-eq? (tn) #f (proper-list? 'symbol))
268
(assert-eq? (tn) #f (proper-list? 'SYMBOL))
269
(assert-eq? (tn) #f (proper-list? #\a))
270
(assert-eq? (tn) #f (proper-list? #\あ))
271
(assert-eq? (tn) #f (proper-list? ""))
272
(assert-eq? (tn) #f (proper-list? " "))
273
(assert-eq? (tn) #f (proper-list? "a"))
274
(assert-eq? (tn) #f (proper-list? "A"))
275
(assert-eq? (tn) #f (proper-list? "aBc12!"))
276
(assert-eq? (tn) #f (proper-list? "あ"))
277
(assert-eq? (tn) #f (proper-list? "あ0イう12!"))
278
(assert-eq? (tn) #f (proper-list? +))
279
(assert-eq? (tn) #f (proper-list? (lambda () #t)))
280
281
;; syntactic keywords should not be appeared as operand
282
(if sigscheme?
283
(begin
284
;; pure syntactic keyword
285
(assert-error (tn) (lambda () (proper-list? else)))
286
;; expression keyword
287
(assert-error (tn) (lambda () (proper-list? do)))))
288
289
(call-with-current-continuation
290
(lambda (k)
291
(assert-eq? (tn) #f (proper-list? k))))
292
(assert-eq? (tn) #f (proper-list? (current-output-port)))
293
(assert-eq? (tn) #f (proper-list? '(#t . #t)))
294
(assert-eq? (tn) #f (proper-list? (cons #t #t)))
295
(assert-eq? (tn) #t (proper-list? '(0 1 2)))
296
(assert-eq? (tn) #t (proper-list? (list 0 1 2)))
297
(assert-eq? (tn) #f (proper-list? '#()))
298
(assert-eq? (tn) #f (proper-list? (vector)))
299
(assert-eq? (tn) #f (proper-list? '#(0 1 2)))
300
(assert-eq? (tn) #f (proper-list? (vector 0 1 2)))
301
302
;; circular-list?
303
(tn "circular-list? proper list")
304
(assert-eq? (tn) #f (circular-list? '()))
305
(assert-eq? (tn) #f (circular-list? '(1)))
306
(assert-eq? (tn) #f (circular-list? '(1 2)))
307
(assert-eq? (tn) #f (circular-list? '(1 2 3)))
308
(assert-eq? (tn) #f (circular-list? '(1 2 3 4)))
309
(tn "circular-list? dotted list")
310
(assert-eq? (tn) #f (circular-list? 1))
311
(assert-eq? (tn) #f (circular-list? '(1 . 2)))
312
(assert-eq? (tn) #f (circular-list? '(1 2 . 3)))
313
(assert-eq? (tn) #f (circular-list? '(1 2 3 . 4)))
314
(assert-eq? (tn) #f (circular-list? '(1 2 3 4 . 5)))
315
(tn "circular-list? circular list")
316
(assert-eq? (tn) #t (circular-list? clst1))
317
(assert-eq? (tn) #t (circular-list? clst2))
318
(assert-eq? (tn) #t (circular-list? clst3))
319
(assert-eq? (tn) #t (circular-list? clst4))
320
(tn "circular-list? all kind of Scheme objects")
321
(if (and sigscheme?
322
(provided? "siod-bugs"))
323
(assert-eq? (tn) #f (circular-list? #f))
324
(assert-eq? (tn) #f (circular-list? #f)))
325
(assert-eq? (tn) #f (circular-list? #t))
326
(assert-eq? (tn) #f (circular-list? '()))
327
(if sigscheme?
328
(begin
329
(assert-eq? (tn) #f (circular-list? (eof)))
330
(assert-eq? (tn) #f (circular-list? (undef)))))
331
(assert-eq? (tn) #f (circular-list? 0))
332
(assert-eq? (tn) #f (circular-list? 1))
333
(assert-eq? (tn) #f (circular-list? 3))
334
(assert-eq? (tn) #f (circular-list? -1))
335
(assert-eq? (tn) #f (circular-list? -3))
336
(assert-eq? (tn) #f (circular-list? 'symbol))
337
(assert-eq? (tn) #f (circular-list? 'SYMBOL))
338
(assert-eq? (tn) #f (circular-list? #\a))
339
(assert-eq? (tn) #f (circular-list? #\あ))
340
(assert-eq? (tn) #f (circular-list? ""))
341
(assert-eq? (tn) #f (circular-list? " "))
342
(assert-eq? (tn) #f (circular-list? "a"))
343
(assert-eq? (tn) #f (circular-list? "A"))
344
(assert-eq? (tn) #f (circular-list? "aBc12!"))
345
(assert-eq? (tn) #f (circular-list? "あ"))
346
(assert-eq? (tn) #f (circular-list? "あ0イう12!"))
347
(assert-eq? (tn) #f (circular-list? +))
348
(assert-eq? (tn) #f (circular-list? (lambda () #t)))
349
350
;; syntactic keywords should not be appeared as operand
351
(if sigscheme?
352
(begin
353
;; pure syntactic keyword
354
(assert-error (tn) (lambda () (circular-list? else)))
355
;; expression keyword
356
(assert-error (tn) (lambda () (circular-list? do)))))
357
358
(call-with-current-continuation
359
(lambda (k)
360
(assert-eq? (tn) #f (circular-list? k))))
361
(assert-eq? (tn) #f (circular-list? (current-output-port)))
362
(assert-eq? (tn) #f (circular-list? '(#t . #t)))
363
(assert-eq? (tn) #f (circular-list? (cons #t #t)))
364
(assert-eq? (tn) #f (circular-list? '(0 1 2)))
365
(assert-eq? (tn) #f (circular-list? (list 0 1 2)))
366
(assert-eq? (tn) #f (circular-list? '#()))
367
(assert-eq? (tn) #f (circular-list? (vector)))
368
(assert-eq? (tn) #f (circular-list? '#(0 1 2)))
369
(assert-eq? (tn) #f (circular-list? (vector 0 1 2)))
370
371
;; dotted-list?
372
(tn "dotted-list? proper list")
373
(assert-eq? (tn) #f (dotted-list? '()))
374
(assert-eq? (tn) #f (dotted-list? '(1)))
375
(assert-eq? (tn) #f (dotted-list? '(1 2)))
376
(assert-eq? (tn) #f (dotted-list? '(1 2 3)))
377
(assert-eq? (tn) #f (dotted-list? '(1 2 3 4)))
378
(tn "dotted-list? dotted list")
379
(assert-eq? (tn) #t (dotted-list? 1))
380
(assert-eq? (tn) #t (dotted-list? '(1 . 2)))
381
(assert-eq? (tn) #t (dotted-list? '(1 2 . 3)))
382
(assert-eq? (tn) #t (dotted-list? '(1 2 3 . 4)))
383
(assert-eq? (tn) #t (dotted-list? '(1 2 3 4 . 5)))
384
(tn "dotted-list? circular list")
385
(assert-eq? (tn) #f (dotted-list? clst1))
386
(assert-eq? (tn) #f (dotted-list? clst2))
387
(assert-eq? (tn) #f (dotted-list? clst3))
388
(assert-eq? (tn) #f (dotted-list? clst4))
389
(tn "dotted-list? all kind of Scheme objects")
390
(if (and sigscheme?
391
(provided? "siod-bugs"))
392
(assert-eq? (tn) #f (dotted-list? #f))
393
(assert-eq? (tn) #t (dotted-list? #f)))
394
(assert-eq? (tn) #t (dotted-list? #t))
395
(assert-eq? (tn) #f (dotted-list? '()))
396
(if sigscheme?
397
(begin
398
(assert-eq? (tn) #t (dotted-list? (eof)))
399
(assert-eq? (tn) #t (dotted-list? (undef)))))
400
(assert-eq? (tn) #t (dotted-list? 0))
401
(assert-eq? (tn) #t (dotted-list? 1))
402
(assert-eq? (tn) #t (dotted-list? 3))
403
(assert-eq? (tn) #t (dotted-list? -1))
404
(assert-eq? (tn) #t (dotted-list? -3))
405
(assert-eq? (tn) #t (dotted-list? 'symbol))
406
(assert-eq? (tn) #t (dotted-list? 'SYMBOL))
407
(assert-eq? (tn) #t (dotted-list? #\a))
408
(assert-eq? (tn) #t (dotted-list? #\あ))
409
(assert-eq? (tn) #t (dotted-list? ""))
410
(assert-eq? (tn) #t (dotted-list? " "))
411
(assert-eq? (tn) #t (dotted-list? "a"))
412
(assert-eq? (tn) #t (dotted-list? "A"))
413
(assert-eq? (tn) #t (dotted-list? "aBc12!"))
414
(assert-eq? (tn) #t (dotted-list? "あ"))
415
(assert-eq? (tn) #t (dotted-list? "あ0イう12!"))
416
(assert-eq? (tn) #t (dotted-list? +))
417
(assert-eq? (tn) #t (dotted-list? (lambda () #t)))
418
419
;; syntactic keywords should not be appeared as operand
420
(if sigscheme?
421
(begin
422
;; pure syntactic keyword
423
(assert-error (tn) (lambda () (dotted-list? else)))
424
;; expression keyword
425
(assert-error (tn) (lambda () (dotted-list? do)))))
426
427
(call-with-current-continuation
428
(lambda (k)
429
(assert-eq? (tn) #t (dotted-list? k))))
430
(assert-eq? (tn) #t (dotted-list? (current-output-port)))
431
(assert-eq? (tn) #t (dotted-list? '(#t . #t)))
432
(assert-eq? (tn) #t (dotted-list? (cons #t #t)))
433
(assert-eq? (tn) #f (dotted-list? '(0 1 2)))
434
(assert-eq? (tn) #f (dotted-list? (list 0 1 2)))
435
(assert-eq? (tn) #t (dotted-list? '#()))
436
(assert-eq? (tn) #t (dotted-list? (vector)))
437
(assert-eq? (tn) #t (dotted-list? '#(0 1 2)))
438
(assert-eq? (tn) #t (dotted-list? (vector 0 1 2)))
439
440
;; null-list?
441
(tn "null-list? proper list")
442
(assert-eq? (tn) #t (null-list? '()))
443
(assert-eq? (tn) #f (null-list? '(1)))
444
(assert-eq? (tn) #f (null-list? '(1 2)))
445
(assert-eq? (tn) #f (null-list? '(1 2 3)))
446
(assert-eq? (tn) #f (null-list? '(1 2 3 4)))
447
;; SRFI-1: List is a proper or circular list. It is an error to pass this
448
;; procedure a value which is not a proper or circular list.
449
(tn "null-list? dotted list")
450
(if sigscheme?
451
(begin
452
;; SigScheme (SRFI-1 reference implementation) specific behavior
453
(assert-error (tn) (lambda () (null-list? 1)))
454
(assert-eq? (tn) #f (null-list? '(1 . 2)))
455
(assert-eq? (tn) #f (null-list? '(1 2 . 3)))
456
(assert-eq? (tn) #f (null-list? '(1 2 3 . 4)))
457
(assert-eq? (tn) #f (null-list? '(1 2 3 4 . 5)))))
458
(tn "null-list? circular list")
459
(assert-eq? (tn) #f (null-list? clst1))
460
(assert-eq? (tn) #f (null-list? clst2))
461
(assert-eq? (tn) #f (null-list? clst3))
462
(assert-eq? (tn) #f (null-list? clst4))
463
464
;; not-pair?
465
(tn "not-pair? proper list")
466
(assert-eq? (tn) #t (not-pair? '()))
467
(assert-eq? (tn) #f (not-pair? '(1)))
468
(assert-eq? (tn) #f (not-pair? '(1 2)))
469
(assert-eq? (tn) #f (not-pair? '(1 2 3)))
470
(assert-eq? (tn) #f (not-pair? '(1 2 3 4)))
471
(tn "not-pair? dotted list")
472
(assert-eq? (tn) #t (not-pair? 1))
473
(assert-eq? (tn) #f (not-pair? '(1 . 2)))
474
(assert-eq? (tn) #f (not-pair? '(1 2 . 3)))
475
(assert-eq? (tn) #f (not-pair? '(1 2 3 . 4)))
476
(assert-eq? (tn) #f (not-pair? '(1 2 3 4 . 5)))
477
(tn "not-pair? circular list")
478
(assert-eq? (tn) #f (not-pair? clst1))
479
(assert-eq? (tn) #f (not-pair? clst2))
480
(assert-eq? (tn) #f (not-pair? clst3))
481
(assert-eq? (tn) #f (not-pair? clst4))
482
(tn "not-pair? all kind of Scheme objects")
483
(assert-eq? (tn) #t (not-pair? #f))
484
(assert-eq? (tn) #t (not-pair? #t))
485
(assert-eq? (tn) #t (not-pair? '()))
486
(if sigscheme?
487
(begin
488
(assert-eq? (tn) #t (not-pair? (eof)))
489
(assert-eq? (tn) #t (not-pair? (undef)))))
490
(assert-eq? (tn) #t (not-pair? 0))
491
(assert-eq? (tn) #t (not-pair? 1))
492
(assert-eq? (tn) #t (not-pair? 3))
493
(assert-eq? (tn) #t (not-pair? -1))
494
(assert-eq? (tn) #t (not-pair? -3))
495
(assert-eq? (tn) #t (not-pair? 'symbol))
496
(assert-eq? (tn) #t (not-pair? 'SYMBOL))
497
(assert-eq? (tn) #t (not-pair? #\a))
498
(assert-eq? (tn) #t (not-pair? #\あ))
499
(assert-eq? (tn) #t (not-pair? ""))
500
(assert-eq? (tn) #t (not-pair? " "))
501
(assert-eq? (tn) #t (not-pair? "a"))
502
(assert-eq? (tn) #t (not-pair? "A"))
503
(assert-eq? (tn) #t (not-pair? "aBc12!"))
504
(assert-eq? (tn) #t (not-pair? "あ"))
505
(assert-eq? (tn) #t (not-pair? "あ0イう12!"))
506
(assert-eq? (tn) #t (not-pair? +))
507
(assert-eq? (tn) #t (not-pair? (lambda () #t)))
508
509
;; syntactic keywords should not be appeared as operand
510
(if sigscheme?
511
(begin
512
;; pure syntactic keyword
513
(assert-error (tn) (lambda () (not-pair? else)))
514
;; expression keyword
515
(assert-error (tn) (lambda () (not-pair? do)))))
516
517
(call-with-current-continuation
518
(lambda (k)
519
(assert-eq? (tn) #t (not-pair? k))))
520
(assert-eq? (tn) #t (not-pair? (current-output-port)))
521
(assert-eq? (tn) #f (not-pair? '(#t . #t)))
522
(assert-eq? (tn) #f (not-pair? (cons #t #t)))
523
(assert-eq? (tn) #f (not-pair? '(0 1 2)))
524
(assert-eq? (tn) #f (not-pair? (list 0 1 2)))
525
(assert-eq? (tn) #t (not-pair? '#()))
526
(assert-eq? (tn) #t (not-pair? (vector)))
527
(assert-eq? (tn) #t (not-pair? '#(0 1 2)))
528
(assert-eq? (tn) #t (not-pair? (vector 0 1 2)))
529
530
;; list=
531
(tn "list= SRFI-1 examples")
532
(assert-eq? (tn) #t (list= eq?))
533
(assert-eq? (tn) #t (list= eq? '(a)))
534
(tn "list= 1 list")
535
(assert-eq? (tn) #t (list= eq? '()))
536
(assert-eq? (tn) #t (list= equal? '()))
537
(assert-eq? (tn) #t (list= eq? lst))
538
(assert-eq? (tn) #t (list= equal? lst))
539
(assert-eq? (tn) #t (list= eq? (list elm0)))
540
(assert-eq? (tn) #t (list= equal? (list elm0)))
541
(assert-eq? (tn) #t (list= equal? '("a" "b" "c")))
542
(assert-eq? (tn) #t (list= equal? (list "a" "b" "c")))
543
(tn "list= 2 lists")
544
(assert-eq? (tn) #t (list= eq? '() '()))
545
(assert-eq? (tn) #t (list= equal? '() '()))
546
(assert-eq? (tn) #t (list= eq? lst lst))
547
(assert-eq? (tn) #t (list= equal? lst lst))
548
(assert-eq? (tn) #t (list= eq? (list elm0) (list elm0)))
549
(assert-eq? (tn) #t (list= equal? (list elm0) (list elm0)))
550
(assert-eq? (tn) #t (list= eq? (list elm0 elm1) (list elm0 elm1)))
551
(assert-eq? (tn) #t (list= equal? (list elm0 elm1) (list elm0 elm1)))
552
(assert-eq? (tn) #t (list= eq? (list elm0 elm1 elm2) (list elm0 elm1 elm2)))
553
(assert-eq? (tn) #t (list= equal? (list elm0 elm1 elm2) (list elm0 elm1 elm2)))
554
(assert-eq? (tn) #t (list= equal? '("a" "b" "c") '("a" "b" "c")))
555
(assert-eq? (tn) #t (list= equal? (list "a" "b" "c") (list "a" "b" "c")))
556
(tn "list= 2 lists unequal length")
557
(assert-eq? (tn) #f (list= eq? (list elm0 elm1) (list elm0 elm1 elm2)))
558
(assert-eq? (tn) #f (list= equal? (list elm0 elm1) (list elm0 elm1 elm2)))
559
(assert-eq? (tn) #f (list= eq? (list elm0 elm1 elm2) (list elm0 elm1)))
560
(assert-eq? (tn) #f (list= equal? (list elm0 elm1 elm2) (list elm0 elm1)))
561
(assert-eq? (tn) #f (list= eq? '() (list elm0 elm1 elm2)))
562
(assert-eq? (tn) #f (list= equal? '() (list elm0 elm1 elm2)))
563
(assert-eq? (tn) #f (list= eq? (list elm0 elm1 elm2) '()))
564
(assert-eq? (tn) #f (list= equal? (list elm0 elm1 elm2) '()))
565
(tn "list= 3 lists")
566
(assert-eq? (tn) #t (list= eq? '() '() '()))
567
(assert-eq? (tn) #t (list= equal? '() '() '()))
568
(assert-eq? (tn) #t (list= eq? lst lst lst))
569
(assert-eq? (tn) #t (list= equal? lst lst lst))
570
(assert-eq? (tn) #t (list= eq? (list elm0) (list elm0) (list elm0)))
571
(assert-eq? (tn) #t (list= equal? (list elm0) (list elm0) (list elm0)))
572
(assert-eq? (tn) #t (list= eq? (list elm0 elm1) (list elm0 elm1)
573
(list elm0 elm1)))
574
(assert-eq? (tn) #t (list= equal? (list elm0 elm1) (list elm0 elm1)
575
(list elm0 elm1)))
576
(assert-eq? (tn) #t (list= eq? (list elm0 elm1 elm2) (list elm0 elm1 elm2)
577
(list elm0 elm1 elm2)))
578
(assert-eq? (tn) #t (list= equal? (list elm0 elm1 elm2) (list elm0 elm1 elm2)
579
(list elm0 elm1 elm2)))
580
(assert-eq? (tn) #t (list= equal? '("a" "b" "c") '("a" "b" "c")
581
'("a" "b" "c")))
582
;; This test is failed on the original srfi-1-reference.scm
583
(assert-eq? (tn) #t (list= equal? (list "a" "b" "c") (list "a" "b" "c")
584
(list "a" "b" "c")))
585
(tn "list= 3 lists unequal length")
586
(assert-eq? (tn) #f (list= eq? (list elm0 elm1) (list elm0 elm1 elm2)
587
(list elm0 elm1 elm2)))
588
(assert-eq? (tn) #f (list= equal? (list elm0 elm1) (list elm0 elm1 elm2)
589
(list elm0 elm1 elm2)))
590
(assert-eq? (tn) #f (list= eq? (list elm0 elm1 elm2) (list elm0 elm1)
591
(list elm0 elm1 elm2)))
592
(assert-eq? (tn) #f (list= equal? (list elm0 elm1 elm2) (list elm0 elm1)
593
(list elm0 elm1 elm2)))
594
(assert-eq? (tn) #f (list= eq? (list elm0 elm1 elm2) (list elm0 elm1 elm2)
595
(list elm0 elm1)))
596
(assert-eq? (tn) #f (list= equal? (list elm0 elm1 elm2) (list elm0 elm1 elm2)
597
(list elm0 elm1)))
598
(assert-eq? (tn) #f (list= eq? '() (list elm0 elm1 elm2)
599
(list elm0 elm1 elm2)))
600
(assert-eq? (tn) #f (list= equal? '() (list elm0 elm1 elm2)
601
(list elm0 elm1 elm2)))
602
(assert-eq? (tn) #f (list= eq? (list elm0 elm1 elm2) '()
603
(list elm0 elm1 elm2)))
604
(assert-eq? (tn) #f (list= equal? (list elm0 elm1 elm2) '()
605
(list elm0 elm1 elm2)))
606
(assert-eq? (tn) #f (list= eq? (list elm0 elm1 elm2) (list elm0 elm1 elm2)
607
'()))
608
(assert-eq? (tn) #f (list= equal? (list elm0 elm1 elm2) (list elm0 elm1 elm2)
609
'()))
610
(tn "list= 4 lists")
611
(assert-eq? (tn) #t (list= eq? '() '() '() '()))
612
(assert-eq? (tn) #t (list= equal? '() '() '() '()))
613
(assert-eq? (tn) #t (list= eq? lst lst lst lst))
614
(assert-eq? (tn) #t (list= equal? lst lst lst lst))
615
(assert-eq? (tn) #t (list= eq? (list elm0) (list elm0)
616
(list elm0) (list elm0)))
617
(assert-eq? (tn) #t (list= equal? (list elm0) (list elm0)
618
(list elm0) (list elm0)))
619
(assert-eq? (tn) #t (list= eq? (list elm0 elm1) (list elm0 elm1)
620
(list elm0 elm1) (list elm0 elm1)))
621
(assert-eq? (tn) #t (list= equal? (list elm0 elm1) (list elm0 elm1)
622
(list elm0 elm1) (list elm0 elm1)))
623
(assert-eq? (tn) #t (list= eq? (list elm0 elm1 elm2) (list elm0 elm1 elm2)
624
(list elm0 elm1 elm2) (list elm0 elm1 elm2)))
625
(assert-eq? (tn) #t (list= equal? (list elm0 elm1 elm2) (list elm0 elm1 elm2)
626
(list elm0 elm1 elm2) (list elm0 elm1 elm2)))
627
(assert-eq? (tn) #t (list= equal? '("a" "b" "c") '("a" "b" "c")
628
'("a" "b" "c") '("a" "b" "c")))
629
;; This test is failed on the original srfi-1-reference.scm
630
(assert-eq? (tn) #t (list= equal? (list "a" "b" "c") (list "a" "b" "c")
631
(list "a" "b" "c") (list "a" "b" "c")))
632
(tn "list= 4 lists unequal length")
633
(assert-eq? (tn) #f (list= eq? (list elm0 elm1) (list elm0 elm1 elm2)
634
(list elm0 elm1 elm2) (list elm0 elm1 elm2)))
635
(assert-eq? (tn) #f (list= equal? (list elm0 elm1) (list elm0 elm1 elm2)
636
(list elm0 elm1 elm2) (list elm0 elm1 elm2)))
637
(assert-eq? (tn) #f (list= eq? (list elm0 elm1 elm2) (list elm0 elm1)
638
(list elm0 elm1 elm2) (list elm0 elm1 elm2)))
639
(assert-eq? (tn) #f (list= equal? (list elm0 elm1 elm2) (list elm0 elm1)
640
(list elm0 elm1 elm2) (list elm0 elm1 elm2)))
641
(assert-eq? (tn) #f (list= eq? (list elm0 elm1 elm2) (list elm0 elm1 elm2)
642
(list elm0 elm1) (list elm0 elm1 elm2)))
643
(assert-eq? (tn) #f (list= equal? (list elm0 elm1 elm2) (list elm0 elm1 elm2)
644
(list elm0 elm1) (list elm0 elm1 elm2)))
645
(assert-eq? (tn) #f (list= eq? '() (list elm0 elm1 elm2)
646
(list elm0 elm1 elm2) (list elm0 elm1 elm2)))
647
(assert-eq? (tn) #f (list= equal? '() (list elm0 elm1 elm2)
648
(list elm0 elm1 elm2) (list elm0 elm1 elm2)))
649
(assert-eq? (tn) #f (list= eq? (list elm0 elm1 elm2) '()
650
(list elm0 elm1 elm2) (list elm0 elm1 elm2)))
651
(assert-eq? (tn) #f (list= equal? (list elm0 elm1 elm2) '()
652
(list elm0 elm1 elm2) (list elm0 elm1 elm2)))
653
(assert-eq? (tn) #f (list= eq? (list elm0 elm1 elm2) (list elm0 elm1 elm2)
654
'() (list elm0 elm1 elm2)))
655
(assert-eq? (tn) #f (list= equal? (list elm0 elm1 elm2) (list elm0 elm1 elm2)
656
'() (list elm0 elm1 elm2)))
657
(assert-eq? (tn) #f (list= eq? (list elm0 elm1 elm2) (list elm0 elm1 elm2)
658
(list elm0 elm1 elm2) '()))
659
(assert-eq? (tn) #f (list= equal? (list elm0 elm1 elm2) (list elm0 elm1 elm2)
660
(list elm0 elm1 elm2) '()))
661
662
663
;;
664
;; Selectors
665
;;
666
667
(tn "first")
668
(assert-eq? (tn) elm0 (first lst))
669
(tn "second")
670
(assert-eq? (tn) elm1 (second lst))
671
(tn "third")
672
(assert-eq? (tn) elm2 (third lst))
673
(tn "fourth")
674
(assert-eq? (tn) elm3 (fourth lst))
675
(tn "fifth")
676
(assert-eq? (tn) elm4 (fifth lst))
677
(tn "sixth")
678
(assert-eq? (tn) elm5 (sixth lst))
679
(tn "seventh")
680
(assert-eq? (tn) elm6 (seventh lst))
681
(tn "eighth")
682
(assert-eq? (tn) elm7 (eighth lst))
683
(tn "ninth")
684
(assert-eq? (tn) elm8 (ninth lst))
685
(tn "tenth")
686
(assert-eq? (tn) elm9 (tenth lst))
687
688
(tn "car+cdr")
689
(assert-true (tn) (call-with-values
690
(lambda () (car+cdr (cons elm0 elm1)))
691
(lambda (kar kdr)
692
(and (eq? kar elm0)
693
(eq? kdr elm1)))))
694
695
;; take
696
;;
697
;; SRFI-1: take returns the first i elements of list x.
698
;; x may be any value -- a proper, circular, or dotted list.
699
(tn "take proper list invalid forms")
700
(assert-error (tn) (lambda () (take '() -1)))
701
(assert-error (tn) (lambda () (take '(1 2) -1)))
702
(tn "take proper list index 0")
703
(assert-equal? (tn) '() (take '() 0))
704
(assert-equal? (tn) '() (take '(1) 0))
705
(assert-equal? (tn) '() (take '(1 2) 0))
706
(assert-equal? (tn) '() (take '(1 2 3) 0))
707
(assert-equal? (tn) '() (take '(1 2 3 4) 0))
708
(assert-eq? (tn) '() (take lst 0))
709
(assert-eq? (tn) '() (take cdr9 0))
710
(tn "take proper list index 1")
711
(assert-error (tn) (lambda () (take '() 1)))
712
(assert-equal? (tn) '(1) (take '(1) 1))
713
(assert-equal? (tn) '(1) (take '(1 2) 1))
714
(assert-equal? (tn) '(1) (take '(1 2 3) 1))
715
(assert-equal? (tn) '(1) (take '(1 2 3 4) 1))
716
(assert-equal? (tn) (list elm0) (take lst 1))
717
(assert-equal? (tn) (list elm8) (take cdr8 1))
718
(assert-equal? (tn) (list elm9) (take cdr9 1))
719
(tn "take proper list index 2")
720
(assert-error (tn) (lambda () (take '() 2)))
721
(assert-error (tn) (lambda () (take '(1) 2)))
722
(assert-equal? (tn) '(1 2) (take '(1 2) 2))
723
(assert-equal? (tn) '(1 2) (take '(1 2 3) 2))
724
(assert-equal? (tn) '(1 2) (take '(1 2 3 4) 2))
725
(assert-equal? (tn) (list elm0 elm1) (take lst 2))
726
(assert-equal? (tn) (list elm7 elm8) (take cdr7 2))
727
(assert-equal? (tn) (list elm8 elm9) (take cdr8 2))
728
(assert-error (tn) (lambda () (take cdr9 2)))
729
(tn "take proper list index 3")
730
(assert-error (tn) (lambda () (take '() 3)))
731
(assert-error (tn) (lambda () (take '(1) 3)))
732
(assert-error (tn) (lambda () (take '(1 2) 3)))
733
(assert-equal? (tn) '(1 2 3) (take '(1 2 3) 3))
734
(assert-equal? (tn) '(1 2 3) (take '(1 2 3 4) 3))
735
(assert-equal? (tn) (list elm0 elm1 elm2) (take lst 3))
736
(assert-equal? (tn) (list elm6 elm7 elm8) (take cdr6 3))
737
(assert-equal? (tn) (list elm7 elm8 elm9) (take cdr7 3))
738
(assert-error (tn) (lambda () (take cdr8 3)))
739
(assert-error (tn) (lambda () (take cdr9 3)))
740
(tn "take proper list index 4")
741
(assert-error (tn) (lambda () (take '() 4)))
742
(assert-error (tn) (lambda () (take '(1) 4)))
743
(assert-error (tn) (lambda () (take '(1 2) 4)))
744
(assert-error (tn) (lambda () (take '(1 2 3) 4)))
745
(assert-equal? (tn) '(1 2 3 4) (take '(1 2 3 4) 4))
746
(assert-equal? (tn) (list elm0 elm1 elm2 elm3) (take lst 4))
747
(assert-equal? (tn) (list elm5 elm6 elm7 elm8) (take cdr5 4))
748
(assert-equal? (tn) (list elm6 elm7 elm8 elm9) (take cdr6 4))
749
(assert-error (tn) (lambda () (take cdr7 4)))
750
(assert-error (tn) (lambda () (take cdr8 4)))
751
(assert-error (tn) (lambda () (take cdr9 4)))
752
(tn "take proper list index 5")
753
(assert-error (tn) (lambda () (take '() 5)))
754
(assert-error (tn) (lambda () (take '(1) 5)))
755
(assert-error (tn) (lambda () (take '(1 2) 5)))
756
(assert-error (tn) (lambda () (take '(1 2 3) 5)))
757
(assert-error (tn) (lambda () (take '(1 2 3 4) 5)))
758
(assert-equal? (tn) (list elm0 elm1 elm2 elm3 elm4) (take lst 5))
759
(assert-equal? (tn) (list elm4 elm5 elm6 elm7 elm8) (take cdr4 5))
760
(assert-equal? (tn) (list elm5 elm6 elm7 elm8 elm9) (take cdr5 5))
761
(assert-error (tn) (lambda () (take cdr6 5)))
762
(assert-error (tn) (lambda () (take cdr7 5)))
763
(assert-error (tn) (lambda () (take cdr8 5)))
764
(assert-error (tn) (lambda () (take cdr9 5)))
765
(tn "take proper list other indices")
766
(assert-equal? (tn)
767
(list elm0 elm1 elm2 elm3 elm4 elm5)
768
(take lst 6))
769
(assert-equal? (tn)
770
(list elm0 elm1 elm2 elm3 elm4 elm5 elm6)
771
(take lst 7))
772
(assert-equal? (tn)
773
(list elm0 elm1 elm2 elm3 elm4 elm5 elm6 elm7)
774
(take lst 8))
775
(assert-equal? (tn)
776
(list elm0 elm1 elm2 elm3 elm4 elm5 elm6 elm7 elm8)
777
(take lst 9))
778
(assert-equal? (tn)
779
(list elm0 elm1 elm2 elm3 elm4 elm5 elm6 elm7 elm8 elm9)
780
(take lst 10))
781
(assert-error (tn) (lambda () (take lst 11)))
782
783
(tn "take dotted list invalid forms")
784
(assert-error (tn) (lambda () (take 1 -1)))
785
(assert-error (tn) (lambda () (take '(1 . 2) -1)))
786
(tn "take dotted list index 0")
787
(assert-equal? (tn) '() (take 1 0))
788
(assert-equal? (tn) '() (take '(1 . 2) 0))
789
(assert-equal? (tn) '() (take '(1 2 . 3) 0))
790
(assert-equal? (tn) '() (take '(1 2 3 . 4) 0))
791
(assert-equal? (tn) '() (take '(1 2 3 4 . 5) 0))
792
(tn "take dotted list index 1")
793
(assert-error (tn) (lambda () (take 1 1)))
794
(assert-equal? (tn) '(1) (take '(1 . 2) 1))
795
(assert-equal? (tn) '(1) (take '(1 2 . 3) 1))
796
(assert-equal? (tn) '(1) (take '(1 2 3 . 4) 1))
797
(assert-equal? (tn) '(1) (take '(1 2 3 4 . 5) 1))
798
(tn "take dotted list index 2")
799
(assert-error (tn) (lambda () (take 1 2)))
800
(assert-error (tn) (lambda () (take '(1 . 2) 2)))
801
(assert-equal? (tn) '(1 2) (take '(1 2 . 3) 2))
802
(assert-equal? (tn) '(1 2) (take '(1 2 3 . 4) 2))
803
(assert-equal? (tn) '(1 2) (take '(1 2 3 4 . 5) 2))
804
(tn "take dotted list index 3")
805
(assert-error (tn) (lambda () (take 1 3)))
806
(assert-error (tn) (lambda () (take '(1 . 2) 3)))
807
(assert-error (tn) (lambda () (take '(1 2 . 3) 3)))
808
(assert-equal? (tn) '(1 2 3) (take '(1 2 3 . 4) 3))
809
(assert-equal? (tn) '(1 2 3) (take '(1 2 3 4 . 5) 3))
810
(tn "take dotted list index 4")
811
(assert-error (tn) (lambda () (take 1 4)))
812
(assert-error (tn) (lambda () (take '(1 . 2) 4)))
813
(assert-error (tn) (lambda () (take '(1 2 . 3) 4)))
814
(assert-error (tn) (lambda () (take '(1 2 3 . 4) 4)))
815
(assert-equal? (tn) '(1 2 3 4) (take '(1 2 3 4 . 5) 4))
816
(tn "take dotted list index 5")
817
(assert-error (tn) (lambda () (take 1 5)))
818
(assert-error (tn) (lambda () (take '(1 . 2) 5)))
819
(assert-error (tn) (lambda () (take '(1 2 . 3) 5)))
820
(assert-error (tn) (lambda () (take '(1 2 3 . 4) 5)))
821
(assert-error (tn) (lambda () (take '(1 2 3 4 . 5) 5)))
822
823
(tn "take circular list invalid forms")
824
;; SigScheme's implementation does not detect negative index on circular list
825
;; since it is an user error. It goes an infinite loop.
826
;;(assert-error (tn) (lambda () (take clst1 -1)))
827
;;(assert-error (tn) (lambda () (take clst2 -1)))
828
(tn "take circular list index 0")
829
(assert-eq? (tn) '() (take clst1 0))
830
(assert-eq? (tn) '() (take clst2 0))
831
(assert-eq? (tn) '() (take clst3 0))
832
(assert-eq? (tn) '() (take clst4 0))
833
(tn "take circular list index 1")
834
(assert-equal? (tn) (list (list-ref clst1 0)) (take clst1 1))
835
(assert-equal? (tn) (list (list-ref clst2 0)) (take clst2 1))
836
(assert-equal? (tn) (list (list-ref clst3 0)) (take clst3 1))
837
(assert-equal? (tn) (list (list-ref clst4 0)) (take clst4 1))
838
(tn "take circular list index 2")
839
(assert-equal? (tn) (list (list-ref clst1 0)
840
(list-ref clst1 0)) (take clst1 2))
841
(assert-equal? (tn) (list (list-ref clst2 0)
842
(list-ref clst2 1)) (take clst2 2))
843
(assert-equal? (tn) (list (list-ref clst3 0)
844
(list-ref clst3 1)) (take clst3 2))
845
(assert-equal? (tn) (list (list-ref clst4 0)
846
(list-ref clst4 1)) (take clst4 2))
847
(tn "take circular list index 3")
848
(assert-equal? (tn) (list (list-ref clst1 0)
849
(list-ref clst1 0)
850
(list-ref clst1 0)) (take clst1 3))
851
(assert-equal? (tn) (list (list-ref clst2 0)
852
(list-ref clst2 1)
853
(list-ref clst2 0)) (take clst2 3))
854
(assert-equal? (tn) (list (list-ref clst3 0)
855
(list-ref clst3 1)
856
(list-ref clst3 2)) (take clst3 3))
857
(assert-equal? (tn) (list (list-ref clst4 0)
858
(list-ref clst4 1)
859
(list-ref clst4 2)) (take clst4 3))
860
(tn "take circular list index 4")
861
(assert-equal? (tn) (list (list-ref clst1 0)
862
(list-ref clst1 0)
863
(list-ref clst1 0)
864
(list-ref clst1 0)) (take clst1 4))
865
(assert-equal? (tn) (list (list-ref clst2 0)
866
(list-ref clst2 1)
867
(list-ref clst2 0)
868
(list-ref clst2 1)) (take clst2 4))
869
(assert-equal? (tn) (list (list-ref clst3 0)
870
(list-ref clst3 1)
871
(list-ref clst3 2)
872
(list-ref clst3 0)) (take clst3 4))
873
(assert-equal? (tn) (list (list-ref clst4 0)
874
(list-ref clst4 1)
875
(list-ref clst4 2)
876
(list-ref clst4 3)) (take clst4 4))
877
(tn "take circular list index 5")
878
(assert-equal? (tn) (list (list-ref clst1 0)
879
(list-ref clst1 0)
880
(list-ref clst1 0)
881
(list-ref clst1 0)
882
(list-ref clst1 0)) (take clst1 5))
883
(assert-equal? (tn) (list (list-ref clst2 0)
884
(list-ref clst2 1)
885
(list-ref clst2 0)
886
(list-ref clst2 1)
887
(list-ref clst2 0)) (take clst2 5))
888
(assert-equal? (tn) (list (list-ref clst3 0)
889
(list-ref clst3 1)
890
(list-ref clst3 2)
891
(list-ref clst3 0)
892
(list-ref clst3 1)) (take clst3 5))
893
(assert-equal? (tn) (list (list-ref clst4 0)
894
(list-ref clst4 1)
895
(list-ref clst4 2)
896
(list-ref clst4 3)
897
(list-ref clst4 0)) (take clst4 5))
898
(tn "take freshly-allocated entire list")
899
;; SRFI-1: If the argument is a list of non-zero length, take is guaranteed to
900
;; return a freshly-allocated list, even in the case where the entire list is
901
;; taken, e.g. (take lis (length lis)).
902
(assert-false (tn) (eq? lst (take lst (length lst))))
903
(assert-true (tn) (equal? lst (take lst (length lst))))
904
(define find-pair
905
(lambda (x lst)
906
(let rec ((rest lst))
907
(if (null? rest)
908
#f
909
(or (eq? x rest)
910
(rec (cdr rest)))))))
911
;; Check uniqueness for each pair in the new list.
912
(assert-true (tn) (let rec ((rest (take lst (length lst))))
913
(if (null? rest)
914
#t
915
(and (not (find-pair rest lst))
916
(rec (cdr rest))))))
917
(tn "take SRFI-1 examples")
918
(assert-equal? (tn) '(a b) (take '(a b c d e) 2))
919
(assert-equal? (tn) '(1 2) (take '(1 2 3 . d) 2))
920
(assert-equal? (tn) '(1 2 3) (take '(1 2 3 . d) 3))
921
922
;; drop
923
;;
924
;; SRFI-1: drop returns all but the first i elements of list x.
925
;; x may be any value -- a proper, circular, or dotted list.
926
(tn "drop proper list invalid forms")
927
(assert-error (tn) (lambda () (drop '() -1)))
928
(assert-error (tn) (lambda () (drop '(1 2) -1)))
929
(tn "drop proper list index 0")
930
(assert-equal? (tn) '() (drop '() 0))
931
(assert-equal? (tn) '(1) (drop '(1) 0))
932
(assert-equal? (tn) '(1 2) (drop '(1 2) 0))
933
(assert-equal? (tn) '(1 2 3) (drop '(1 2 3) 0))
934
(assert-equal? (tn) '(1 2 3 4) (drop '(1 2 3 4) 0))
935
(assert-eq? (tn) cdr0 (drop lst 0))
936
(assert-eq? (tn) cdr9 (drop cdr9 0))
937
(tn "drop proper list index 1")
938
(assert-error (tn) (lambda () (drop '() 1)))
939
(assert-equal? (tn) '() (drop '(1) 1))
940
(assert-equal? (tn) '(2) (drop '(1 2) 1))
941
(assert-equal? (tn) '(2 3) (drop '(1 2 3) 1))
942
(assert-equal? (tn) '(2 3 4) (drop '(1 2 3 4) 1))
943
(assert-eq? (tn) cdr1 (drop lst 1))
944
(assert-eq? (tn) cdr9 (drop cdr8 1))
945
(assert-eq? (tn) '() (drop cdr9 1))
946
(tn "drop proper list index 2")
947
(assert-error (tn) (lambda () (drop '() 2)))
948
(assert-error (tn) (lambda () (drop '(1) 2)))
949
(assert-equal? (tn) '() (drop '(1 2) 2))
950
(assert-equal? (tn) '(3) (drop '(1 2 3) 2))
951
(assert-equal? (tn) '(3 4) (drop '(1 2 3 4) 2))
952
(assert-eq? (tn) cdr2 (drop lst 2))
953
(assert-eq? (tn) cdr9 (drop cdr7 2))
954
(assert-eq? (tn) '() (drop cdr8 2))
955
(assert-error (tn) (lambda () (drop cdr9 2)))
956
(tn "drop proper list index 3")
957
(assert-error (tn) (lambda () (drop '() 3)))
958
(assert-error (tn) (lambda () (drop '(1) 3)))
959
(assert-error (tn) (lambda () (drop '(1 2) 3)))
960
(assert-equal? (tn) '() (drop '(1 2 3) 3))
961
(assert-equal? (tn) '(4) (drop '(1 2 3 4) 3))
962
(assert-eq? (tn) cdr3 (drop lst 3))
963
(assert-eq? (tn) cdr9 (drop cdr6 3))
964
(assert-eq? (tn) '() (drop cdr7 3))
965
(assert-error (tn) (lambda () (drop cdr8 3)))
966
(assert-error (tn) (lambda () (drop cdr9 3)))
967
(tn "drop proper list index 4")
968
(assert-error (tn) (lambda () (drop '() 4)))
969
(assert-error (tn) (lambda () (drop '(1) 4)))
970
(assert-error (tn) (lambda () (drop '(1 2) 4)))
971
(assert-error (tn) (lambda () (drop '(1 2 3) 4)))
972
(assert-equal? (tn) '() (drop '(1 2 3 4) 4))
973
(assert-eq? (tn) cdr4 (drop lst 4))
974
(assert-eq? (tn) cdr9 (drop cdr5 4))
975
(assert-eq? (tn) '() (drop cdr6 4))
976
(assert-error (tn) (lambda () (drop cdr7 4)))
977
(assert-error (tn) (lambda () (drop cdr8 4)))
978
(assert-error (tn) (lambda () (drop cdr9 4)))
979
(tn "drop proper list index 5")
980
(assert-error (tn) (lambda () (drop '() 5)))
981
(assert-error (tn) (lambda () (drop '(1) 5)))
982
(assert-error (tn) (lambda () (drop '(1 2) 5)))
983
(assert-error (tn) (lambda () (drop '(1 2 3) 5)))
984
(assert-error (tn) (lambda () (drop '(1 2 3 4) 5)))
985
(assert-eq? (tn) cdr5 (drop lst 5))
986
(assert-eq? (tn) cdr9 (drop cdr4 5))
987
(assert-eq? (tn) '() (drop cdr5 5))
988
(assert-error (tn) (lambda () (drop cdr6 5)))
989
(assert-error (tn) (lambda () (drop cdr7 5)))
990
(assert-error (tn) (lambda () (drop cdr8 5)))
991
(assert-error (tn) (lambda () (drop cdr9 5)))
992
(tn "drop proper list other indices")
993
(assert-eq? (tn) cdr6 (drop lst 6))
994
(assert-eq? (tn) cdr7 (drop lst 7))
995
(assert-eq? (tn) cdr8 (drop lst 8))
996
(assert-eq? (tn) cdr9 (drop lst 9))
997
(assert-eq? (tn) '() (drop lst 10))
998
(assert-error (tn) (lambda () (drop lst 11)))
999
1000
(tn "drop dotted list invalid forms")
1001
(assert-error (tn) (lambda () (drop 1 -1)))
1002
(assert-error (tn) (lambda () (drop '(1 . 2) -1)))
1003
(tn "drop dotted list index 0")
1004
(assert-equal? (tn) 1 (drop 1 0))
1005
(assert-equal? (tn) '(1 . 2) (drop '(1 . 2) 0))
1006
(assert-equal? (tn) '(1 2 . 3) (drop '(1 2 . 3) 0))
1007
(assert-equal? (tn) '(1 2 3 . 4) (drop '(1 2 3 . 4) 0))
1008
(assert-equal? (tn) '(1 2 3 4 . 5) (drop '(1 2 3 4 . 5) 0))
1009
(tn "drop dotted list index 1")
1010
(assert-error (tn) (lambda () (drop 1 1)))
1011
(assert-equal? (tn) 2 (drop '(1 . 2) 1))
1012
(assert-equal? (tn) '(2 . 3) (drop '(1 2 . 3) 1))
1013
(assert-equal? (tn) '(2 3 . 4) (drop '(1 2 3 . 4) 1))
1014
(assert-equal? (tn) '(2 3 4 . 5) (drop '(1 2 3 4 . 5) 1))
1015
(tn "drop dotted list index 2")
1016
(assert-error (tn) (lambda () (drop 1 2)))
1017
(assert-error (tn) (lambda () (drop '(1 . 2) 2)))
1018
(assert-equal? (tn) 3 (drop '(1 2 . 3) 2))
1019
(assert-equal? (tn) '(3 . 4) (drop '(1 2 3 . 4) 2))
1020
(assert-equal? (tn) '(3 4 . 5) (drop '(1 2 3 4 . 5) 2))
1021
(tn "drop dotted list index 3")
1022
(assert-error (tn) (lambda () (drop 1 3)))
1023
(assert-error (tn) (lambda () (drop '(1 . 2) 3)))
1024
(assert-error (tn) (lambda () (drop '(1 2 . 3) 3)))
1025
(assert-equal? (tn) 4 (drop '(1 2 3 . 4) 3))
1026
(assert-equal? (tn) '(4 . 5) (drop '(1 2 3 4 . 5) 3))
1027
(tn "drop dotted list index 4")
1028
(assert-error (tn) (lambda () (drop 1 4)))
1029
(assert-error (tn) (lambda () (drop '(1 . 2) 4)))
1030
(assert-error (tn) (lambda () (drop '(1 2 . 3) 4)))
1031
(assert-error (tn) (lambda () (drop '(1 2 3 . 4) 4)))
1032
(assert-equal? (tn) 5 (drop '(1 2 3 4 . 5) 4))
1033
(tn "drop dotted list index 5")
1034
(assert-error (tn) (lambda () (drop 1 5)))
1035
(assert-error (tn) (lambda () (drop '(1 . 2) 5)))
1036
(assert-error (tn) (lambda () (drop '(1 2 . 3) 5)))
1037
(assert-error (tn) (lambda () (drop '(1 2 3 . 4) 5)))
1038
(assert-error (tn) (lambda () (drop '(1 2 3 4 . 5) 5)))
1039
1040
(tn "drop circular list invalid forms")
1041
;; SigScheme's implementation does not detect negative index on circular list
1042
;; since it is an user error. It goes an infinite loop.
1043
;;(assert-error (tn) (lambda () (drop clst1 -1)))
1044
;;(assert-error (tn) (lambda () (drop clst2 -1)))
1045
(tn "drop circular list index 0")
1046
(assert-eq? (tn) clst1 (drop clst1 0))
1047
(assert-eq? (tn) clst2 (drop clst2 0))
1048
(assert-eq? (tn) clst3 (drop clst3 0))
1049
(assert-eq? (tn) clst4 (drop clst4 0))
1050
(tn "drop circular list index 1")
1051
(assert-eq? (tn) clst1 (drop clst1 1))
1052
(assert-eq? (tn) (my-list-tail clst2 1) (drop clst2 1))
1053
(assert-eq? (tn) (my-list-tail clst3 1) (drop clst3 1))
1054
(assert-eq? (tn) (my-list-tail clst4 1) (drop clst4 1))
1055
(tn "drop circular list index 2")
1056
(assert-eq? (tn) clst1 (drop clst1 2))
1057
(assert-eq? (tn) clst2 (drop clst2 2))
1058
(assert-eq? (tn) (my-list-tail clst3 2) (drop clst3 2))
1059
(assert-eq? (tn) (my-list-tail clst4 2) (drop clst4 2))
1060
(tn "drop circular list index 3")
1061
(assert-eq? (tn) clst1 (drop clst1 3))
1062
(assert-eq? (tn) (my-list-tail clst2 1) (drop clst2 3))
1063
(assert-eq? (tn) clst3 (drop clst3 3))
1064
(assert-eq? (tn) (my-list-tail clst4 3) (drop clst4 3))
1065
(tn "drop circular list index 4")
1066
(assert-eq? (tn) clst1 (drop clst1 4))
1067
(assert-eq? (tn) clst2 (drop clst2 4))
1068
(assert-eq? (tn) (my-list-tail clst3 1) (drop clst3 4))
1069
(assert-eq? (tn) clst4 (drop clst4 4))
1070
(tn "drop circular list index 5")
1071
(assert-eq? (tn) clst1 (drop clst1 5))
1072
(assert-eq? (tn) (my-list-tail clst2 1) (drop clst2 5))
1073
(assert-eq? (tn) (my-list-tail clst3 2) (drop clst3 5))
1074
(assert-eq? (tn) (my-list-tail clst4 1) (drop clst4 5))
1075
(tn "drop circular list index 6")
1076
(assert-eq? (tn) clst1 (drop clst1 6))
1077
(assert-eq? (tn) clst2 (drop clst2 6))
1078
(assert-eq? (tn) clst3 (drop clst3 6))
1079
(assert-eq? (tn) (my-list-tail clst4 2) (drop clst4 6))
1080
1081
(tn "drop SRFI-1 examples")
1082
(assert-equal? (tn) '(c d e) (drop '(a b c d e) 2))
1083
(assert-equal? (tn) '(3 . d) (drop '(1 2 3 . d) 2))
1084
(assert-equal? (tn) 'd (drop '(1 2 3 . d) 3))
1085
1086
;; take-right
1087
;; drop-right
1088
;; take!
1089
;; drop-right!
1090
;; split-at
1091
;; split-at!
1092
1093
;; last
1094
;;
1095
;; SRFI-1: last returns the last element of the non-empty, finite list pair.
1096
(tn "last invalid forms")
1097
(assert-error (tn) (lambda () (last '())))
1098
(assert-error (tn) (lambda () (last 1)))
1099
(tn "last")
1100
(assert-eq? (tn) elm9 (last lst))
1101
(assert-eq? (tn) elm9 (last cdr7))
1102
(assert-eq? (tn) elm9 (last cdr8))
1103
(assert-eq? (tn) elm9 (last cdr9))
1104
(assert-equal? (tn) 1 (last '(1 . 2)))
1105
(assert-equal? (tn) 2 (last '(1 2 . 3)))
1106
(assert-equal? (tn) 3 (last '(1 2 3 . 4)))
1107
1108
;; last-pair
1109
;;
1110
;; SRFI-1: last-pair returns the last pair in the non-empty, finite list pair.
1111
(tn "last-pair invalid forms")
1112
(assert-error (tn) (lambda () (last-pair '())))
1113
(assert-error (tn) (lambda () (last-pair 1)))
1114
(tn "last-pair")
1115
(assert-eq? (tn) cdr9 (last-pair lst))
1116
(assert-eq? (tn) cdr9 (last-pair cdr7))
1117
(assert-eq? (tn) cdr9 (last-pair cdr8))
1118
(assert-eq? (tn) cdr9 (last-pair cdr9))
1119
(assert-equal? (tn) '(1 . 2) (last-pair '(1 . 2)))
1120
(assert-equal? (tn) '(2 . 3) (last-pair '(1 2 . 3)))
1121
(assert-equal? (tn) '(3 . 4) (last-pair '(1 2 3 . 4)))
1122
1123
1124
;;
1125
;; Miscellaneous: length, append, concatenate, reverse, zip & count
1126
;;
1127
1128
;; length+
1129
(tn "length+ proper list")
1130
(assert-equal? (tn) 0 (length+ '()))
1131
(assert-equal? (tn) 1 (length+ '(1)))
1132
(assert-equal? (tn) 2 (length+ '(1 2)))
1133
(assert-equal? (tn) 3 (length+ '(1 2 3)))
1134
(assert-equal? (tn) 4 (length+ '(1 2 3 4)))
1135
(tn "length+ dotted list")
1136
;; Although the behavior on dotted list is not defined in SRFI-1 itself, the
1137
;; reference implementation returns its length. So SigScheme followed it.
1138
(if sigscheme?
1139
(begin
1140
(assert-equal? (tn) 0 (length+ 1))
1141
(assert-equal? (tn) 1 (length+ '(1 . 2)))
1142
(assert-equal? (tn) 2 (length+ '(1 2 . 3)))
1143
(assert-equal? (tn) 3 (length+ '(1 2 3 . 4)))
1144
(assert-equal? (tn) 4 (length+ '(1 2 3 4 . 5)))))
1145
(tn "length+ circular list")
1146
(assert-eq? (tn) #f (length+ clst1))
1147
(assert-eq? (tn) #f (length+ clst2))
1148
(assert-eq? (tn) #f (length+ clst3))
1149
(assert-eq? (tn) #f (length+ clst4))
1150
1151
;; append!
1152
(tn "append!")
1153
(assert-equal? (tn) '() (append!))
1154
(assert-equal? (tn) '() (append! '()))
1155
(assert-equal? (tn) '() (append! '() '()))
1156
(assert-equal? (tn) '() (append! '() '() '()))
1157
(assert-equal? (tn) '(a) (append! (list 'a) '() '()))
1158
(assert-equal? (tn) '(a) (append! '() (list 'a) '()))
1159
(assert-equal? (tn) '(a) (append! '() '() '(a)))
1160
(assert-equal? (tn) 'a (append! 'a))
1161
(assert-equal? (tn) '(a . b) (append! '(a . b)))
1162
(assert-equal? (tn) '(a . b) (append! '() '() '(a . b)))
1163
(assert-equal? (tn) '(1 2 3 a . b) (append! (list 1) (list 2 3) '(a . b)))
1164
(assert-equal? (tn) 7 (append! (+ 3 4)))
1165
(assert-equal? (tn) '(+ 3 4) (append! '(+ 3 4)))
1166
(assert-equal? (tn) '(a b) (append! '(a b)))
1167
(assert-equal? (tn) '(c d e a b) (append! (list 'c) (list 'd 'e) '(a b)))
1168
;; The reference implementation does not cause error on non-tail dotted list.
1169
;;(assert-error (tn) (lambda () (append! 'a 'b)))
1170
;;(assert-error (tn) (lambda () (append! 'a '(b))))
1171
;;(assert-error (tn) (lambda () (append! 'a '())))
1172
;;(assert-error (tn) (lambda () (append! (cons 'a 'b) '())))
1173
;;(assert-error (tn) (lambda () (append! '() (cons 'a 'b) '())))
1174
(tn "append! shared tail")
1175
;; SRFI-1: The last argument is never altered; the result list shares structure
1176
;; with this parameter.
1177
(assert-equal? (tn)
1178
(list 1 2 3 elm8 elm9)
1179
(append! (list 1) (list 2 3) cdr8))
1180
(assert-eq? (tn)
1181
cdr8
1182
(my-list-tail (append! (list 1) (list 2 3) cdr8) 3))
1183
1184
;; concatenate
1185
(tn "concatenate invalid forms")
1186
(assert-error (tn) (lambda () (concatenate)))
1187
(assert-error (tn) (lambda () (concatenate #t)))
1188
(tn "concatenate")
1189
(assert-equal? (tn) '() (concatenate '()))
1190
(assert-equal? (tn) '() (concatenate '(())))
1191
(assert-equal? (tn) '() (concatenate '(() ())))
1192
(assert-equal? (tn) '() (concatenate '(() () ())))
1193
(assert-equal? (tn) '(a) (concatenate '((a) () ())))
1194
(assert-equal? (tn) '(a) (concatenate '(() (a) ())))
1195
(assert-equal? (tn) '(a) (concatenate '(() () (a))))
1196
(assert-equal? (tn) 'a (concatenate '(a)))
1197
(assert-equal? (tn) '(a . b) (concatenate '((a . b))))
1198
(assert-equal? (tn) '(a . b) (concatenate '(() () (a . b))))
1199
(assert-equal? (tn) '(1 2 3 a . b) (concatenate '((1) (2 3) (a . b))))
1200
(assert-equal? (tn) 7 (concatenate (list (+ 3 4))))
1201
(assert-equal? (tn) '(+ 3 4) (concatenate '((+ 3 4))))
1202
(assert-equal? (tn) '(a b) (concatenate '((a b))))
1203
(assert-equal? (tn) '(c d e a b) (concatenate '((c) (d e) (a b))))
1204
1205
;; concatenate!
1206
(tn "concatenate! invalid forms")
1207
(assert-error (tn) (lambda () (concatenate!)))
1208
(assert-error (tn) (lambda () (concatenate! #t)))
1209
(tn "concatenate!")
1210
(assert-equal? (tn) '() (concatenate! '()))
1211
(assert-equal? (tn) '() (concatenate! (list '())))
1212
(assert-equal? (tn) '() (concatenate! (list '() '())))
1213
(assert-equal? (tn) '() (concatenate! (list '() '() '())))
1214
(assert-equal? (tn) '(a) (concatenate! (list (list 'a) '() '())))
1215
(assert-equal? (tn) '(a) (concatenate! (list '() (list 'a) '())))
1216
(assert-equal? (tn) '(a) (concatenate! (list '() '() '(a))))
1217
(assert-equal? (tn) 'a (concatenate! '(a)))
1218
(assert-equal? (tn) '(a . b) (concatenate! '((a . b))))
1219
(assert-equal? (tn) '(a . b) (concatenate! (list '() '() '(a . b))))
1220
(assert-equal? (tn) '(1 2 3 a . b) (concatenate! (list (list 1) (list 2 3) '(a . b))))
1221
(assert-equal? (tn) 7 (concatenate! (list (+ 3 4))))
1222
(assert-equal? (tn) '(+ 3 4) (concatenate! '((+ 3 4))))
1223
(assert-equal? (tn) '(a b) (concatenate! '((a b))))
1224
(assert-equal? (tn) '(c d e a b) (concatenate! (list (list 'c) (list 'd 'e) '(a b))))
1225
1226
;; reverse!
1227
1228
;;append-reverse
1229
(tn "append-reverse invalid forms")
1230
(assert-error (tn) (lambda () (append-reverse #t '())))
1231
(tn "append-reverse")
1232
(assert-equal? (tn) '() (append-reverse '() '()))
1233
(assert-equal? (tn) '(3 2 1) (append-reverse '(1 2 3) '()))
1234
(assert-equal? (tn) '(3 2 1 4 5 6) (append-reverse '(1 2 3) '(4 5 6)))
1235
(assert-equal? (tn) '(4 5 6) (append-reverse '() '(4 5 6)))
1236
(assert-equal? (tn) '(3 2 1 . #t) (append-reverse '(1 2 3) #t))
1237
(assert-equal? (tn) #t (append-reverse '() #t))
1238
1239
;; append-reverse!
1240
;;
1241
;; SRFI-1: it is allowed, but not required, to alter rev-head's cons cells to
1242
;; construct the result.
1243
(tn "append-reverse! invalid forms")
1244
(assert-error (tn) (lambda () (append-reverse! #t '())))
1245
(tn "append-reverse!")
1246
(assert-equal? (tn) '() (append-reverse! '() '()))
1247
(assert-equal? (tn) '(3 2 1) (append-reverse! (list 1 2 3) '()))
1248
(assert-equal? (tn) '(3 2 1 4 5 6) (append-reverse! (list 1 2 3) '(4 5 6)))
1249
(assert-equal? (tn) '(4 5 6) (append-reverse! '() '(4 5 6)))
1250
(assert-equal? (tn) '(3 2 1 . #t) (append-reverse! (list 1 2 3) #t))
1251
(assert-equal? (tn) #t (append-reverse! '() #t))
1252
1253
;; zip
1254
(tn "zip invalid forms")
1255
(assert-error (tn) (lambda () (zip)))
1256
(tn "zip single list")
1257
(assert-equal? (tn) '() (zip '()))
1258
(assert-equal? (tn) '((1)) (zip '(1)))
1259
(assert-equal? (tn) '((1) (2)) (zip '(1 2)))
1260
(assert-equal? (tn) '((1) (2) (3)) (zip '(1 2 3)))
1261
(tn "zip 3 lists")
1262
(assert-equal? (tn) '() (zip '() '() '()))
1263
(assert-equal? (tn) '((1 4 7)) (zip '(1) '(4) '(7)))
1264
(assert-equal? (tn) '((1 4 7) (2 5 8)) (zip '(1 2) '(4 5) '(7 8)))
1265
(assert-equal? (tn) '((1 4 7) (2 5 8) (3 6 9)) (zip '(1 2 3) '(4 5 6) '(7 8 9)))
1266
(tn "zip 3 lists unequal length")
1267
(assert-equal? (tn) '() (zip '() '(4) '(7)))
1268
(assert-equal? (tn) '() (zip '(1) '() '(7)))
1269
(assert-equal? (tn) '() (zip '(1) '(4) '()))
1270
(assert-equal? (tn) '((1 4 7)) (zip '(1) '(4 5) '(7 8)))
1271
(assert-equal? (tn) '((1 4 7)) (zip '(1 2) '(4) '(7 8)))
1272
(assert-equal? (tn) '((1 4 7)) (zip '(1 2) '(4 5) '(7)))
1273
(assert-equal? (tn) '((1 4 7) (2 5 8)) (zip '(1 2) '(4 5 6) '(7 8 9)))
1274
(assert-equal? (tn) '((1 4 7) (2 5 8)) (zip '(1 2 3) '(4 5) '(7 8 9)))
1275
(assert-equal? (tn) '((1 4 7) (2 5 8)) (zip '(1 2 3) '(4 5 6) '(7 8)))
1276
(tn "zip SRFI-1 examples")
1277
(assert-equal? (tn)
1278
'((one 1 odd) (two 2 even) (three 3 odd))
1279
(zip '(one two three)
1280
'(1 2 3)
1281
'(odd even odd even odd even odd even)))
1282
(assert-equal? (tn)
1283
'((1) (2) (3))
1284
(zip '(1 2 3)))
1285
;; SRFI-1: At least one of the argument lists must be finite.
1286
(assert-equal? (tn)
1287
'((3 #f) (1 #t) (4 #f) (1 #t))
1288
(zip '(3 1 4 1) (circular-list #f #t)))
1289
1290
;; unzip1
1291
;; unzip2
1292
;; unzip3
1293
;; unzip4
1294
;; unzip5
1295
;; count
1296
1297
;;
1298
;; Fold, unfold & map
1299
;;
1300
1301
;; fold
1302
(tn "fold invalid forms")
1303
(assert-error (tn) (lambda () (fold cons)))
1304
(assert-error (tn) (lambda () (fold cons '())))
1305
(assert-error (tn) (lambda () (fold cons '#())))
1306
(assert-error (tn) (lambda () (fold cons '(1) '#(2))))
1307
(assert-error (tn) (lambda () (fold #\a '())))
1308
(tn "fold single list")
1309
(assert-equal? (tn) '() (fold cons '() '()))
1310
(assert-equal? (tn) '(1) (fold cons '() '(1)))
1311
(assert-equal? (tn) '(2 1) (fold cons '() '(1 2)))
1312
(assert-equal? (tn) '(3 2 1) (fold cons '() '(1 2 3)))
1313
(tn "fold 3 lists")
1314
(assert-equal? (tn)
1315
"cCzbByaAxNIL"
1316
(fold string-append
1317
"NIL"
1318
'("a" "b" "c") '("A" "B" "C") '("x" "y" "z")))
1319
;; unequal length
1320
(assert-equal? (tn)
1321
"bByaAxNIL"
1322
(fold string-append
1323
"NIL"
1324
'("a" "b" "c") '("A" "B") '("x" "y" "z")))
1325
(assert-equal? (tn)
1326
"NIL"
1327
(fold string-append
1328
"NIL"
1329
'("a" "b" "c") '() '("x" "y" "z")))
1330
(tn "fold SRFI-1 examples")
1331
;; Add up the elements of list.
1332
(assert-equal? (tn) 15 (fold + 0 '(1 2 3 4 5)))
1333
;; Reverse LST.
1334
(assert-equal? (tn)
1335
(list elm9 elm8 elm7 elm6 elm5 elm4 elm3 elm2 elm1 elm0)
1336
(fold cons '() lst))
1337
;; See APPEND-REVERSE.
1338
(assert-equal? (tn)
1339
'(10 9 8 1 2 3)
1340
(let ((tail '(1 2 3))
1341
(rev-head '(8 9 10)))
1342
(fold cons tail rev-head)))
1343
;; How many symbols in list?
1344
(assert-equal? (tn)
1345
0
1346
(fold (lambda (x count) (if (symbol? x) (+ count 1) count))
1347
0
1348
lst))
1349
(assert-equal? (tn)
1350
3
1351
(fold (lambda (x count) (if (symbol? x) (+ count 1) count))
1352
0
1353
'(0 #\a a "a" b (0) c)))
1354
;; Length of the longest string in list:
1355
(assert-equal? (tn)
1356
17
1357
(fold (lambda (s max-len) (max max-len (string-length s)))
1358
0
1359
'("" "string-append" "str" "SigScheme Project" "SRFI-1")))
1360
;; unequal length lists
1361
(assert-equal? (tn)
1362
'(c 3 b 2 a 1)
1363
(fold cons* '() '(a b c) '(1 2 3 4 5)))
1364
1365
;; fold-right
1366
;; pair-fold
1367
;; pair-fold-right
1368
1369
;; reduce
1370
(tn "reduce invalid forms")
1371
(assert-error (tn) (lambda () (reduce cons)))
1372
(assert-error (tn) (lambda () (reduce cons '())))
1373
(assert-error (tn) (lambda () (reduce cons '#())))
1374
(assert-error (tn) (lambda () (reduce cons '() '#(2))))
1375
(assert-error (tn) (lambda () (reduce #\a '())))
1376
(tn "reduce")
1377
(assert-equal? (tn) 0 (reduce + 0 '()))
1378
(assert-equal? (tn) 1 (reduce + 0 '(1)))
1379
(assert-equal? (tn) 3 (reduce + 0 '(1 2)))
1380
(assert-equal? (tn) 6 (reduce + 0 '(1 2 3)))
1381
(assert-equal? (tn) "" (reduce string-append "" '()))
1382
(assert-equal? (tn) "a" (reduce string-append "" '("a")))
1383
(assert-equal? (tn) "ba" (reduce string-append "" '("a" "b")))
1384
(assert-equal? (tn) "cba" (reduce string-append "" '("a" "b" "c")))
1385
(assert-equal? (tn) '() (reduce cons '() '()))
1386
(assert-equal? (tn) '(1) (reduce cons '() '(() 1)))
1387
(assert-equal? (tn) '(2 1) (reduce cons '() '(() 1 2)))
1388
(assert-equal? (tn) '(3 2 1) (reduce cons '() '(() 1 2 3)))
1389
(tn "reduce SRFI-1 examples")
1390
;; Take the max of a list of non-negative integers.
1391
(assert-equal? (tn) 43 (reduce max 0 '(0 7 8 8 43 -4)))
1392
1393
;; reduce-right
1394
1395
;; unfold
1396
(tn "unfold invalid forms")
1397
(assert-error (tn) (lambda () (unfold #\c car cdr '(1 2 3))))
1398
(assert-error (tn) (lambda () (unfold cons #\a cdr '(1 2 3))))
1399
(assert-error (tn) (lambda () (unfold cons car #\d '(1 2 3))))
1400
(assert-error (tn) (lambda () (unfold cons car cdr '#(1 2 3))))
1401
(assert-error (tn) (lambda () (unfold cons car cdr '(1 2 3) '())))
1402
(assert-error (tn) (lambda () (unfold cons car cdr '(1 2 3) values '())))
1403
(tn "unfold")
1404
(assert-equal? (tn) '() (unfold null? car cdr '()))
1405
(assert-error (tn) (lambda () (unfold null? car cdr 1)))
1406
(assert-equal? (tn) '() (unfold not-pair? car cdr 1))
1407
(assert-equal? (tn) 1 (unfold not-pair? car cdr 1 values))
1408
(assert-equal? (tn) '(1 2 3 4) (unfold null? car cdr '(1 2 3 4)))
1409
(assert-error (tn) (lambda () (unfold null? car cdr '(1 2 3 4 . 5))))
1410
(assert-equal? (tn) '(1 2 3 4) (unfold not-pair? car cdr '(1 2 3 4 . 5)))
1411
(assert-equal? (tn) '(1 2 3 4 . 5) (unfold not-pair? car cdr '(1 2 3 4 . 5) values))
1412
(tn "unfold SRFI-1 examples")
1413
;; List of squares: 1^2 ... 10^2
1414
(assert-equal? (tn)
1415
'(1 4 9 16 25 36 49 64 81 100)
1416
(unfold (lambda (x) (> x 10))
1417
(lambda (x) (* x x))
1418
(lambda (x) (+ x 1))
1419
1))
1420
;; Copy a proper list.
1421
(assert-true (tn) (equal? lst (unfold null-list? car cdr lst)))
1422
(assert-false (tn) (eq? lst (unfold null-list? car cdr lst)))
1423
;; Read current input port into a list of values.
1424
(assert-equal? (tn)
1425
'((equal? lst (unfold null-list? car cdr lst)))
1426
(let ((p (open-input-string
1427
"(equal? lst (unfold null-list? car cdr lst))")))
1428
(unfold eof-object? values (lambda (x) (read p)) (read p))))
1429
;; Copy a possibly non-proper list:
1430
(assert-true (tn) (equal? lst (unfold not-pair? car cdr lst values)))
1431
(assert-false (tn) (eq? lst (unfold not-pair? car cdr lst values)))
1432
(let ((dlst (cons elm0 (cons elm1 (cons elm2 elm3)))))
1433
(assert-true (tn) (equal? dlst (unfold not-pair? car cdr dlst values)))
1434
(assert-false (tn) (eq? dlst (unfold not-pair? car cdr dlst values))))
1435
;; Append HEAD onto TAIL:
1436
(assert-equal? (tn)
1437
'(1 2 3 4 5 6)
1438
(let ((head '(1 2 3))
1439
(tail '(4 5 6)))
1440
(unfold null-list? car cdr head
1441
(lambda (x) tail))))
1442
1443
;; unfold-right
1444
1445
;; map
1446
(tn "map invalid forms")
1447
(assert-error (tn) (lambda () (map +)))
1448
(assert-error (tn) (lambda () (map + '#())))
1449
(assert-error (tn) (lambda () (map + '(1) '#(2))))
1450
(assert-error (tn) (lambda () (map #\a '(1))))
1451
(tn "map single list")
1452
(assert-equal? (tn) '() (map + '()))
1453
(assert-equal? (tn) '() (map even? '()))
1454
(assert-equal? (tn) '(2 4 6 8) (map + '(2 4 6 8)))
1455
(assert-equal? (tn) '(#t #t #t #t) (map even? '(2 4 6 8)))
1456
(assert-equal? (tn) '(#f #t #t #t #t) (map even? '(3 2 4 6 8)))
1457
(assert-equal? (tn) '(#t #t #f #t #t) (map even? '(2 4 3 6 8)))
1458
(assert-equal? (tn) '(#t #t #t #t #f) (map even? '(2 4 6 8 3)))
1459
(tn "map 3 lists")
1460
(assert-equal? (tn) '() (map + '() '() '()))
1461
(assert-equal? (tn) '(12 17 22 27) (map +
1462
'(2 4 6 8)
1463
'(1 3 5 7)
1464
'(9 10 11 12)))
1465
(assert-equal? (tn) '(12 #f 22 #f) (map (lambda args
1466
(let ((sum (apply + args)))
1467
(and (even? sum)
1468
sum)))
1469
'(2 4 6 8)
1470
'(1 3 5 7)
1471
'(9 10 11 12)))
1472
(assert-equal? (tn) '(12 18 22 28) (map (lambda args
1473
(let ((sum (apply + args)))
1474
(and (even? sum)
1475
sum)))
1476
'(2 4 6 8)
1477
'(1 4 5 8)
1478
'(9 10 11 12)))
1479
(tn "map 3 lists unequal length")
1480
(assert-equal? (tn) '(12 17 22) (map +
1481
'(2 4 6)
1482
'(1 3 5 7)
1483
'(9 10 11 12)))
1484
(assert-equal? (tn) '(12 17 22) (map +
1485
'(2 4 6 8)
1486
'(1 3 5)
1487
'(9 10 11 12)))
1488
(assert-equal? (tn) '(12 17 22) (map +
1489
'(2 4 6 8)
1490
'(1 3 5 7)
1491
'(9 10 11)))
1492
(assert-equal? (tn) '() (map +
1493
'()
1494
'(1 3 5 7)
1495
'(9 10 11 12)))
1496
(assert-equal? (tn) '() (map +
1497
'(2 4 6 8)
1498
'()
1499
'(9 10 11 12)))
1500
(assert-equal? (tn) '() (map +
1501
'(2 4 6 8)
1502
'(1 3 5 7)
1503
'()))
1504
(tn "map 3 lists with circular list")
1505
(assert-equal? (tn) '(11 15 17 21) (map +
1506
clst2
1507
'(1 3 5 7)
1508
'(9 10 11 12)))
1509
(assert-equal? (tn) '(11 15 17 21) (map +
1510
'(1 3 5 7)
1511
clst2
1512
'(9 10 11 12)))
1513
(assert-equal? (tn) '(11 15 17 21) (map +
1514
'(1 3 5 7)
1515
'(9 10 11 12)
1516
clst2))
1517
(tn "map SRFI-1 examples")
1518
(assert-equal? (tn)
1519
'(b e h)
1520
(map cadr '((a b) (d e) (g h))))
1521
(define expt
1522
(lambda (x y)
1523
(apply * (make-list y x))))
1524
(assert-equal? (tn)
1525
'(1 4 27 256 3125)
1526
(map (lambda (n) (expt n n))
1527
'(1 2 3 4 5)))
1528
(assert-equal? (tn)
1529
'(5 7 9)
1530
(map + '(1 2 3) '(4 5 6)))
1531
(assert-true (tn)
1532
(let ((result (let ((count 0))
1533
(map (lambda (ignored)
1534
(set! count (+ count 1))
1535
count)
1536
'(a b)))))
1537
(or (equal? result '(1 2))
1538
(equal? result '(2 1)))))
1539
(assert-equal? (tn)
1540
'(4 1 5 1)
1541
(map + '(3 1 4 1) (circular-list 1 0)))
1542
1543
;; for-each
1544
1545
;; append-map
1546
(tn "append-map invalid forms")
1547
(assert-error (tn) (lambda () (append-map values)))
1548
(assert-error (tn) (lambda () (append-map #\a '())))
1549
(assert-error (tn) (lambda () (append-map values '#())))
1550
(assert-error (tn) (lambda () (append-map list '(1) '#(2))))
1551
(tn "append-map single list")
1552
(assert-equal? (tn)
1553
'()
1554
(append-map values '()))
1555
(assert-equal? (tn)
1556
'(1 2 3 4 5 6 7)
1557
(append-map values '((1) (2 3) (4) (5 6 7))))
1558
(assert-equal? (tn)
1559
'(1 3 2 4 7 6 5)
1560
(append-map reverse '((1) (2 3) (4) (5 6 7))))
1561
(tn "append-map 3 lists")
1562
(assert-equal? (tn)
1563
'()
1564
(append-map list '() '() '()))
1565
(assert-equal? (tn)
1566
'(1 4 7 2 5 8 3 6 9)
1567
(append-map list '(1 2 3) '(4 5 6) '(7 8 9)))
1568
(tn "append-map 3 lists unequal length")
1569
(assert-equal? (tn)
1570
'(1 4 7 2 5 8)
1571
(append-map list '(1 2) '(4 5 6) '(7 8 9)))
1572
(assert-equal? (tn)
1573
'(1 4 7 2 5 8)
1574
(append-map list '(1 2 3) '(4 5) '(7 8 9)))
1575
(assert-equal? (tn)
1576
'(1 4 7 2 5 8)
1577
(append-map list '(1 2 3) '(4 5 6) '(7 8)))
1578
(assert-equal? (tn)
1579
'()
1580
(append-map list '() '(4 5 6) '(7 8 9)))
1581
(assert-equal? (tn)
1582
'()
1583
(append-map list '(1 2 3) '() '(7 8 9)))
1584
(assert-equal? (tn)
1585
'()
1586
(append-map list '(1 2 3) '(4 5 6) '()))
1587
(tn "append-map 3 lists with circular list")
1588
;; SRFI-1: At least one of the list arguments must be finite.
1589
(assert-equal? (tn)
1590
'(1 4 7 2 5 8 1 6 9)
1591
(append-map list clst2 '(4 5 6) '(7 8 9)))
1592
(assert-equal? (tn)
1593
'(1 1 7 2 2 8 3 1 9)
1594
(append-map list '(1 2 3) clst2 '(7 8 9)))
1595
(assert-equal? (tn)
1596
'(1 4 1 2 5 2 3 6 1)
1597
(append-map list '(1 2 3) '(4 5 6) clst2))
1598
(tn "append-map SRFI-1 examples")
1599
(assert-equal? (tn)
1600
'(1 -1 3 -3 8 -8)
1601
(append-map (lambda (x) (list x (- x))) '(1 3 8)))
1602
1603
;; append-map!
1604
(tn "append-map! invalid forms")
1605
(assert-error (tn) (lambda () (append-map! values)))
1606
(assert-error (tn) (lambda () (append-map! #\a '())))
1607
(assert-error (tn) (lambda () (append-map! values '#())))
1608
(assert-error (tn) (lambda () (append-map! list '(1) '#(2))))
1609
(tn "append-map! single list")
1610
(assert-equal? (tn)
1611
'()
1612
(append-map! values '()))
1613
(assert-equal? (tn)
1614
'(1 2 3 4 5 6 7)
1615
(append-map! values
1616
(list (list 1) (list 2 3) (list 4) (list 5 6 7))))
1617
(assert-equal? (tn)
1618
'(1 3 2 4 7 6 5)
1619
(append-map! reverse '((1) (2 3) (4) (5 6 7))))
1620
(tn "append-map! 3 lists")
1621
(assert-equal? (tn)
1622
'()
1623
(append-map! list '() '() '()))
1624
(assert-equal? (tn)
1625
'(1 4 7 2 5 8 3 6 9)
1626
(append-map! list '(1 2 3) '(4 5 6) '(7 8 9)))
1627
(tn "append-map! 3 lists unequal length")
1628
(assert-equal? (tn)
1629
'(1 4 7 2 5 8)
1630
(append-map! list '(1 2) '(4 5 6) '(7 8 9)))
1631
(assert-equal? (tn)
1632
'(1 4 7 2 5 8)
1633
(append-map! list '(1 2 3) '(4 5) '(7 8 9)))
1634
(assert-equal? (tn)
1635
'(1 4 7 2 5 8)
1636
(append-map! list '(1 2 3) '(4 5 6) '(7 8)))
1637
(assert-equal? (tn)
1638
'()
1639
(append-map! list '() '(4 5 6) '(7 8 9)))
1640
(assert-equal? (tn)
1641
'()
1642
(append-map! list '(1 2 3) '() '(7 8 9)))
1643
(assert-equal? (tn)
1644
'()
1645
(append-map! list '(1 2 3) '(4 5 6) '()))
1646
(tn "append-map! 3 lists with circular list")
1647
;; SRFI-1: At least one of the list arguments must be finite.
1648
(assert-equal? (tn)
1649
'(1 4 7 2 5 8 1 6 9)
1650
(append-map! list clst2 '(4 5 6) '(7 8 9)))
1651
(assert-equal? (tn)
1652
'(1 1 7 2 2 8 3 1 9)
1653
(append-map! list '(1 2 3) clst2 '(7 8 9)))
1654
(assert-equal? (tn)
1655
'(1 4 1 2 5 2 3 6 1)
1656
(append-map! list '(1 2 3) '(4 5 6) clst2))
1657
(tn "append-map! SRFI-1 examples")
1658
(assert-equal? (tn)
1659
'(1 -1 3 -3 8 -8)
1660
(append-map! (lambda (x) (list x (- x))) '(1 3 8)))
1661
1662
;; map!
1663
1664
;; map-in-order
1665
(tn "map-in-order")
1666
;; derived from SRFI-1 example of map
1667
(assert-equal? (tn)
1668
'()
1669
(let ((count 0))
1670
(map-in-order (lambda (ignored)
1671
(set! count (+ count 1))
1672
count)
1673
'())))
1674
(assert-equal? (tn)
1675
'(1 2)
1676
(let ((count 0))
1677
(map-in-order (lambda (ignored)
1678
(set! count (+ count 1))
1679
count)
1680
'(a b))))
1681
(assert-equal? (tn)
1682
'(1 2 3)
1683
(let ((count 0))
1684
(map-in-order (lambda (ignored)
1685
(set! count (+ count 1))
1686
count)
1687
'(a b c))))
1688
(assert-equal? (tn)
1689
'(1 2 3 4)
1690
(let ((count 0))
1691
(map-in-order (lambda (ignored)
1692
(set! count (+ count 1))
1693
count)
1694
'(a b c d))))
1695
1696
;; pair-for-each
1697
1698
;; filter-map
1699
(tn "filter-map invalid forms")
1700
(assert-error (tn) (lambda () (filter-map even?)))
1701
(assert-error (tn) (lambda () (filter-map #\a '())))
1702
(assert-error (tn) (lambda () (filter-map + '#(1))))
1703
(assert-error (tn) (lambda () (filter-map + '(1) '#(2))))
1704
(tn "filter-map single list")
1705
(assert-equal? (tn) '() (filter-map even? '()))
1706
(assert-equal? (tn) '(2 -8 12) (filter-map (lambda (x)
1707
(and (even? x)
1708
x))
1709
'(2 7 3 -8 5 -3 9 12)))
1710
(assert-equal? (tn) '() (filter-map pair?
1711
'(2 7 3 -8 5 -3 9 12)))
1712
(tn "filter-map 3 lists")
1713
(assert-equal? (tn)
1714
'(112 320 72 27)
1715
(filter-map (lambda args
1716
(let ((res (apply * args)))
1717
(and (positive? res)
1718
res)))
1719
'(2 8 7 3 5 -3 9)
1720
'(6 -2 38 -2 8 4 3)
1721
'(-1 -7 -5 2 8 -6 1)))
1722
(tn "filter-map 3 lists unequal length")
1723
(assert-equal? (tn)
1724
'(112 320)
1725
(filter-map (lambda args
1726
(let ((res (apply * args)))
1727
(and (positive? res)
1728
res)))
1729
'(2 8 7 3 5 -3 9)
1730
'(6 -2 38 -2 8)
1731
'(-1 -7 -5 2 8 -6)))
1732
(assert-equal? (tn)
1733
'()
1734
(filter-map (lambda args
1735
(let ((res (apply * args)))
1736
(and (positive? res)
1737
res)))
1738
'()
1739
'(6 -2 38 -2 8)
1740
'(-1 -7 -5 2 8 -6)))
1741
(assert-equal? (tn)
1742
'()
1743
(filter-map (lambda args
1744
(let ((res (apply * args)))
1745
(and (positive? res)
1746
res)))
1747
'(2 8 7 3 5 -3 9)
1748
'()
1749
'(-1 -7 -5 2 8 -6)))
1750
(assert-equal? (tn)
1751
'()
1752
(filter-map (lambda args
1753
(let ((res (apply * args)))
1754
(and (positive? res)
1755
res)))
1756
'(2 8 7 3 5 -3 9)
1757
'(6 -2 38 -2 8)
1758
'()))
1759
(tn "filter-map 3 lists unequal length with circular list")
1760
;; SRFI-1: At least one of the list arguments must be finite.
1761
(assert-equal? (tn)
1762
'(24 40 36)
1763
(filter-map (lambda args
1764
(let ((res (apply * args)))
1765
(and (positive? res)
1766
res)))
1767
'(2 8 7 3 5 -3 9)
1768
clst4
1769
'(-1 -7 -5 2 8 -6)))
1770
(assert-equal? (tn)
1771
'()
1772
(filter-map (lambda args
1773
(let ((res (apply * args)))
1774
(and (positive? res)
1775
res)))
1776
'()
1777
clst4
1778
'(-1 -7 -5 2 8 -6)))
1779
(assert-equal? (tn)
1780
'()
1781
(filter-map (lambda args
1782
(let ((res (apply * args)))
1783
(and (positive? res)
1784
res)))
1785
'(2 8 7 3 5 -3 9)
1786
'()
1787
clst4))
1788
(assert-equal? (tn)
1789
'()
1790
(filter-map (lambda args
1791
(let ((res (apply * args)))
1792
(and (positive? res)
1793
res)))
1794
'(2 8 7 3 5 -3 9)
1795
clst4
1796
'()))
1797
(tn "filter-map SRFI-1 examples")
1798
(assert-equal? (tn)
1799
'(1 9 49)
1800
(filter-map (lambda (x)
1801
(and (number? x)
1802
(* x x)))
1803
'(a 1 b 3 c 7)))
1804
1805
1806
;;
1807
;; Filtering & partitioning
1808
;;
1809
1810
;; filter
1811
(tn "filter invalid forms")
1812
(assert-error (tn) (lambda () (filter #\a '(1 2))))
1813
(assert-error (tn) (lambda () (filter cons '(1 2))))
1814
(assert-error (tn) (lambda () (filter cons '(1 2) '(3 4))))
1815
(assert-error (tn) (lambda () (filter even? '(1 2) '(3 4))))
1816
(tn "filter")
1817
(assert-equal? (tn) '() (filter even? '()))
1818
(assert-equal? (tn) '(2 4 6) (filter even? '(1 2 3 4 5 6)))
1819
(assert-equal? (tn) '(1 3 5) (filter odd? '(1 2 3 4 5 6)))
1820
(assert-equal? (tn) '(1 2 3 4 5 6) (filter number? '(1 2 3 4 5 6)))
1821
(assert-equal? (tn) '() (filter pair? '(1 2 3 4 5 6)))
1822
(tn "filter SRFI-1 examples")
1823
(assert-equal? (tn) '(0 8 8 -4) (filter even? '(0 7 8 8 43 -4)))
1824
1825
;; partition
1826
1827
;; remove
1828
(tn "remove invalid forms")
1829
(assert-error (tn) (lambda () (remove #\a '(1 2))))
1830
(assert-error (tn) (lambda () (remove cons '(1 2))))
1831
(assert-error (tn) (lambda () (remove cons '(1 2) '(3 4))))
1832
(assert-error (tn) (lambda () (remove even? '(1 2) '(3 4))))
1833
(tn "remove")
1834
(assert-equal? (tn) '() (remove even? '()))
1835
(assert-equal? (tn) '(0 8 8 -4) (remove odd? '(0 7 8 8 43 -4)))
1836
(assert-equal? (tn) '() (remove number? '(0 7 8 8 43 -4)))
1837
(assert-equal? (tn) '(0 7 8 8 43 -4) (remove pair? '(0 7 8 8 43 -4)))
1838
(tn "remove SRFI-1 examples")
1839
(assert-equal? (tn) '(7 43) (remove even? '(0 7 8 8 43 -4)))
1840
1841
;; filter!
1842
;; partition!
1843
;; remove!
1844
1845
1846
;;
1847
;; Searching
1848
;;
1849
1850
;; find
1851
(tn "find invalid forms")
1852
(assert-error (tn) (lambda () (find even? '#(1 2))))
1853
(assert-error (tn) (lambda () (find 1 '(1 2))))
1854
(tn "find proper list")
1855
(assert-false (tn) (find even? '()))
1856
(assert-false (tn) (find (lambda (x) #f) lst))
1857
(assert-eq? (tn) elm0 (find (lambda (x) (eq? x elm0)) lst))
1858
(assert-eq? (tn) elm1 (find (lambda (x) (eq? x elm1)) lst))
1859
(assert-eq? (tn) elm2 (find (lambda (x) (eq? x elm2)) lst))
1860
(assert-eq? (tn) elm8 (find (lambda (x) (eq? x elm8)) lst))
1861
(assert-eq? (tn) elm9 (find (lambda (x) (eq? x elm9)) lst))
1862
(tn "find dotted list")
1863
(assert-error (tn) (lambda () (find even? 1)))
1864
(assert-equal? (tn) 1 (find (lambda (x) (= x 1)) '(1 . 2)))
1865
(assert-equal? (tn) 2 (find (lambda (x) (= x 2)) '(1 2 . 3)))
1866
(assert-equal? (tn) 3 (find (lambda (x) (= x 3)) '(1 2 3 . 4)))
1867
(assert-error (tn) (lambda () (find even? '(1 . 2))))
1868
(assert-equal? (tn) 2 (find even? '(1 2 . 3)))
1869
(assert-equal? (tn) 2 (find even? '(1 2 3 . 4)))
1870
(assert-equal? (tn) 1 (find odd? '(1 . 2)))
1871
(assert-equal? (tn) 1 (find odd? '(1 2 . 3)))
1872
(assert-equal? (tn) 1 (find odd? '(1 2 3 . 4)))
1873
(tn "find circular list")
1874
;; Rotates the circular list as like as find-tail.
1875
(assert-equal? (tn) 1 (find (lambda (x) (= x 1)) clst4))
1876
(assert-equal? (tn) 2 (find (lambda (x) (= x 2)) clst4))
1877
(assert-equal? (tn) 3 (find (lambda (x) (= x 3)) clst4))
1878
(assert-equal? (tn) 4 (find (lambda (x) (= x 4)) clst4))
1879
(assert-equal? (tn)
1880
1
1881
(let ((cnt 2))
1882
(find (lambda (x)
1883
(if (= x 1)
1884
(set! cnt (- cnt 1)))
1885
(and (zero? cnt)
1886
(= x 1)))
1887
clst4)))
1888
(assert-equal? (tn)
1889
2
1890
(let ((cnt 2))
1891
(find (lambda (x)
1892
(if (= x 1)
1893
(set! cnt (- cnt 1)))
1894
(and (zero? cnt)
1895
(= x 2)))
1896
clst4)))
1897
(assert-equal? (tn)
1898
3
1899
(let ((cnt 2))
1900
(find (lambda (x)
1901
(if (= x 1)
1902
(set! cnt (- cnt 1)))
1903
(and (zero? cnt)
1904
(= x 3)))
1905
clst4)))
1906
(assert-equal? (tn)
1907
1
1908
(let ((cnt 3))
1909
(find (lambda (x)
1910
(if (= x 1)
1911
(set! cnt (- cnt 1)))
1912
(and (zero? cnt)
1913
(= x 1)))
1914
clst4)))
1915
(assert-equal? (tn)
1916
1
1917
(let ((cnt 4))
1918
(find (lambda (x)
1919
(if (= x 1)
1920
(set! cnt (- cnt 1)))
1921
(and (zero? cnt)
1922
(= x 1)))
1923
clst4)))
1924
1925
;; find-tail
1926
(tn "find-tail invalid forms")
1927
(assert-error (tn) (lambda () (find-tail even? '#(1 2))))
1928
(assert-error (tn) (lambda () (find-tail 1 '(1 2))))
1929
(tn "find-tail proper list")
1930
;; Although the behavior on null list is not explicitly defined in SRFI-1
1931
;; itself, the reference implementation returns #f So SigScheme followed it.
1932
(assert-false (tn) (find-tail even? '()))
1933
(assert-false (tn) (find-tail (lambda (x) #f) lst))
1934
(assert-eq? (tn) lst (find-tail (lambda (x) (eq? x elm0)) lst))
1935
(assert-eq? (tn) cdr1 (find-tail (lambda (x) (eq? x elm1)) lst))
1936
(assert-eq? (tn) cdr2 (find-tail (lambda (x) (eq? x elm2)) lst))
1937
(assert-eq? (tn) cdr8 (find-tail (lambda (x) (eq? x elm8)) lst))
1938
(assert-eq? (tn) cdr9 (find-tail (lambda (x) (eq? x elm9)) lst))
1939
(tn "find-tail dotted list")
1940
(assert-error (tn) (lambda () (find-tail even? 1)))
1941
;; Although the behavior on dotted list is not defined in SRFI-1 itself, the
1942
;; reference implementation returns the last pair. So SigScheme followed it.
1943
(assert-equal? (tn) '(1 . 2) (find-tail (lambda (x) (= x 1)) '(1 . 2)))
1944
(assert-equal? (tn) '(2 . 3) (find-tail (lambda (x) (= x 2)) '(1 2 . 3)))
1945
(assert-equal? (tn) '(3 . 4) (find-tail (lambda (x) (= x 3)) '(1 2 3 . 4)))
1946
(assert-error (tn) (lambda () (find-tail even? '(1 . 2))))
1947
(assert-equal? (tn) '(2 . 3) (find-tail even? '(1 2 . 3)))
1948
(assert-equal? (tn) '(2 3 . 4) (find-tail even? '(1 2 3 . 4)))
1949
(assert-equal? (tn) '(1 . 2) (find-tail odd? '(1 . 2)))
1950
(assert-equal? (tn) '(1 2 . 3) (find-tail odd? '(1 2 . 3)))
1951
(assert-equal? (tn) '(1 2 3 . 4) (find-tail odd? '(1 2 3 . 4)))
1952
(tn "find-tail circular list")
1953
;; SRFI-1: In the circular-list case, this procedure "rotates" the list.
1954
(assert-eq? (tn) clst4 (find-tail (lambda (x) (= x 1)) clst4))
1955
(assert-eq? (tn) (my-list-tail clst4 1) (find-tail (lambda (x) (= x 2))
1956
clst4))
1957
(assert-eq? (tn) (my-list-tail clst4 2) (find-tail (lambda (x) (= x 3))
1958
clst4))
1959
(assert-eq? (tn) (my-list-tail clst4 3) (find-tail (lambda (x) (= x 4))
1960
clst4))
1961
(assert-eq? (tn)
1962
clst4
1963
(let ((cnt 2))
1964
(find-tail (lambda (x)
1965
(if (= x 1)
1966
(set! cnt (- cnt 1)))
1967
(and (zero? cnt)
1968
(= x 1)))
1969
clst4)))
1970
(assert-eq? (tn)
1971
(my-list-tail clst4 1)
1972
(let ((cnt 2))
1973
(find-tail (lambda (x)
1974
(if (= x 1)
1975
(set! cnt (- cnt 1)))
1976
(and (zero? cnt)
1977
(= x 2)))
1978
clst4)))
1979
(assert-eq? (tn)
1980
(my-list-tail clst4 2)
1981
(let ((cnt 2))
1982
(find-tail (lambda (x)
1983
(if (= x 1)
1984
(set! cnt (- cnt 1)))
1985
(and (zero? cnt)
1986
(= x 3)))
1987
clst4)))
1988
(assert-eq? (tn)
1989
clst4
1990
(let ((cnt 3))
1991
(find-tail (lambda (x)
1992
(if (= x 1)
1993
(set! cnt (- cnt 1)))
1994
(and (zero? cnt)
1995
(= x 1)))
1996
clst4)))
1997
(assert-eq? (tn)
1998
clst4
1999
(let ((cnt 4))
2000
(find-tail (lambda (x)
2001
(if (= x 1)
2002
(set! cnt (- cnt 1)))
2003
(and (zero? cnt)
2004
(= x 1)))
2005
clst4)))
2006
2007
;; take-while
2008
;; take-while!
2009
;; drop-while
2010
;; span
2011
;; span!
2012
;; break
2013
;; break!
2014
2015
;; any
2016
(tn "any invalid forms")
2017
(assert-error (tn) (lambda () (any +)))
2018
(assert-error (tn) (lambda () (any + '#())))
2019
(assert-error (tn) (lambda () (any + '(1) '#(2))))
2020
(assert-error (tn) (lambda () (any #\a '(1))))
2021
(tn "any single list")
2022
(assert-equal? (tn) #f (any + '()))
2023
(assert-equal? (tn) #f (any even? '()))
2024
(assert-equal? (tn) 2 (any + '(2 4 6 8)))
2025
(assert-equal? (tn) #f (any odd? '(2 4 6 8)))
2026
(assert-equal? (tn) #t (any odd? '(3 2 4 6 8)))
2027
(assert-equal? (tn) #t (any odd? '(2 4 3 6 8)))
2028
(assert-equal? (tn) #t (any odd? '(2 4 6 8 3)))
2029
(tn "any 3 lists")
2030
(assert-equal? (tn) #f (any + '() '() '()))
2031
(assert-equal? (tn) 12 (any +
2032
'(2 4 6 8)
2033
'(1 3 5 7)
2034
'(9 10 11 12)))
2035
(assert-equal? (tn) 17 (any (lambda args
2036
(let ((sum (apply + args)))
2037
(and (odd? sum)
2038
sum)))
2039
'(2 4 6 8)
2040
'(1 3 5 7)
2041
'(9 10 11 12)))
2042
(assert-equal? (tn) #f (any (lambda args
2043
(let ((sum (apply + args)))
2044
(and (odd? sum)
2045
sum)))
2046
'(2 4 6 8)
2047
'(1 4 5 8)
2048
'(9 10 11 12)))
2049
(tn "any 3 lists unequal length")
2050
(assert-equal? (tn) 22 (any (lambda args
2051
(let ((sum (apply + args)))
2052
(and (< 20 sum)
2053
sum)))
2054
'(2 4 6)
2055
'(1 3 5 7)
2056
'(9 10 11 12)))
2057
(assert-equal? (tn) 22 (any (lambda args
2058
(let ((sum (apply + args)))
2059
(and (< 20 sum)
2060
sum)))
2061
'(2 4 6 8)
2062
'(1 3 5)
2063
'(9 10 11 12)))
2064
(assert-equal? (tn) 22 (any (lambda args
2065
(let ((sum (apply + args)))
2066
(and (< 20 sum)
2067
sum)))
2068
'(2 4 6 8)
2069
'(1 3 5 7)
2070
'(9 10 11)))
2071
(assert-equal? (tn) #f (any (lambda args
2072
(let ((sum (apply + args)))
2073
(and (< 25 sum)
2074
sum)))
2075
'(2 4 6)
2076
'(1 3 5 7)
2077
'(9 10 11 12)))
2078
(assert-equal? (tn) #f (any (lambda args
2079
(let ((sum (apply + args)))
2080
(and (< 25 sum)
2081
sum)))
2082
'(2 4 6 8)
2083
'(1 3 5)
2084
'(9 10 11 12)))
2085
(assert-equal? (tn) #f (any (lambda args
2086
(let ((sum (apply + args)))
2087
(and (< 25 sum)
2088
sum)))
2089
'(2 4 6 8)
2090
'(1 3 5 7)
2091
'(9 10 11)))
2092
(assert-equal? (tn) #f (any +
2093
'()
2094
'(1 3 5 7)
2095
'(9 10 11 12)))
2096
(assert-equal? (tn) #f (any +
2097
'(2 4 6 8)
2098
'()
2099
'(9 10 11 12)))
2100
(assert-equal? (tn) #f (any +
2101
'(2 4 6 8)
2102
'(1 3 5 7)
2103
'()))
2104
(tn "any 3 lists with circular list")
2105
(assert-equal? (tn) 11 (any +
2106
clst2
2107
'(1 3 5 7)
2108
'(9 10 11 12)))
2109
(assert-equal? (tn) 21 (any (lambda args
2110
(let ((sum (apply + args)))
2111
(and (< 20 sum)
2112
sum)))
2113
clst2
2114
'(1 3 5 7)
2115
'(9 10 11 12)))
2116
(tn "any 3 SRFI-1 examples")
2117
;;(assert-eq? (tn) #t (any integer? '(a 3 b 2.7)))
2118
(assert-eq? (tn) #t (any integer? '(a 3 b #\2)))
2119
;;(assert-eq? (tn) #f (any integer? '(a 3.1 b 2.7)))
2120
(assert-eq? (tn) #f (any integer? '(a #\3 b #\2)))
2121
(assert-eq? (tn) #t (any < '(3 1 4 1 5)
2122
'(2 7 1 8 2)))
2123
2124
;; every
2125
(tn "every invalid forms")
2126
(assert-error (tn) (lambda () (every +)))
2127
(assert-error (tn) (lambda () (every + '#())))
2128
(assert-error (tn) (lambda () (every + '(1) '#(2))))
2129
(assert-error (tn) (lambda () (every #\a '(1))))
2130
(tn "every single list")
2131
(assert-equal? (tn) #t (every + '()))
2132
(assert-equal? (tn) #t (every even? '()))
2133
(assert-equal? (tn) 8 (every + '(2 4 6 8)))
2134
(assert-equal? (tn) #t (every even? '(2 4 6 8)))
2135
(assert-equal? (tn) #f (every even? '(3 2 4 6 8)))
2136
(assert-equal? (tn) #f (every even? '(2 4 3 6 8)))
2137
(assert-equal? (tn) #f (every even? '(2 4 6 8 3)))
2138
(tn "every 3 lists")
2139
(assert-equal? (tn) #t (every + '() '() '()))
2140
(assert-equal? (tn) 27 (every +
2141
'(2 4 6 8)
2142
'(1 3 5 7)
2143
'(9 10 11 12)))
2144
(assert-equal? (tn) #f (every (lambda args
2145
(let ((sum (apply + args)))
2146
(and (even? sum)
2147
sum)))
2148
'(2 4 6 8)
2149
'(1 3 5 7)
2150
'(9 10 11 12)))
2151
(assert-equal? (tn) 28 (every (lambda args
2152
(let ((sum (apply + args)))
2153
(and (even? sum)
2154
sum)))
2155
'(2 4 6 8)
2156
'(1 4 5 8)
2157
'(9 10 11 12)))
2158
(tn "every 3 lists unequal length")
2159
(assert-equal? (tn) 22 (every +
2160
'(2 4 6)
2161
'(1 3 5 7)
2162
'(9 10 11 12)))
2163
(assert-equal? (tn) 22 (every +
2164
'(2 4 6 8)
2165
'(1 3 5)
2166
'(9 10 11 12)))
2167
(assert-equal? (tn) 22 (every +
2168
'(2 4 6 8)
2169
'(1 3 5 7)
2170
'(9 10 11)))
2171
(assert-equal? (tn) #t (every +
2172
'()
2173
'(1 3 5 7)
2174
'(9 10 11 12)))
2175
(assert-equal? (tn) #t (every +
2176
'(2 4 6 8)
2177
'()
2178
'(9 10 11 12)))
2179
(assert-equal? (tn) #t (every +
2180
'(2 4 6 8)
2181
'(1 3 5 7)
2182
'()))
2183
(tn "every 3 lists with circular list")
2184
(assert-equal? (tn) 21 (every +
2185
clst2
2186
'(1 3 5 7)
2187
'(9 10 11 12)))
2188
2189
;; list-index
2190
(tn "list-index invalid forms")
2191
(assert-error (tn) (lambda () (list-index even?)))
2192
(assert-error (tn) (lambda () (list-index even? '#())))
2193
(assert-error (tn) (lambda () (list-index #\a '(1))))
2194
(assert-error (tn) (lambda () (list-index + '(1) '#(2))))
2195
(tn "list-index single list")
2196
(assert-false (tn) (list-index even? '()))
2197
(assert-false (tn) (list-index even? '(1)))
2198
(assert-equal? (tn) 1 (list-index even? '(1 2)))
2199
(assert-equal? (tn) 1 (list-index even? '(1 2 3)))
2200
(assert-false (tn) (list-index odd? '(2 4 6 8)))
2201
(assert-equal? (tn) 0 (list-index odd? '(3 2 4 6 8)))
2202
(assert-equal? (tn) 2 (list-index odd? '(2 4 3 6 8)))
2203
(assert-equal? (tn) 4 (list-index odd? '(2 4 6 8 3)))
2204
(tn "list-index 3 lists")
2205
(assert-false (tn) (list-index + '() '() '()))
2206
(assert-equal? (tn) 0 (list-index +
2207
'(2 4 6 8)
2208
'(1 3 5 7)
2209
'(9 10 11 12)))
2210
(assert-equal? (tn) 1 (list-index (lambda args
2211
(let ((sum (apply + args)))
2212
(and (odd? sum)
2213
sum)))
2214
'(2 4 6 8)
2215
'(1 3 5 7)
2216
'(9 10 11 12)))
2217
(assert-equal? (tn) #f (list-index (lambda args
2218
(let ((sum (apply + args)))
2219
(and (odd? sum)
2220
sum)))
2221
'(2 4 6 8)
2222
'(1 4 5 8)
2223
'(9 10 11 12)))
2224
(tn "list-index 3 lists unequal length")
2225
(assert-equal? (tn) 2 (list-index (lambda args
2226
(let ((sum (apply + args)))
2227
(and (< 20 sum)
2228
sum)))
2229
'(2 4 6)
2230
'(1 3 5 7)
2231
'(9 10 11 12)))
2232
(assert-equal? (tn) 2 (list-index (lambda args
2233
(let ((sum (apply + args)))
2234
(and (< 20 sum)
2235
sum)))
2236
'(2 4 6 8)
2237
'(1 3 5)
2238
'(9 10 11 12)))
2239
(assert-equal? (tn) 2 (list-index (lambda args
2240
(let ((sum (apply + args)))
2241
(and (< 20 sum)
2242
sum)))
2243
'(2 4 6 8)
2244
'(1 3 5 7)
2245
'(9 10 11)))
2246
(assert-equal? (tn) #f (list-index (lambda args
2247
(let ((sum (apply + args)))
2248
(and (< 25 sum)
2249
sum)))
2250
'(2 4 6)
2251
'(1 3 5 7)
2252
'(9 10 11 12)))
2253
(assert-equal? (tn) #f (list-index (lambda args
2254
(let ((sum (apply + args)))
2255
(and (< 25 sum)
2256
sum)))
2257
'(2 4 6 8)
2258
'(1 3 5)
2259
'(9 10 11 12)))
2260
(assert-equal? (tn) #f (list-index (lambda args
2261
(let ((sum (apply + args)))
2262
(and (< 25 sum)
2263
sum)))
2264
'(2 4 6 8)
2265
'(1 3 5 7)
2266
'(9 10 11)))
2267
(assert-equal? (tn) #f (list-index +
2268
'()
2269
'(1 3 5 7)
2270
'(9 10 11 12)))
2271
(assert-equal? (tn) #f (list-index +
2272
'(2 4 6 8)
2273
'()
2274
'(9 10 11 12)))
2275
(assert-equal? (tn) #f (list-index +
2276
'(2 4 6 8)
2277
'(1 3 5 7)
2278
'()))
2279
(tn "list-index SRFI-1 examples")
2280
(assert-equal? (tn) 2 (list-index even? '(3 1 4 1 5 9)))
2281
(assert-equal? (tn) 1 (list-index < '(3 1 4 1 5 9 2 5 6) '(2 7 1 8 2)))
2282
(assert-equal? (tn) #f (list-index = '(3 1 4 1 5 9 2 5 6) '(2 7 1 8 2)))
2283
2284
;; member
2285
(tn "member invalid forms")
2286
(assert-error (tn) (lambda () (member 1)))
2287
(assert-error (tn) (lambda () (member 1 '#(1))))
2288
(assert-error (tn) (lambda () (member 1 '(1) #\a)))
2289
(assert-error (tn) (lambda () (member 1 '(1) = '())))
2290
(tn "member")
2291
(assert-eq? (tn) #f (member 1 '()))
2292
(assert-eq? (tn) #f (member 1 '() eq?))
2293
(assert-eq? (tn) #f (member 1 '() equal?))
2294
(assert-eq? (tn) cdr3 (member elm3 lst))
2295
(assert-eq? (tn) cdr3 (member elm3 lst eq?))
2296
(assert-eq? (tn) cdr3 (member elm3 lst equal?))
2297
(assert-eq? (tn) cdr3 (member (list-copy elm3) lst))
2298
(assert-false (tn) (member (list-copy elm3) lst eq?))
2299
(assert-eq? (tn) cdr3 (member (list-copy elm3) lst equal?))
2300
2301
2302
;;
2303
;; Deleting
2304
;;
2305
2306
;; delete
2307
(tn "delete invalid forms")
2308
(assert-error (tn) (lambda () (delete 1)))
2309
(assert-error (tn) (lambda () (delete 1 '#(1))))
2310
(assert-error (tn) (lambda () (delete 1 '(1) #\a)))
2311
(assert-error (tn) (lambda () (delete 1 '(1) = '())))
2312
(tn "delete")
2313
(assert-equal? (tn) '() (delete 1 '()))
2314
(assert-equal? (tn) '() (delete 1 '() eq?))
2315
(assert-equal? (tn) '() (delete 1 '() equal?))
2316
(assert-equal? (tn) (list cdr0 cdr2) (delete cdr1 (list cdr0 cdr1 cdr2)))
2317
(assert-equal? (tn) (list cdr0 cdr2) (delete cdr1 (list cdr0 cdr1 cdr2) eq?))
2318
(assert-equal? (tn) (list cdr0 cdr2) (delete cdr1 (list cdr0 cdr1 cdr2) equal?))
2319
(assert-equal? (tn) (list cdr0 cdr2) (delete (list-copy cdr1)
2320
(list cdr0 cdr1 cdr2)))
2321
(assert-equal? (tn) (list cdr0 cdr1 cdr2) (delete (list-copy cdr1)
2322
(list cdr0 cdr1 cdr2) eq?))
2323
(assert-equal? (tn) (list cdr0 cdr2) (delete (list-copy cdr1)
2324
(list cdr0 cdr1 cdr2) equal?))
2325
(tn "delete SRFI-1 examples")
2326
(assert-equal? (tn) '(0 -4) (delete 5 '(0 7 8 8 43 -4) <))
2327
2328
;; delete!
2329
(tn "delete! invalid forms")
2330
(assert-error (tn) (lambda () (delete! 1)))
2331
(assert-error (tn) (lambda () (delete! 1 (vector 1))))
2332
(assert-error (tn) (lambda () (delete! 1 (list 1) #\a)))
2333
(assert-error (tn) (lambda () (delete! 1 (list 1) = '())))
2334
(tn "delete!")
2335
(assert-equal? (tn) '() (delete! 1 '()))
2336
(assert-equal? (tn) '() (delete! 1 '() eq?))
2337
(assert-equal? (tn) '() (delete! 1 '() equal?))
2338
(assert-equal? (tn) (list cdr0 cdr2) (delete! cdr1 (list cdr0 cdr1 cdr2)))
2339
(assert-equal? (tn) (list cdr0 cdr2) (delete! cdr1 (list cdr0 cdr1 cdr2) eq?))
2340
(assert-equal? (tn) (list cdr0 cdr2) (delete! cdr1 (list cdr0 cdr1 cdr2) equal?))
2341
(assert-equal? (tn) (list cdr0 cdr2) (delete! (list-copy cdr1)
2342
(list cdr0 cdr1 cdr2)))
2343
(assert-equal? (tn) (list cdr0 cdr1 cdr2) (delete! (list-copy cdr1)
2344
(list cdr0 cdr1 cdr2) eq?))
2345
(assert-equal? (tn) (list cdr0 cdr2) (delete! (list-copy cdr1)
2346
(list cdr0 cdr1 cdr2) equal?))
2347
(tn "delete! SRFI-1 examples")
2348
(assert-equal? (tn) '(0 -4) (delete! 5 (list 0 7 8 8 43 -4) <))
2349
2350
;; delete-duplicates
2351
;; delete-duplicates!
2352
2353
2354
;;
2355
;; Association lists
2356
;;
2357
2358
(define alist-s '(("b" . 2) ("a" . 1) ("d" . 4) ("b" . 5) ("c" . 3)))
2359
(define alist-n '((1 . a) (5 . e) (6 . f) (2 . b) (4 . d) (3 . c)
2360
(4 . d) (3 . c) (7 . g) (6 . f) (5 . e) (7 . g)))
2361
2362
;; assoc
2363
(tn "assoc (SRFI-1 extended) invalid forms")
2364
(assert-error (tn) (lambda () (assoc "a" alist-s #\a)))
2365
(assert-error (tn) (lambda () (assoc "a" alist-s string=? values)))
2366
(tn "assoc (SRFI-1 extended)")
2367
(assert-equal? (tn) '("b" . 2) (assoc "b" alist-s))
2368
(assert-equal? (tn) '("a" . 1) (assoc "a" alist-s))
2369
(assert-equal? (tn) '("d" . 4) (assoc "d" alist-s))
2370
(assert-equal? (tn) '("c" . 3) (assoc "c" alist-s))
2371
(assert-false (tn) (assoc "A" alist-s))
2372
(assert-equal? (tn) '("b" . 2) (assoc "b" alist-s string=?))
2373
(assert-equal? (tn) '("a" . 1) (assoc "a" alist-s string=?))
2374
(assert-equal? (tn) '("d" . 4) (assoc "d" alist-s string=?))
2375
(assert-equal? (tn) '("c" . 3) (assoc "c" alist-s string=?))
2376
(assert-false (tn) (assoc "A" alist-s string=?))
2377
2378
;; alist-cons
2379
(tn "alist-cons")
2380
(assert-equal? (tn) '(("A" . 1)) (alist-cons "A" 1 '()))
2381
(assert-equal? (tn) (cons '("A" . 1) alist-s) (alist-cons "A" 1 alist-s))
2382
(assert-eq? (tn) alist-s (cdr (alist-cons "A" 1 alist-s)))
2383
2384
;; alist-copy
2385
(tn "alist-copy")
2386
(assert-equal? (tn) '() (alist-copy '()))
2387
(assert-equal? (tn) alist-s (alist-copy alist-s))
2388
(assert-false (tn) (eq? (list-ref alist-s 0)
2389
(list-ref (alist-copy alist-s) 0)))
2390
(assert-true (tn) (eq? (car (list-ref alist-s 0))
2391
(car (list-ref (alist-copy alist-s) 0))))
2392
(assert-true (tn) (eq? (cdr (list-ref alist-s 0))
2393
(cdr (list-ref (alist-copy alist-s) 0))))
2394
(assert-false (tn) (eq? (list-ref alist-s 1)
2395
(list-ref (alist-copy alist-s) 1)))
2396
(assert-true (tn) (eq? (car (list-ref alist-s 1))
2397
(car (list-ref (alist-copy alist-s) 1))))
2398
(assert-true (tn) (eq? (cdr (list-ref alist-s 1))
2399
(cdr (list-ref (alist-copy alist-s) 1))))
2400
(assert-false (tn) (eq? (list-ref alist-s 2)
2401
(list-ref (alist-copy alist-s) 2)))
2402
(assert-true (tn) (eq? (car (list-ref alist-s 2))
2403
(car (list-ref (alist-copy alist-s) 2))))
2404
(assert-true (tn) (eq? (cdr (list-ref alist-s 2))
2405
(cdr (list-ref (alist-copy alist-s) 2))))
2406
2407
;; alist-delete
2408
(tn "alist-delete invalid forms")
2409
(assert-error (tn) (lambda () (alist-delete "A" '#())))
2410
(assert-error (tn) (lambda () (alist-delete "A" '(("a" . 1)) #\a)))
2411
(assert-error (tn) (lambda () (alist-delete #\a '(("a" . 1)) string=?)))
2412
(tn "alist-delete")
2413
(assert-equal? (tn) '() (alist-delete "A" '()))
2414
(assert-equal? (tn) '() (alist-delete "A" '() string=?))
2415
(assert-equal? (tn)
2416
'(("b" . 2) ("a" . 1) ("d" . 4) ("b" . 5) ("c" . 3))
2417
(alist-delete "A" alist-s))
2418
(assert-equal? (tn)
2419
'(("b" . 2) ("d" . 4) ("b" . 5) ("c" . 3))
2420
(alist-delete "a" alist-s))
2421
(assert-equal? (tn)
2422
'(("a" . 1) ("d" . 4) ("c" . 3))
2423
(alist-delete "b" alist-s))
2424
(assert-equal? (tn)
2425
'(("a" . 1) ("d" . 4) ("c" . 3))
2426
(alist-delete "b" alist-s string=?))
2427
(assert-equal? (tn)
2428
'((1 . a) (5 . e) (6 . f) (2 . b) (4 . d) (3 . c)
2429
(4 . d) (3 . c) (7 . g) (6 . f) (5 . e) (7 . g))
2430
(alist-delete -1 alist-n))
2431
(assert-equal? (tn)
2432
'((1 . a) (5 . e) (2 . b) (4 . d) (3 . c)
2433
(4 . d) (3 . c) (7 . g) (5 . e) (7 . g))
2434
(alist-delete 6 alist-n))
2435
(assert-equal? (tn)
2436
'((1 . a) (5 . e) (2 . b) (4 . d) (3 . c)
2437
(4 . d) (3 . c) (7 . g) (5 . e) (7 . g))
2438
(alist-delete 6 alist-n =))
2439
(tn "alist-delete SRFI-1 examples")
2440
(assert-equal? (tn)
2441
'((1 . a) (5 . e) (2 . b) (4 . d) (3 . c)
2442
(4 . d) (3 . c) (5 . e))
2443
(alist-delete 5 alist-n <))
2444
2445
;; alist-delete!
2446
(tn "alist-delete! invalid forms")
2447
(assert-error (tn) (lambda () (alist-delete! "A" (vector))))
2448
(assert-error (tn) (lambda () (alist-delete! "A" (list (cons "a" 1)) #\a)))
2449
(assert-error (tn) (lambda () (alist-delete! #\a (list (cons "a" 1)) string=?)))
2450
(tn "alist-delete!")
2451
(assert-equal? (tn) '() (alist-delete! "A" '()))
2452
(assert-equal? (tn) '() (alist-delete! "A" '() string=?))
2453
(assert-equal? (tn)
2454
'(("b" . 2) ("a" . 1) ("d" . 4) ("b" . 5) ("c" . 3))
2455
(alist-delete! "A" (alist-copy alist-s)))
2456
(assert-equal? (tn)
2457
'(("b" . 2) ("d" . 4) ("b" . 5) ("c" . 3))
2458
(alist-delete! "a" (alist-copy alist-s)))
2459
(assert-equal? (tn)
2460
'(("a" . 1) ("d" . 4) ("c" . 3))
2461
(alist-delete! "b" (alist-copy alist-s)))
2462
(assert-equal? (tn)
2463
'(("a" . 1) ("d" . 4) ("c" . 3))
2464
(alist-delete! "b" (alist-copy alist-s) string=?))
2465
(assert-equal? (tn)
2466
'((1 . a) (5 . e) (6 . f) (2 . b) (4 . d) (3 . c)
2467
(4 . d) (3 . c) (7 . g) (6 . f) (5 . e) (7 . g))
2468
(alist-delete! -1 (alist-copy alist-n)))
2469
(assert-equal? (tn)
2470
'((1 . a) (5 . e) (2 . b) (4 . d) (3 . c)
2471
(4 . d) (3 . c) (7 . g) (5 . e) (7 . g))
2472
(alist-delete! 6 (alist-copy alist-n)))
2473
(assert-equal? (tn)
2474
'((1 . a) (5 . e) (2 . b) (4 . d) (3 . c)
2475
(4 . d) (3 . c) (7 . g) (5 . e) (7 . g))
2476
(alist-delete! 6 (alist-copy alist-n) =))
2477
(tn "alist-delete! SRFI-1 examples")
2478
(assert-equal? (tn)
2479
'((1 . a) (5 . e) (2 . b) (4 . d) (3 . c)
2480
(4 . d) (3 . c) (5 . e))
2481
(alist-delete! 5 (alist-copy alist-n) <))
2482
2483
2484
;;
2485
;; Set operations on lists
2486
;;
2487
2488
;; lset<=
2489
;; lset=
2490
;; lset-adjoin
2491
;; lset-union
2492
;; lset-intersection
2493
;; lset-difference
2494
2495
;; lset-xor
2496
(tn "lset-xor")
2497
;; To test the bug of the original srfi-1-reference.scm
2498
(assert-equal? (tn)
2499
'("d")
2500
(lset-xor equal? '("a" "b" "c") '("d" "c" "a" "b")))
2501
2502
;; lset-diff+intersection
2503
;; lset-union!
2504
;; lset-intersection!
2505
;; lset-difference!
2506
2507
;; lset-xor!
2508
(tn "lset-xor!")
2509
;; To test the bug of the original srfi-1-reference.scm
2510
(assert-equal? (tn)
2511
'("d")
2512
(lset-xor equal? (list "a" "b" "c") (list "d" "c" "a" "b")))
2513
2514
;; lset-diff+intersection!
2515
2516
2517
(total-report)
Loggerhead is a web-based interface for Breezy
Version: 2.0.1