HCoop / bpt / guile.git / blame
| Commit | Line | Data |
|---|---|---|
| 91e7199f KR |
1 | ;;;; srfi-1.test --- Test suite for Guile's SRFI-1 functions. -*- scheme -*- |
| 2 | ;;;; | |
| f9a95cfe | 3 | ;;;; Copyright 2003, 2004 Free Software Foundation, Inc. |
| 91e7199f KR |
4 | ;;;; |
| 5 | ;;;; This program is free software; you can redistribute it and/or modify | |
| 6 | ;;;; it under the terms of the GNU General Public License as published by | |
| 7 | ;;;; the Free Software Foundation; either version 2, or (at your option) | |
| 8 | ;;;; any later version. | |
| 9 | ;;;; | |
| 10 | ;;;; This program is distributed in the hope that it will be useful, | |
| 11 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
| 12 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
| 13 | ;;;; GNU General Public License for more details. | |
| 14 | ;;;; | |
| 15 | ;;;; You should have received a copy of the GNU General Public License | |
| 16 | ;;;; along with this software; see the file COPYING. If not, write to | |
| 17 | ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, | |
| 18 | ;;;; Boston, MA 02111-1307 USA | |
| 19 | ||
| 20 | (use-modules (srfi srfi-1) | |
| 21 | (test-suite lib)) | |
| 22 | ||
| 72f1b979 KR |
23 | (define (ref-delete x lst . proc) |
| 24 | "Reference implemenation of srfi-1 `delete'." | |
| 25 | (set! proc (if (null? proc) equal? (car proc))) | |
| 26 | (do ((ret '()) | |
| 27 | (lst lst (cdr lst))) | |
| 28 | ((null? lst) | |
| 29 | (reverse! ret)) | |
| 30 | (if (not (proc x (car lst))) | |
| 31 | (set! ret (cons (car lst) ret))))) | |
| 32 | ||
| 33 | (define (ref-delete-duplicates lst . proc) | |
| 34 | "Reference implemenation of srfi-1 `delete-duplicates'." | |
| 35 | (set! proc (if (null? proc) equal? (car proc))) | |
| 36 | (if (null? lst) | |
| 37 | '() | |
| 38 | (do ((keep '())) | |
| 39 | ((null? lst) | |
| 40 | (reverse! keep)) | |
| 41 | (let ((elem (car lst))) | |
| 42 | (set! keep (cons elem keep)) | |
| 43 | (set! lst (ref-delete elem lst proc)))))) | |
| 44 | ||
| 91e7199f | 45 | |
| f9a95cfe KR |
46 | ;; |
| 47 | ;; alist-copy | |
| 48 | ;; | |
| 49 | ||
| 50 | (with-test-prefix "alist-copy" | |
| 51 | ||
| 52 | ;; return a list which is the pairs making up alist A, the spine and cells | |
| 53 | (define (alist-pairs a) | |
| 54 | (let more ((a a) | |
| 55 | (result a)) | |
| 56 | (if (pair? a) | |
| 57 | (more (cdr a) (cons a result)) | |
| 58 | result))) | |
| 59 | ||
| 60 | ;; return a list of the elements common to lists X and Y, compared with eq? | |
| 61 | (define (common-elements x y) | |
| 62 | (if (null? x) | |
| 63 | '() | |
| 64 | (if (memq (car x) y) | |
| 65 | (cons (car x) (common-elements (cdr x) y)) | |
| 66 | (common-elements (cdr x) y)))) | |
| 67 | ||
| 68 | ;; validate an alist-copy of OLD to NEW | |
| 69 | ;; lists must be equal, and must comprise new pairs | |
| 70 | (define (valid-alist-copy? old new) | |
| 71 | (and (equal? old new) | |
| 72 | (null? (common-elements old new)))) | |
| 73 | ||
| 74 | (pass-if-exception "too few args" exception:wrong-num-args | |
| 75 | (alist-copy)) | |
| 76 | ||
| 77 | (pass-if-exception "too many args" exception:wrong-num-args | |
| 78 | (alist-copy '() '())) | |
| 79 | ||
| 80 | (let ((old '())) | |
| 81 | (pass-if old (valid-alist-copy? old (alist-copy old)))) | |
| 82 | ||
| 83 | (let ((old '((1 . 2)))) | |
| 84 | (pass-if old (valid-alist-copy? old (alist-copy old)))) | |
| 85 | ||
| 86 | (let ((old '((1 . 2) (3 . 4)))) | |
| 87 | (pass-if old (valid-alist-copy? old (alist-copy old)))) | |
| 88 | ||
| 89 | (let ((old '((1 . 2) (3 . 4) (5 . 6)))) | |
| 90 | (pass-if old (valid-alist-copy? old (alist-copy old))))) | |
| 91 | ||
| 872223a8 KR |
92 | ;; |
| 93 | ;; alist-delete | |
| 94 | ;; | |
| 95 | ||
| 96 | (with-test-prefix "alist-delete" | |
| 97 | ||
| 98 | (pass-if "equality call arg order" | |
| 99 | (let ((good #f)) | |
| 100 | (alist-delete 'k '((ak . 123)) | |
| 101 | (lambda (k ak) | |
| 102 | (if (and (eq? k 'k) (eq? ak 'ak)) | |
| 103 | (set! good #t)))) | |
| 104 | good)) | |
| 105 | ||
| 106 | (pass-if "delete keys greater than 5" | |
| 107 | (equal? '((4 . x) (5 . y)) | |
| 108 | (alist-delete 5 '((4 . x) (5 . y) (6 . z)) <))) | |
| 109 | ||
| 110 | (pass-if "empty" | |
| 111 | (equal? '() (alist-delete 'x '()))) | |
| 112 | ||
| 113 | (pass-if "(y)" | |
| 114 | (equal? '() (alist-delete 'y '((y . 1))))) | |
| 115 | ||
| 116 | (pass-if "(n)" | |
| 117 | (equal? '((n . 1)) (alist-delete 'y '((n . 1))))) | |
| 118 | ||
| 119 | (pass-if "(y y)" | |
| 120 | (equal? '() (alist-delete 'y '((y . 1) (y . 2))))) | |
| 121 | ||
| 122 | (pass-if "(n y)" | |
| 123 | (equal? '((n . 1)) (alist-delete 'y '((n . 1) (y . 2))))) | |
| 124 | ||
| 125 | (pass-if "(y n)" | |
| 126 | (equal? '((n . 2)) (alist-delete 'y '((y . 1) (n . 2))))) | |
| 127 | ||
| 128 | (pass-if "(n n)" | |
| 129 | (equal? '((n . 1) (n . 2)) (alist-delete 'y '((n . 1) (n . 2))))) | |
| 130 | ||
| 131 | (pass-if "(y y y)" | |
| 132 | (equal? '() (alist-delete 'y '((y . 1) (y . 2) (y . 3))))) | |
| 133 | ||
| 134 | (pass-if "(n y y)" | |
| 135 | (equal? '((n . 1)) (alist-delete 'y '((n . 1) (y . 2) (y . 3))))) | |
| 136 | ||
| 137 | (pass-if "(y n y)" | |
| 138 | (equal? '((n . 2)) (alist-delete 'y '((y . 1) (n . 2) (y . 3))))) | |
| 139 | ||
| 140 | (pass-if "(n n y)" | |
| 141 | (equal? '((n . 1) (n . 2)) (alist-delete 'y '((n . 1) (n . 2) (y . 3))))) | |
| 142 | ||
| 143 | (pass-if "(y y n)" | |
| 144 | (equal? '( (n . 3)) (alist-delete 'y '((y . 1) (y . 2) (n . 3))))) | |
| 145 | ||
| 146 | (pass-if "(n y n)" | |
| 147 | (equal? '((n . 1) (n . 3)) (alist-delete 'y '((n . 1) (y . 2) (n . 3))))) | |
| 148 | ||
| 149 | (pass-if "(y n n)" | |
| 150 | (equal? '((n . 2) (n . 3)) (alist-delete 'y '((y . 1) (n . 2) (n . 3))))) | |
| 151 | ||
| 152 | (pass-if "(n n n)" | |
| 153 | (equal? '((n . 1) (n . 2) (n . 3)) (alist-delete 'y '((n . 1) (n . 2) (n . 3)))))) | |
| 154 | ||
| bbd1b480 KR |
155 | ;; |
| 156 | ;; append-map | |
| 157 | ;; | |
| 158 | ||
| 159 | (with-test-prefix "append-map" | |
| 160 | ||
| 161 | (with-test-prefix "one list" | |
| 162 | ||
| 163 | (pass-if "()" | |
| 164 | (equal? '() (append-map noop '(())))) | |
| 165 | ||
| 166 | (pass-if "(1)" | |
| 167 | (equal? '(1) (append-map noop '((1))))) | |
| 168 | ||
| 169 | (pass-if "(1 2)" | |
| 170 | (equal? '(1 2) (append-map noop '((1 2))))) | |
| 171 | ||
| 172 | (pass-if "() ()" | |
| 173 | (equal? '() (append-map noop '(() ())))) | |
| 174 | ||
| 175 | (pass-if "() (1)" | |
| 176 | (equal? '(1) (append-map noop '(() (1))))) | |
| 177 | ||
| 178 | (pass-if "() (1 2)" | |
| 179 | (equal? '(1 2) (append-map noop '(() (1 2))))) | |
| 180 | ||
| 181 | (pass-if "(1) (2)" | |
| 182 | (equal? '(1 2) (append-map noop '((1) (2))))) | |
| 183 | ||
| 184 | (pass-if "(1 2) ()" | |
| 185 | (equal? '(1 2) (append-map noop '(() (1 2)))))) | |
| 186 | ||
| 187 | (with-test-prefix "two lists" | |
| 188 | ||
| 189 | (pass-if "() / 9" | |
| 190 | (equal? '() (append-map noop '(()) '(9)))) | |
| 191 | ||
| 192 | (pass-if "(1) / 9" | |
| 193 | (equal? '(1) (append-map noop '((1)) '(9)))) | |
| 194 | ||
| 195 | (pass-if "() () / 9 9" | |
| 196 | (equal? '() (append-map noop '(() ()) '(9 9)))) | |
| 197 | ||
| 198 | (pass-if "(1) (2) / 9" | |
| 199 | (equal? '(1) (append-map noop '((1) (2)) '(9)))) | |
| 200 | ||
| 201 | (pass-if "(1) (2) / 9 9" | |
| 202 | (equal? '(1 2) (append-map noop '((1) (2)) '(9 9)))))) | |
| 203 | ||
| f0d1bc09 KR |
204 | ;; |
| 205 | ;; break | |
| 206 | ;; | |
| 207 | ||
| 208 | (with-test-prefix "break" | |
| 209 | ||
| 210 | (define (test-break lst want-v1 want-v2) | |
| 211 | (call-with-values | |
| 212 | (lambda () | |
| 213 | (break negative? lst)) | |
| 214 | (lambda (got-v1 got-v2) | |
| 215 | (and (equal? got-v1 want-v1) | |
| 216 | (equal? got-v2 want-v2))))) | |
| 217 | ||
| 218 | (pass-if "empty" | |
| 219 | (test-break '() '() '())) | |
| 220 | ||
| 221 | (pass-if "y" | |
| 222 | (test-break '(1) '(1) '())) | |
| 223 | ||
| 224 | (pass-if "n" | |
| 225 | (test-break '(-1) '() '(-1))) | |
| 226 | ||
| 227 | (pass-if "yy" | |
| 228 | (test-break '(1 2) '(1 2) '())) | |
| 229 | ||
| 230 | (pass-if "ny" | |
| 231 | (test-break '(-1 1) '() '(-1 1))) | |
| 232 | ||
| 233 | (pass-if "yn" | |
| 234 | (test-break '(1 -1) '(1) '(-1))) | |
| 235 | ||
| 236 | (pass-if "nn" | |
| 237 | (test-break '(-1 -2) '() '(-1 -2))) | |
| 238 | ||
| 239 | (pass-if "yyy" | |
| 240 | (test-break '(1 2 3) '(1 2 3) '())) | |
| 241 | ||
| 242 | (pass-if "nyy" | |
| 243 | (test-break '(-1 1 2) '() '(-1 1 2))) | |
| 244 | ||
| 245 | (pass-if "yny" | |
| 246 | (test-break '(1 -1 2) '(1) '(-1 2))) | |
| 247 | ||
| 248 | (pass-if "nny" | |
| 249 | (test-break '(-1 -2 1) '() '(-1 -2 1))) | |
| 250 | ||
| 251 | (pass-if "yyn" | |
| 252 | (test-break '(1 2 -1) '(1 2) '(-1))) | |
| 253 | ||
| 254 | (pass-if "nyn" | |
| 255 | (test-break '(-1 1 -2) '() '(-1 1 -2))) | |
| 256 | ||
| 257 | (pass-if "ynn" | |
| 258 | (test-break '(1 -1 -2) '(1) '(-1 -2))) | |
| 259 | ||
| 260 | (pass-if "nnn" | |
| 261 | (test-break '(-1 -2 -3) '() '(-1 -2 -3)))) | |
| 262 | ||
| c6e9db20 KR |
263 | ;; |
| 264 | ;; concatenate and concatenate! | |
| 265 | ;; | |
| 266 | ||
| 267 | (let () | |
| 268 | (define (common-tests concatenate-proc unmodified?) | |
| 269 | (define (try lstlst want) | |
| 270 | (let ((lstlst-copy (copy-tree lstlst)) | |
| 271 | (got (concatenate-proc lstlst))) | |
| 272 | (if unmodified? | |
| 273 | (if (not (equal? lstlst lstlst-copy)) | |
| 274 | (error "input lists modified"))) | |
| 275 | (equal? got want))) | |
| 276 | ||
| 277 | (pass-if-exception "too few args" exception:wrong-num-args | |
| 278 | (concatenate-proc)) | |
| 279 | ||
| 280 | (pass-if-exception "too many args" exception:wrong-num-args | |
| 281 | (concatenate-proc '() '())) | |
| 282 | ||
| 283 | (pass-if "no lists" | |
| 284 | (try '() '())) | |
| 285 | ||
| 286 | (pass-if (try '((1)) '(1))) | |
| 287 | (pass-if (try '((1 2)) '(1 2))) | |
| 288 | (pass-if (try '(() (1)) '(1))) | |
| 289 | (pass-if (try '(() () (1)) '(1))) | |
| 290 | ||
| 291 | (pass-if (try '((1) (2)) '(1 2))) | |
| 292 | (pass-if (try '(() (1 2)) '(1 2))) | |
| 293 | ||
| 294 | (pass-if (try '((1) 2) '(1 . 2))) | |
| 295 | (pass-if (try '((1) (2) 3) '(1 2 . 3))) | |
| 296 | (pass-if (try '((1) (2) (3 . 4)) '(1 2 3 . 4))) | |
| 297 | ) | |
| 298 | ||
| 299 | (with-test-prefix "concatenate" | |
| 300 | (common-tests concatenate #t)) | |
| 301 | ||
| 302 | (with-test-prefix "concatenate!" | |
| 303 | (common-tests concatenate! #f))) | |
| 304 | ||
| f3903293 KR |
305 | ;; |
| 306 | ;; count | |
| 307 | ;; | |
| 308 | ||
| 309 | (with-test-prefix "count" | |
| 310 | (pass-if-exception "no args" exception:wrong-num-args | |
| 311 | (count)) | |
| 312 | ||
| 313 | (pass-if-exception "one arg" exception:wrong-num-args | |
| 314 | (count noop)) | |
| 315 | ||
| 316 | (with-test-prefix "one list" | |
| 317 | (define (or1 x) | |
| 318 | x) | |
| 319 | ||
| 320 | (pass-if "empty list" (= 0 (count or1 '()))) | |
| 321 | ||
| 322 | (pass-if-exception "pred arg count 0" exception:wrong-type-arg | |
| 323 | (count (lambda () x) '(1 2 3))) | |
| 324 | (pass-if-exception "pred arg count 2" exception:wrong-type-arg | |
| 325 | (count (lambda (x y) x) '(1 2 3))) | |
| 326 | ||
| 327 | (pass-if-exception "improper 1" exception:wrong-type-arg | |
| 328 | (count or1 1)) | |
| 329 | (pass-if-exception "improper 2" exception:wrong-type-arg | |
| 330 | (count or1 '(1 . 2))) | |
| 331 | (pass-if-exception "improper 3" exception:wrong-type-arg | |
| 332 | (count or1 '(1 2 . 3))) | |
| 333 | ||
| 334 | (pass-if (= 0 (count or1 '(#f)))) | |
| 335 | (pass-if (= 1 (count or1 '(#t)))) | |
| 336 | ||
| 337 | (pass-if (= 0 (count or1 '(#f #f)))) | |
| 338 | (pass-if (= 1 (count or1 '(#f #t)))) | |
| 339 | (pass-if (= 1 (count or1 '(#t #f)))) | |
| 340 | (pass-if (= 2 (count or1 '(#t #t)))) | |
| 341 | ||
| 342 | (pass-if (= 0 (count or1 '(#f #f #f)))) | |
| 343 | (pass-if (= 1 (count or1 '(#f #f #t)))) | |
| 344 | (pass-if (= 1 (count or1 '(#t #f #f)))) | |
| 345 | (pass-if (= 2 (count or1 '(#t #f #t)))) | |
| 346 | (pass-if (= 3 (count or1 '(#t #t #t))))) | |
| 347 | ||
| 348 | (with-test-prefix "two lists" | |
| 349 | (define (or2 x y) | |
| 350 | (or x y)) | |
| 351 | ||
| 352 | (pass-if "arg order" | |
| 353 | (= 1 (count (lambda (x y) | |
| 354 | (and (= 1 x) | |
| 355 | (= 2 y))) | |
| 356 | '(1) '(2)))) | |
| 357 | ||
| 358 | (pass-if "empty lists" (= 0 (count or2 '() '()))) | |
| 359 | ||
| 360 | (pass-if-exception "pred arg count 0" exception:wrong-type-arg | |
| 361 | (count (lambda () #t) '(1 2 3) '(1 2 3))) | |
| 362 | (pass-if-exception "pred arg count 1" exception:wrong-type-arg | |
| 363 | (count (lambda (x) x) '(1 2 3) '(1 2 3))) | |
| 364 | (pass-if-exception "pred arg count 3" exception:wrong-type-arg | |
| 365 | (count (lambda (x y z) x) '(1 2 3) '(1 2 3))) | |
| 366 | ||
| 367 | (pass-if-exception "improper first 1" exception:wrong-type-arg | |
| 368 | (count or2 1 '(1 2 3))) | |
| 369 | (pass-if-exception "improper first 2" exception:wrong-type-arg | |
| 370 | (count or2 '(1 . 2) '(1 2 3))) | |
| 371 | (pass-if-exception "improper first 3" exception:wrong-type-arg | |
| 372 | (count or2 '(1 2 . 3) '(1 2 3))) | |
| 373 | ||
| 374 | (pass-if-exception "improper second 1" exception:wrong-type-arg | |
| 375 | (count or2 '(1 2 3) 1)) | |
| 376 | (pass-if-exception "improper second 2" exception:wrong-type-arg | |
| 377 | (count or2 '(1 2 3) '(1 . 2))) | |
| 378 | (pass-if-exception "improper second 3" exception:wrong-type-arg | |
| 379 | (count or2 '(1 2 3) '(1 2 . 3))) | |
| 380 | ||
| 381 | (pass-if (= 0 (count or2 '(#f) '(#f)))) | |
| 382 | (pass-if (= 1 (count or2 '(#t) '(#f)))) | |
| 383 | (pass-if (= 1 (count or2 '(#f) '(#t)))) | |
| 384 | ||
| 385 | (pass-if (= 0 (count or2 '(#f #f) '(#f #f)))) | |
| 386 | (pass-if (= 1 (count or2 '(#t #f) '(#t #f)))) | |
| 387 | (pass-if (= 2 (count or2 '(#t #t) '(#f #f)))) | |
| 388 | (pass-if (= 2 (count or2 '(#t #f) '(#f #t)))) | |
| 389 | ||
| 390 | (with-test-prefix "stop shortest" | |
| 391 | (pass-if (= 2 (count or2 '(#t #f #t) '(#f #t)))) | |
| 392 | (pass-if (= 2 (count or2 '(#t #f #t #t) '(#f #t)))) | |
| 393 | (pass-if (= 2 (count or2 '(#t #f) '(#f #t #t)))) | |
| 394 | (pass-if (= 2 (count or2 '(#t #f) '(#f #t #t #t)))))) | |
| 395 | ||
| 396 | (with-test-prefix "three lists" | |
| 397 | (define (or3 x y z) | |
| 398 | (or x y z)) | |
| 399 | ||
| 400 | (pass-if "arg order" | |
| 401 | (= 1 (count (lambda (x y z) | |
| 402 | (and (= 1 x) | |
| 403 | (= 2 y) | |
| 404 | (= 3 z))) | |
| 405 | '(1) '(2) '(3)))) | |
| 406 | ||
| 407 | (pass-if "empty lists" (= 0 (count or3 '() '() '()))) | |
| 408 | ||
| 409 | ;; currently bad pred argument gives wrong-num-args when 3 or more | |
| 410 | ;; lists, as opposed to wrong-type-arg for 1 or 2 lists | |
| 411 | (pass-if-exception "pred arg count 0" exception:wrong-num-args | |
| 412 | (count (lambda () #t) '(1 2 3) '(1 2 3) '(1 2 3))) | |
| 413 | (pass-if-exception "pred arg count 2" exception:wrong-num-args | |
| 414 | (count (lambda (x y) x) '(1 2 3) '(1 2 3)'(1 2 3) )) | |
| 415 | (pass-if-exception "pred arg count 4" exception:wrong-num-args | |
| 416 | (count (lambda (w x y z) x) '(1 2 3) '(1 2 3) '(1 2 3))) | |
| 417 | ||
| 418 | (pass-if-exception "improper first 1" exception:wrong-type-arg | |
| 419 | (count or3 1 '(1 2 3) '(1 2 3))) | |
| 420 | (pass-if-exception "improper first 2" exception:wrong-type-arg | |
| 421 | (count or3 '(1 . 2) '(1 2 3) '(1 2 3))) | |
| 422 | (pass-if-exception "improper first 3" exception:wrong-type-arg | |
| 423 | (count or3 '(1 2 . 3) '(1 2 3) '(1 2 3))) | |
| 424 | ||
| 425 | (pass-if-exception "improper second 1" exception:wrong-type-arg | |
| 426 | (count or3 '(1 2 3) 1 '(1 2 3))) | |
| 427 | (pass-if-exception "improper second 2" exception:wrong-type-arg | |
| 428 | (count or3 '(1 2 3) '(1 . 2) '(1 2 3))) | |
| 429 | (pass-if-exception "improper second 3" exception:wrong-type-arg | |
| 430 | (count or3 '(1 2 3) '(1 2 . 3) '(1 2 3))) | |
| 431 | ||
| 432 | (pass-if-exception "improper third 1" exception:wrong-type-arg | |
| 433 | (count or3 '(1 2 3) '(1 2 3) 1)) | |
| 434 | (pass-if-exception "improper third 2" exception:wrong-type-arg | |
| 435 | (count or3 '(1 2 3) '(1 2 3) '(1 . 2))) | |
| 436 | (pass-if-exception "improper third 3" exception:wrong-type-arg | |
| 437 | (count or3 '(1 2 3) '(1 2 3) '(1 2 . 3))) | |
| 438 | ||
| 439 | (pass-if (= 0 (count or3 '(#f) '(#f) '(#f)))) | |
| 440 | (pass-if (= 1 (count or3 '(#t) '(#f) '(#f)))) | |
| 441 | (pass-if (= 1 (count or3 '(#f) '(#t) '(#f)))) | |
| 442 | (pass-if (= 1 (count or3 '(#f) '(#f) '(#t)))) | |
| 443 | ||
| 444 | (pass-if (= 0 (count or3 '(#f #f) '(#f #f) '(#f #f)))) | |
| 445 | ||
| 446 | (pass-if (= 1 (count or3 '(#t #f) '(#f #f) '(#f #f)))) | |
| 447 | (pass-if (= 1 (count or3 '(#f #t) '(#f #f) '(#f #f)))) | |
| 448 | (pass-if (= 1 (count or3 '(#f #f) '(#t #f) '(#f #f)))) | |
| 449 | (pass-if (= 1 (count or3 '(#f #f) '(#f #t) '(#f #f)))) | |
| 450 | (pass-if (= 1 (count or3 '(#f #f) '(#f #f) '(#t #f)))) | |
| 451 | (pass-if (= 1 (count or3 '(#f #f) '(#f #f) '(#f #t)))) | |
| 452 | ||
| 453 | (pass-if (= 2 (count or3 '(#t #t) '(#f #f) '(#f #f)))) | |
| 454 | (pass-if (= 2 (count or3 '(#f #f) '(#t #t) '(#f #f)))) | |
| 455 | (pass-if (= 2 (count or3 '(#f #f) '(#f #f) '(#t #t)))) | |
| 456 | (pass-if (= 2 (count or3 '(#f #f) '(#t #f) '(#f #t)))) | |
| 457 | ||
| 458 | (with-test-prefix "stop shortest" | |
| 459 | (pass-if (= 0 (count or3 '() '(#t #t #t) '(#t #t)))) | |
| 460 | (pass-if (= 0 (count or3 '(#t #t #t) '() '(#t #t)))) | |
| 461 | (pass-if (= 0 (count or3 '(#t #t #t) '(#t #t) '()))) | |
| 462 | ||
| 463 | (pass-if (= 1 (count or3 '(#t) '(#t #t #t) '(#t #t)))) | |
| 464 | (pass-if (= 1 (count or3 '(#t #t #t) '(#t) '(#t #t)))) | |
| 465 | (pass-if (= 1 (count or3 '(#t #t #t) '(#t #t) '(#t))))))) | |
| c6e9db20 | 466 | |
| 8ec84fe5 KR |
467 | ;; |
| 468 | ;; delete and delete! | |
| 469 | ;; | |
| 470 | ||
| 471 | (let () | |
| 72f1b979 KR |
472 | ;; Call (PROC lst) for all lists of length up to 6, with all combinations |
| 473 | ;; of elements to be retained or deleted. Elements to retain are numbers, | |
| 474 | ;; 0 upwards. Elements to be deleted are #f. | |
| 475 | (define (test-lists proc) | |
| 476 | (do ((n 0 (1+ n))) | |
| 477 | ((>= n 6)) | |
| 478 | (do ((limit (ash 1 n)) | |
| 479 | (i 0 (1+ i))) | |
| 480 | ((>= i limit)) | |
| 481 | (let ((lst '())) | |
| 482 | (do ((bit 0 (1+ bit))) | |
| 483 | ((>= bit n)) | |
| 484 | (set! lst (cons (if (logbit? bit i) bit #f) lst))) | |
| 485 | (proc lst))))) | |
| 486 | ||
| 8ec84fe5 | 487 | (define (common-tests delete-proc) |
| 72f1b979 KR |
488 | (pass-if-exception "too few args" exception:wrong-num-args |
| 489 | (delete-proc 0)) | |
| 490 | ||
| 491 | (pass-if-exception "too many args" exception:wrong-num-args | |
| 492 | (delete-proc 0 '() equal? 99)) | |
| 493 | ||
| 494 | (pass-if "empty" | |
| 495 | (eq? '() (delete-proc 0 '()))) | |
| 496 | ||
| 497 | (pass-if "equal? (the default)" | |
| 498 | (equal? '((1) (3)) | |
| 499 | (delete-proc '(2) '((1) (2) (3))))) | |
| 500 | ||
| 501 | (pass-if "eq?" | |
| 502 | (equal? '((1) (2) (3)) | |
| 503 | (delete-proc '(2) '((1) (2) (3)) eq?))) | |
| 504 | ||
| 8ec84fe5 KR |
505 | (pass-if "called arg order" |
| 506 | (equal? '(1 2 3) | |
| 507 | (delete-proc 3 '(1 2 3 4 5) <)))) | |
| 508 | ||
| 509 | (with-test-prefix "delete" | |
| 72f1b979 | 510 | (common-tests delete) |
| 8ec84fe5 | 511 | |
| 72f1b979 KR |
512 | (test-lists |
| 513 | (lambda (lst) | |
| 514 | (let ((lst-copy (list-copy lst))) | |
| 515 | (with-test-prefix lst-copy | |
| 516 | (pass-if "result" | |
| 517 | (equal? (delete #f lst) | |
| 518 | (ref-delete #f lst))) | |
| 519 | (pass-if "non-destructive" | |
| 520 | (equal? lst-copy lst))))))) | |
| 521 | ||
| 8ec84fe5 | 522 | (with-test-prefix "delete!" |
| 72f1b979 KR |
523 | (common-tests delete!) |
| 524 | ||
| 525 | (test-lists | |
| 526 | (lambda (lst) | |
| 527 | (pass-if lst | |
| 528 | (equal? (delete! #f lst) | |
| 529 | (ref-delete #f lst))))))) | |
| 530 | ||
| 531 | ;; | |
| 532 | ;; delete-duplicates and delete-duplicates! | |
| 533 | ;; | |
| 534 | ||
| 535 | (let () | |
| 536 | ;; Call (PROC lst) for all lists of length 1 <= n <= 4, with all | |
| 537 | ;; combinations of numbers 1 to n in the elements | |
| 538 | (define (test-lists proc) | |
| 539 | (do ((n 1 (1+ n))) | |
| 540 | ((> n 4)) | |
| 541 | (do ((limit (integer-expt n n)) | |
| 542 | (i 0 (1+ i))) | |
| 543 | ((>= i limit)) | |
| 544 | (let ((lst '())) | |
| 545 | (do ((j 0 (1+ j)) | |
| 546 | (rem i (quotient rem n))) | |
| 547 | ((>= j n)) | |
| 548 | (set! lst (cons (remainder rem n) lst))) | |
| 549 | (proc lst))))) | |
| 550 | ||
| 551 | (define (common-tests delete-duplicates-proc) | |
| 552 | (pass-if-exception "too few args" exception:wrong-num-args | |
| 553 | (delete-duplicates-proc)) | |
| 554 | ||
| 555 | (pass-if-exception "too many args" exception:wrong-num-args | |
| 556 | (delete-duplicates-proc '() equal? 99)) | |
| 557 | ||
| 558 | (pass-if "empty" | |
| 559 | (eq? '() (delete-duplicates-proc '()))) | |
| 560 | ||
| 561 | (pass-if "equal? (the default)" | |
| 562 | (equal? '((2)) | |
| 563 | (delete-duplicates-proc '((2) (2) (2))))) | |
| 564 | ||
| 565 | (pass-if "eq?" | |
| 566 | (equal? '((2) (2) (2)) | |
| 567 | (delete-duplicates-proc '((2) (2) (2)) eq?))) | |
| 568 | ||
| 569 | (pass-if "called arg order" | |
| 570 | (let ((ok #t)) | |
| 571 | (delete-duplicates-proc '(1 2 3 4 5) | |
| 572 | (lambda (x y) | |
| 573 | (if (> x y) | |
| 574 | (set! ok #f)) | |
| 575 | #f)) | |
| 576 | ok))) | |
| 577 | ||
| 578 | (with-test-prefix "delete-duplicates" | |
| 579 | (common-tests delete-duplicates) | |
| 580 | ||
| 581 | (test-lists | |
| 582 | (lambda (lst) | |
| 583 | (let ((lst-copy (list-copy lst))) | |
| 584 | (with-test-prefix lst-copy | |
| 585 | (pass-if "result" | |
| 586 | (equal? (delete-duplicates lst) | |
| 587 | (ref-delete-duplicates lst))) | |
| 588 | (pass-if "non-destructive" | |
| 589 | (equal? lst-copy lst))))))) | |
| 590 | ||
| 591 | (with-test-prefix "delete-duplicates!" | |
| 592 | (common-tests delete-duplicates!) | |
| 593 | ||
| 594 | (test-lists | |
| 595 | (lambda (lst) | |
| 596 | (pass-if lst | |
| 597 | (equal? (delete-duplicates! lst) | |
| 598 | (ref-delete-duplicates lst))))))) | |
| 8ec84fe5 | 599 | |
| 91e7199f KR |
600 | ;; |
| 601 | ;; drop | |
| 602 | ;; | |
| 603 | ||
| 604 | (with-test-prefix "drop" | |
| 605 | ||
| 606 | (pass-if "'() 0" | |
| 607 | (null? (drop '() 0))) | |
| 608 | ||
| 609 | (pass-if "'(a) 0" | |
| 610 | (let ((lst '(a))) | |
| 611 | (eq? lst | |
| 612 | (drop lst 0)))) | |
| 613 | ||
| 614 | (pass-if "'(a b) 0" | |
| 615 | (let ((lst '(a b))) | |
| 616 | (eq? lst | |
| 617 | (drop lst 0)))) | |
| 618 | ||
| 619 | (pass-if "'(a) 1" | |
| 620 | (let ((lst '(a))) | |
| 621 | (eq? (cdr lst) | |
| 622 | (drop lst 1)))) | |
| 623 | ||
| 624 | (pass-if "'(a b) 1" | |
| 625 | (let ((lst '(a b))) | |
| 626 | (eq? (cdr lst) | |
| 627 | (drop lst 1)))) | |
| 628 | ||
| 629 | (pass-if "'(a b) 2" | |
| 630 | (let ((lst '(a b))) | |
| 631 | (eq? (cddr lst) | |
| 632 | (drop lst 2)))) | |
| 633 | ||
| 634 | (pass-if "'(a b c) 1" | |
| 635 | (let ((lst '(a b c))) | |
| 636 | (eq? (cddr lst) | |
| 637 | (drop lst 2)))) | |
| 638 | ||
| 639 | (pass-if "circular '(a) 0" | |
| 640 | (let ((lst (circular-list 'a))) | |
| 641 | (eq? lst | |
| 642 | (drop lst 0)))) | |
| 643 | ||
| 644 | (pass-if "circular '(a) 1" | |
| 645 | (let ((lst (circular-list 'a))) | |
| 646 | (eq? lst | |
| 647 | (drop lst 1)))) | |
| 648 | ||
| 649 | (pass-if "circular '(a) 2" | |
| 650 | (let ((lst (circular-list 'a))) | |
| 651 | (eq? lst | |
| 652 | (drop lst 1)))) | |
| 653 | ||
| 654 | (pass-if "circular '(a b) 1" | |
| 655 | (let ((lst (circular-list 'a))) | |
| 656 | (eq? (cdr lst) | |
| 657 | (drop lst 0)))) | |
| 658 | ||
| 659 | (pass-if "circular '(a b) 2" | |
| 660 | (let ((lst (circular-list 'a))) | |
| 661 | (eq? lst | |
| 662 | (drop lst 1)))) | |
| 663 | ||
| 664 | (pass-if "circular '(a b) 5" | |
| 665 | (let ((lst (circular-list 'a))) | |
| 666 | (eq? (cdr lst) | |
| 667 | (drop lst 5)))) | |
| 668 | ||
| 669 | (pass-if "'(a . b) 1" | |
| 670 | (eq? 'b | |
| 671 | (drop '(a . b) 1))) | |
| 672 | ||
| 673 | (pass-if "'(a b . c) 1" | |
| 674 | (equal? 'c | |
| 675 | (drop '(a b . c) 2)))) | |
| 676 | ||
| a52ef9e4 KR |
677 | ;; |
| 678 | ;; filter-map | |
| 679 | ;; | |
| 680 | ||
| 681 | (with-test-prefix "filter-map" | |
| 682 | ||
| 683 | (with-test-prefix "one list" | |
| 684 | (pass-if "(1)" | |
| 685 | (equal? '(1) (filter-map noop '(1)))) | |
| 686 | ||
| 687 | (pass-if "(#f)" | |
| 688 | (equal? '() (filter-map noop '(#f)))) | |
| 689 | ||
| 690 | (pass-if "(1 2)" | |
| 691 | (equal? '(1 2) (filter-map noop '(1 2)))) | |
| 692 | ||
| 693 | (pass-if "(#f 2)" | |
| 694 | (equal? '(2) (filter-map noop '(#f 2)))) | |
| 695 | ||
| 696 | (pass-if "(#f #f)" | |
| 697 | (equal? '() (filter-map noop '(#f #f)))) | |
| 698 | ||
| 699 | (pass-if "(1 2 3)" | |
| 700 | (equal? '(1 2 3) (filter-map noop '(1 2 3)))) | |
| 701 | ||
| 702 | (pass-if "(#f 2 3)" | |
| 703 | (equal? '(2 3) (filter-map noop '(#f 2 3)))) | |
| 704 | ||
| 705 | (pass-if "(1 #f 3)" | |
| 706 | (equal? '(1 3) (filter-map noop '(1 #f 3)))) | |
| 707 | ||
| 708 | (pass-if "(1 2 #f)" | |
| 709 | (equal? '(1 2) (filter-map noop '(1 2 #f))))) | |
| 710 | ||
| 711 | (with-test-prefix "two lists" | |
| 712 | (pass-if "(1 2 3) (4 5 6)" | |
| 713 | (equal? '(1 2 3) (filter-map noop '(1 2 3) '(4 5 6)))) | |
| 714 | ||
| 715 | (pass-if "(#f 2 3) (4 5)" | |
| 716 | (equal? '(2) (filter-map noop '(#f 2 3) '(4 5)))) | |
| 717 | ||
| 718 | (pass-if "(4 #f) (1 2 3)" | |
| 719 | (equal? '(4) (filter-map noop '(4 #f) '(1 2 3)))))) | |
| 720 | ||
| 15d36a34 KR |
721 | ;; |
| 722 | ;; length+ | |
| 723 | ;; | |
| 724 | ||
| 725 | (with-test-prefix "length+" | |
| 726 | (pass-if-exception "too few args" exception:wrong-num-args | |
| 727 | (length+)) | |
| 728 | (pass-if-exception "too many args" exception:wrong-num-args | |
| 729 | (length+ 123 456)) | |
| 730 | (pass-if (= 0 (length+ '()))) | |
| 731 | (pass-if (= 1 (length+ '(x)))) | |
| 732 | (pass-if (= 2 (length+ '(x y)))) | |
| 733 | (pass-if (= 3 (length+ '(x y z)))) | |
| 734 | (pass-if (not (length+ (circular-list 1)))) | |
| 735 | (pass-if (not (length+ (circular-list 1 2)))) | |
| 736 | (pass-if (not (length+ (circular-list 1 2 3))))) | |
| 737 | ||
| b052db69 KR |
738 | ;; |
| 739 | ;; list-copy | |
| 740 | ;; | |
| 741 | ||
| 742 | (with-test-prefix "list-copy" | |
| b052db69 KR |
743 | (pass-if (equal? '() (list-copy '()))) |
| 744 | (pass-if (equal? '(1 2) (list-copy '(1 2)))) | |
| 745 | (pass-if (equal? '(1 2 3) (list-copy '(1 2 3)))) | |
| 746 | (pass-if (equal? '(1 2 3 4) (list-copy '(1 2 3 4)))) | |
| 747 | (pass-if (equal? '(1 2 3 4 5) (list-copy '(1 2 3 4 5)))) | |
| 748 | ||
| 749 | ;; improper lists can be copied | |
| 750 | (pass-if (equal? 1 (list-copy 1))) | |
| 751 | (pass-if (equal? '(1 . 2) (list-copy '(1 . 2)))) | |
| 752 | (pass-if (equal? '(1 2 . 3) (list-copy '(1 2 . 3)))) | |
| 753 | (pass-if (equal? '(1 2 3 . 4) (list-copy '(1 2 3 . 4)))) | |
| 754 | (pass-if (equal? '(1 2 3 4 . 5) (list-copy '(1 2 3 4 . 5))))) | |
| 755 | ||
| 76822573 KR |
756 | ;; |
| 757 | ;; lset= | |
| 758 | ;; | |
| 759 | ||
| 760 | (with-test-prefix "lset=" | |
| 761 | ||
| 762 | ;; prior to guile 1.6.8 at least one list arg was (incorrectly) required | |
| 763 | (pass-if "no args" | |
| 764 | (eq? #t (lset= eq?))) | |
| 765 | ||
| 766 | (with-test-prefix "one arg" | |
| 767 | ||
| 768 | (pass-if "()" | |
| 769 | (eq? #t (lset= eqv? '()))) | |
| 770 | ||
| 771 | (pass-if "(1)" | |
| 772 | (eq? #t (lset= eqv? '(1)))) | |
| 773 | ||
| 774 | (pass-if "(1 2)" | |
| 775 | (eq? #t (lset= eqv? '(1 2))))) | |
| 776 | ||
| 777 | (with-test-prefix "two args" | |
| 778 | ||
| 779 | (pass-if "() ()" | |
| 780 | (eq? #t (lset= eqv? '() '()))) | |
| 781 | ||
| 782 | (pass-if "(1) (1)" | |
| 783 | (eq? #t (lset= eqv? '(1) '(1)))) | |
| 784 | ||
| 785 | (pass-if "(1) (2)" | |
| 786 | (eq? #f (lset= eqv? '(1) '(2)))) | |
| 787 | ||
| 788 | (pass-if "(1) (1 2)" | |
| 789 | (eq? #f (lset= eqv? '(1) '(1 2)))) | |
| 790 | ||
| 791 | (pass-if "(1 2) (2 1)" | |
| 792 | (eq? #t (lset= eqv? '(1 2) '(2 1)))) | |
| 793 | ||
| 794 | (pass-if "called arg order" | |
| 795 | (let ((good #t)) | |
| 796 | (lset= (lambda (x y) | |
| 797 | (if (not (= x (1- y))) | |
| 798 | (set! good #f)) | |
| 799 | #t) | |
| 800 | '(1 1) '(2 2)) | |
| 801 | good))) | |
| 802 | ||
| 803 | (with-test-prefix "three args" | |
| 804 | ||
| 805 | (pass-if "() () ()" | |
| 806 | (eq? #t (lset= eqv? '() '() '()))) | |
| 807 | ||
| 808 | (pass-if "(1) (1) (1)" | |
| 809 | (eq? #t (lset= eqv? '(1) '(1) '(1)))) | |
| 810 | ||
| 811 | (pass-if "(1) (1) (2)" | |
| 812 | (eq? #f (lset= eqv? '(1) '(1) '(2)))) | |
| 813 | ||
| 814 | (pass-if "(1) (1) (1 2)" | |
| 815 | (eq? #f (lset= eqv? '(1) '(1) '(1 2)))) | |
| 816 | ||
| 817 | (pass-if "(1 2 3) (3 2 1) (1 3 2)" | |
| 818 | (eq? #t (lset= eqv? '(1 2 3) '(3 2 1) '(1 3 2)))) | |
| 819 | ||
| 820 | (pass-if "called arg order" | |
| 821 | (let ((good #t)) | |
| 822 | (lset= (lambda (x y) | |
| 823 | (if (not (= x (1- y))) | |
| 824 | (set! good #f)) | |
| 825 | #t) | |
| 826 | '(1 1) '(2 2) '(3 3)) | |
| 827 | good)))) | |
| 828 | ||
| 829 | ;; | |
| 830 | ;; member | |
| 831 | ;; | |
| 832 | ||
| 833 | (with-test-prefix "member" | |
| 834 | ||
| 835 | (pass-if-exception "no args" exception:wrong-num-args | |
| 836 | (member)) | |
| 837 | ||
| 838 | (pass-if-exception "one arg" exception:wrong-num-args | |
| 839 | (member 1)) | |
| 840 | ||
| 841 | (pass-if "1 (1 2 3)" | |
| 842 | (let ((lst '(1 2 3))) | |
| 843 | (eq? lst (member 1 lst)))) | |
| 844 | ||
| 845 | (pass-if "2 (1 2 3)" | |
| 846 | (let ((lst '(1 2 3))) | |
| 847 | (eq? (cdr lst) (member 2 lst)))) | |
| 848 | ||
| 849 | (pass-if "3 (1 2 3)" | |
| 850 | (let ((lst '(1 2 3))) | |
| 851 | (eq? (cddr lst) (member 3 lst)))) | |
| 852 | ||
| 853 | (pass-if "4 (1 2 3)" | |
| 854 | (let ((lst '(1 2 3))) | |
| 855 | (eq? #f (member 4 lst)))) | |
| 856 | ||
| 857 | (pass-if "called arg order" | |
| 858 | (let ((good #f)) | |
| 859 | (member 1 '(2) (lambda (x y) | |
| 860 | (set! good (and (eqv? 1 x) | |
| 861 | (eqv? 2 y))))) | |
| 862 | good))) | |
| 863 | ||
| 91e7199f KR |
864 | ;; |
| 865 | ;; take | |
| 866 | ;; | |
| 867 | ||
| 868 | (with-test-prefix "take" | |
| 869 | ||
| 870 | (pass-if "'() 0" | |
| 871 | (null? (take '() 0))) | |
| 872 | ||
| 873 | (pass-if "'(a) 0" | |
| 874 | (null? (take '(a) 0))) | |
| 875 | ||
| 876 | (pass-if "'(a b) 0" | |
| 877 | (null? (take '() 0))) | |
| 878 | ||
| 879 | (pass-if "'(a b c) 0" | |
| 880 | (null? (take '() 0))) | |
| 881 | ||
| 882 | (pass-if "'(a) 1" | |
| 883 | (let* ((lst '(a)) | |
| 884 | (got (take lst 1))) | |
| 885 | (and (equal? '(a) got) | |
| 886 | (not (eq? lst got))))) | |
| 887 | ||
| 888 | (pass-if "'(a b) 1" | |
| 889 | (equal? '(a) | |
| 890 | (take '(a b) 1))) | |
| 891 | ||
| 892 | (pass-if "'(a b c) 1" | |
| 893 | (equal? '(a) | |
| 894 | (take '(a b c) 1))) | |
| 895 | ||
| 896 | (pass-if "'(a b) 2" | |
| 897 | (let* ((lst '(a b)) | |
| 898 | (got (take lst 2))) | |
| 899 | (and (equal? '(a b) got) | |
| 900 | (not (eq? lst got))))) | |
| 901 | ||
| 902 | (pass-if "'(a b c) 2" | |
| 903 | (equal? '(a b) | |
| 904 | (take '(a b c) 2))) | |
| 905 | ||
| 906 | (pass-if "circular '(a) 0" | |
| 907 | (equal? '() | |
| 908 | (take (circular-list 'a) 0))) | |
| 909 | ||
| 910 | (pass-if "circular '(a) 1" | |
| 911 | (equal? '(a) | |
| 912 | (take (circular-list 'a) 1))) | |
| 913 | ||
| 914 | (pass-if "circular '(a) 2" | |
| 915 | (equal? '(a a) | |
| 916 | (take (circular-list 'a) 2))) | |
| 917 | ||
| 918 | (pass-if "circular '(a b) 5" | |
| 919 | (equal? '(a b a b a) | |
| 920 | (take (circular-list 'a 'b) 5))) | |
| 921 | ||
| 922 | (pass-if "'(a . b) 1" | |
| 923 | (equal? '(a) | |
| 924 | (take '(a . b) 1))) | |
| 925 | ||
| 926 | (pass-if "'(a b . c) 1" | |
| 927 | (equal? '(a) | |
| 928 | (take '(a b . c) 1))) | |
| 929 | ||
| 930 | (pass-if "'(a b . c) 2" | |
| 931 | (equal? '(a b) | |
| 932 | (take '(a b . c) 2)))) | |
| 9a029e41 KR |
933 | |
| 934 | ;; | |
| 935 | ;; partition | |
| 936 | ;; | |
| 937 | ||
| 938 | (define (test-partition pred list kept-good dropped-good) | |
| 939 | (call-with-values (lambda () | |
| 940 | (partition pred list)) | |
| 941 | (lambda (kept dropped) | |
| 942 | (and (equal? kept kept-good) | |
| 943 | (equal? dropped dropped-good))))) | |
| 944 | ||
| 945 | (with-test-prefix "partition" | |
| 946 | ||
| 947 | (pass-if "with dropped tail" | |
| 948 | (test-partition even? '(1 2 3 4 5 6 7) | |
| 949 | '(2 4 6) '(1 3 5 7))) | |
| 950 | ||
| 951 | (pass-if "with kept tail" | |
| 952 | (test-partition even? '(1 2 3 4 5 6) | |
| 953 | '(2 4 6) '(1 3 5))) | |
| 954 | ||
| 955 | (pass-if "with everything dropped" | |
| 956 | (test-partition even? '(1 3 5 7) | |
| 957 | '() '(1 3 5 7))) | |
| 958 | ||
| 959 | (pass-if "with everything kept" | |
| 960 | (test-partition even? '(2 4 6) | |
| 961 | '(2 4 6) '())) | |
| 962 | ||
| 963 | (pass-if "with empty list" | |
| 964 | (test-partition even? '() | |
| 965 | '() '())) | |
| 966 | ||
| 967 | (pass-if "with reasonably long list" | |
| 968 | ;; the old implementation from SRFI-1 reference implementation | |
| 969 | ;; would signal a stack-overflow for a list of only 500 elements! | |
| 970 | (call-with-values (lambda () | |
| 971 | (partition even? | |
| 972 | (make-list 10000 1))) | |
| 973 | (lambda (even odd) | |
| 974 | (and (= (length odd) 10000) | |
| 975 | (= (length even) 0)))))) | |
| 976 | ||
| ee0301df KR |
977 | ;; |
| 978 | ;; span | |
| 979 | ;; | |
| 980 | ||
| 981 | (with-test-prefix "span" | |
| 982 | ||
| 983 | (define (test-span lst want-v1 want-v2) | |
| 984 | (call-with-values | |
| 985 | (lambda () | |
| 986 | (span positive? lst)) | |
| 987 | (lambda (got-v1 got-v2) | |
| 988 | (and (equal? got-v1 want-v1) | |
| 989 | (equal? got-v2 want-v2))))) | |
| 990 | ||
| 991 | (pass-if "empty" | |
| 992 | (test-span '() '() '())) | |
| 993 | ||
| 994 | (pass-if "y" | |
| 995 | (test-span '(1) '(1) '())) | |
| 996 | ||
| 997 | (pass-if "n" | |
| 998 | (test-span '(-1) '() '(-1))) | |
| 999 | ||
| 1000 | (pass-if "yy" | |
| 1001 | (test-span '(1 2) '(1 2) '())) | |
| 1002 | ||
| 1003 | (pass-if "ny" | |
| 1004 | (test-span '(-1 1) '() '(-1 1))) | |
| 1005 | ||
| 1006 | (pass-if "yn" | |
| 1007 | (test-span '(1 -1) '(1) '(-1))) | |
| 1008 | ||
| 1009 | (pass-if "nn" | |
| 1010 | (test-span '(-1 -2) '() '(-1 -2))) | |
| 1011 | ||
| 1012 | (pass-if "yyy" | |
| 1013 | (test-span '(1 2 3) '(1 2 3) '())) | |
| 1014 | ||
| 1015 | (pass-if "nyy" | |
| 1016 | (test-span '(-1 1 2) '() '(-1 1 2))) | |
| 1017 | ||
| 1018 | (pass-if "yny" | |
| 1019 | (test-span '(1 -1 2) '(1) '(-1 2))) | |
| 1020 | ||
| 1021 | (pass-if "nny" | |
| 1022 | (test-span '(-1 -2 1) '() '(-1 -2 1))) | |
| 1023 | ||
| 1024 | (pass-if "yyn" | |
| 1025 | (test-span '(1 2 -1) '(1 2) '(-1))) | |
| 1026 | ||
| 1027 | (pass-if "nyn" | |
| 1028 | (test-span '(-1 1 -2) '() '(-1 1 -2))) | |
| 1029 | ||
| 1030 | (pass-if "ynn" | |
| 1031 | (test-span '(1 -1 -2) '(1) '(-1 -2))) | |
| 1032 | ||
| 1033 | (pass-if "nnn" | |
| 1034 | (test-span '(-1 -2 -3) '() '(-1 -2 -3)))) |